* [bug#36404] [PATCH 0/6] Add 'guix deploy'.
@ 2019-06-27 18:35 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
` (4 more replies)
0 siblings, 5 replies; 84+ messages in thread
From: Jakob L. Kreuze @ 2019-06-27 18:35 UTC (permalink / raw)
To: 36404
[-- Attachment #1: Type: text/plain, Size: 5560 bytes --]
Hello, Guix!
This patch provides the basis for 'guix deploy', implementing what I've
referred to as the "simple case" in my progress reports: in-place
updates to machines (physical or virtual) whose name and IP address we
know well. Do note that these commits depend on Ludovic's implementation
of 'remote-eval'.[1]
There's certainly more to be done with this -- the GSoC period is far
from over, and I'm hoping to use that time to implement more complex
use-cases such as automatically provisioning virtual machines in the
cloud. I'm submitting a patch series now per the recommendation of my
mentors to break the project into a few chunks to submit over the
duration of the summer.
Quite a bit has changed since my last email about this.[2] For one,
GOOPS is no longer used. Machine declarations now look just like any
other sort of declaration in Guix.
#+BEGIN_SRC scheme
(use-modules (gnu) (guix))
(use-machine-modules ssh)
(use-service-modules networking ssh)
(use-package-modules bootloaders)
(define %system
(operating-system
(host-name "gnu-deployed")
(timezone "Etc/UTC")
(bootloader (bootloader-configuration
(bootloader grub-bootloader)
(target "/dev/vda")
(terminal-outputs '(console))))
(file-systems (cons (file-system
(mount-point "/")
(device "/dev/vda1")
(type "ext4"))
%base-file-systems))
(services
(append (list (service dhcp-client-service-type)
(service openssh-service-type
(openssh-configuration
(permit-root-login #t)
(allow-empty-passwords? #t))))
%base-services))))
(list (machine
(system %system)
(environment 'managed-host)
(configuration (machine-ssh-configuration
(host-name "localhost")
(identity "./id_rsa")
(port 2222)))))
#+END_SRC scheme
There are a number of other differences here as well. For one, the SSH
configuration now has an 'identity' field for specifying a private key
to use when authenticating with the host. Any key management scheme you
might have set up in '~/.ssh/config' will also work if the 'identity'
field is omitted.
The 'environment' field is where we declare how machines should be
provisioned. In this case, the only type of provisioning that's been
implemented is 'managed-host' -- the "simple case" of in-place updates
to a machine that's already running GuixSD. The parameters for
provisioning are given in the form of an environment-specific
configuration type. In the example, this is 'machine-ssh-configuration',
which describes how 'guix deploy' should make an SSH connection to the
machine. I'm sure you can imagine something along the lines of a
'machine-digitalocean-configuration', describing some parameters for a
droplet.
There are two things in this patch series that I'd like comments on in
particular.
First, I still haven't figured out the whole testing situation. The
tests, as of now, spin up a virtual machine, create a machine instance,
deploy that to the virtual machine, and then make assertions about
changes made to the system. These tests were originally in the system
test suite as they deal with virtual machines, but I've since moved it
into the normal Guix test suite because of how much needs to be done on
the host side -- I spent an absurd amount of time trying to fit a call
to 'deploy-machine' into a derivation that could be run by the system
test suite, but I just wasn't able to make it work. I'm hoping someone
will have thoughts about how we can test 'guix deploy'. Should we have
them disabled by default? Is there some way to implement them in the a
system test suite that I've overlooked? Should the tests be included at
all?
Second, I'd like some suggestions on how to go about the documentation.
I have a cursory description of how to invoke the command-line tool, and
an example of a deployment specification, but I'm wondering if the
documentation should be split up into multiple sections across the
manual -- especially if we're going to have multiple 'environment' types
with their own configuration records down the line.
I look forward to your comments.
Regards,
Jakob
[1]: https://lists.gnu.org/archive/html/guix-patches/2019-06/msg00201.html
[2]: https://lists.gnu.org/archive/html/guix-devel/2019-06/msg00078.html
David Thompson (1):
Take another stab at this whole guix deploy thing.
Jakob L. Kreuze (5):
ssh: Add 'identity' keyword to 'open-ssh-session'.
gnu: Add machine type for deployment specifications.
Export the (gnu machine) interface.
Add 'guix deploy'.
doc: Add section for 'guix deploy'.
Makefile.am | 4 +-
doc/guix.texi | 103 +++++++++
gnu.scm | 8 +-
gnu/local.mk | 5 +-
gnu/machine.scm | 89 ++++++++
gnu/machine/ssh.scm | 355 +++++++++++++++++++++++++++++++
guix/scripts/deploy.scm | 90 ++++++++
guix/ssh.scm | 3 +-
tests/machine.scm | 450 ++++++++++++++++++++++++++++++++++++++++
9 files changed, 1103 insertions(+), 4 deletions(-)
create mode 100644 gnu/machine.scm
create mode 100644 gnu/machine/ssh.scm
create mode 100644 guix/scripts/deploy.scm
create mode 100644 tests/machine.scm
--
2.22.0
[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]
^ permalink raw reply [flat|nested] 84+ messages in thread* [bug#36404] [PATCH 1/6] Take another stab at this whole guix deploy thing. 2019-06-27 18:35 [bug#36404] [PATCH 0/6] Add 'guix deploy' Jakob L. Kreuze @ 2019-06-27 18:38 ` 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 20:05 ` [bug#36404] [PATCH 0/6] Add 'guix deploy' Thompson, David ` (3 subsequent siblings) 4 siblings, 1 reply; 84+ messages in thread From: Jakob L. Kreuze @ 2019-06-27 18:38 UTC (permalink / raw) To: 36404 2019-03-09 David Thompson <dthompson2@worcester.edu> * guix/scripts/deploy.scm: New file. * Makefile.am (MODULES): Add it. * gnu/machine.scm: New file. * gnu/local.mk (GNU_SYSTEM_MODULES): Add it. --- Makefile.am | 1 + gnu/local.mk | 3 +- gnu/machine.scm | 59 ++++++++++++++++++++++++++++++++ guix/scripts/deploy.scm | 76 +++++++++++++++++++++++++++++++++++++++++ 4 files changed, 138 insertions(+), 1 deletion(-) create mode 100644 gnu/machine.scm create mode 100644 guix/scripts/deploy.scm diff --git a/Makefile.am b/Makefile.am index 80be73e4bf..ba01264a4b 100644 --- a/Makefile.am +++ b/Makefile.am @@ -266,6 +266,7 @@ MODULES = \ guix/scripts/weather.scm \ guix/scripts/container.scm \ guix/scripts/container/exec.scm \ + guix/scripts/deploy.scm \ guix.scm \ $(GNU_SYSTEM_MODULES) diff --git a/gnu/local.mk b/gnu/local.mk index f5d53b49b8..f973a8d804 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -563,6 +563,7 @@ GNU_SYSTEM_MODULES = \ %D%/system/shadow.scm \ %D%/system/uuid.scm \ %D%/system/vm.scm \ + %D%/machine.scm \ \ %D%/build/accounts.scm \ %D%/build/activation.scm \ @@ -629,7 +630,7 @@ INSTALLER_MODULES = \ %D%/installer/newt/user.scm \ %D%/installer/newt/utils.scm \ %D%/installer/newt/welcome.scm \ - %D%/installer/newt/wifi.scm + %D%/installer/newt/wifi.scm # Always ship the installer modules but compile them only when # ENABLE_INSTALLER is true. diff --git a/gnu/machine.scm b/gnu/machine.scm new file mode 100644 index 0000000000..4fde7d5c01 --- /dev/null +++ b/gnu/machine.scm @@ -0,0 +1,59 @@ +(define-module (gnu machine) + #:use-module ((gnu packages package-management) #:select (guix)) + #:use-module (gnu system) + #:use-module (guix derivations) + #:use-module (guix inferior) + #:use-module (guix packages) + #:use-module (guix ssh) + #:use-module (guix store) + #:use-module (oop goops) + #:use-module (ssh session) + #:export (<machine> + system + display-name + build-os + deploy-os + remote-eval + + <sshable-machine> + host-name + ssh-port + ssh-user)) + +(define-class <machine> () + (system #:getter system #:init-keyword #:system)) + +(define-method (display-name (machine <machine>)) + (operating-system-host-name (system machine))) + +(define-method (build-os (machine <machine>) store) + (let* ((guixdrv (run-with-store store (package->derivation guix))) + (guixdir (and (build-derivations store (list guixdrv)) + (derivation->output-path guixdrv))) + (osdrv (run-with-store store (operating-system-derivation + (system machine))))) + (and (build-derivations store (list osdrv)) + (list (derivation-file-name osdrv) + (derivation->output-path osdrv))))) + +(define-method (deploy-os (machine <machine>) store osdrv) + (error "not implemented")) + +(define-method (remote-eval (machine <machine>) exp) + (error "not implemented")) + +(define-class <sshable-machine> (<machine>) + (host-name #:getter host-name #:init-keyword #:host-name) + (ssh-port #:getter ssh-port #:init-keyword #:ssh-port #:init-form 22) + (ssh-user #:getter ssh-user #:init-keyword #:ssh-user #:init-form "root") + ;; ??? - SSH key config? + ) + +(define-method (deploy-os (machine <sshable-machine>) store osdrvs) + (let ((session (open-ssh-session (host-name machine) + #:user (ssh-user machine) + #:port (ssh-port machine)))) + (with-store store (send-files store osdrvs + (connect-to-remote-daemon session) + #:recursive? #t)) + #t)) diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm new file mode 100644 index 0000000000..bcb3a2ea4c --- /dev/null +++ b/guix/scripts/deploy.scm @@ -0,0 +1,76 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 David Thompson <davet@gnu.org> +;;; +;;; 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 <http://www.gnu.org/licenses/>. + +(define-module (guix scripts deploy) + #:use-module (gnu machine) + #:use-module (guix ui) + #:use-module (guix scripts) + #:use-module (guix scripts build) + #:use-module (guix store) + #:use-module (ice-9 format) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-37) + #:export (guix-deploy)) + +(define (show-help) + (display (G_ "Usage: guix deploy WHATEVER\n"))) + +(define %options + (cons* (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + %standard-build-options)) + +(define %default-options + '((system . ,(%current-system)) + (substitutes? . #t) + (build-hook? . #t) + (graft? . #t) + (print-build-trace? . #t) + (print-extended-build-trace? . #t) + (multiplexed-build-output? . #t) + (debug . 0) + (verbosity . 2))) + +(define (load-source-file file) + (let ((module (make-user-module '()))) + (load* file module))) + +(define (guix-deploy . args) + (define (handle-argument arg result) + (alist-cons 'file arg result)) + (let* ((opts (parse-command-line args %options (list %default-options) + #:argument-handler handle-argument)) + (file (assq-ref opts 'file)) + (machines (load-source-file file))) + (with-store store + (set-build-options-from-command-line store opts) + ;; Build all the OSes and create a mapping from machine to OS derivation + ;; for use in the deploy step. + (let ((osdrvs (map (lambda (machine) + (format #t "building ~a... " (display-name machine)) + (let ((osdrv (build-os machine store))) + (display "done\n") + (cons machine osdrv))) + machines))) + (for-each (lambda (machine) + (format #t "deploying to ~a... " (display-name machine)) + (deploy-os machine store (assq-ref osdrvs machine)) + (display "done\n")) + machines))))) -- 2.22.0 ^ permalink raw reply related [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 2/6] ssh: Add 'identity' keyword to 'open-ssh-session'. 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 ` Jakob L. Kreuze 2019-06-27 18:40 ` [bug#36404] [PATCH 3/6] gnu: Add machine type for deployment specifications Jakob L. Kreuze 0 siblings, 1 reply; 84+ messages in thread From: Jakob L. Kreuze @ 2019-06-27 18:39 UTC (permalink / raw) To: 36404 2019-06-26 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org> * guix/ssh.scm (open-ssh-session): Add 'identity' keyword argument. --- guix/ssh.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/guix/ssh.scm b/guix/ssh.scm index 9b9baf54ea..a2387564a4 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -57,12 +57,13 @@ (define %compression "zlib@openssh.com,zlib") -(define* (open-ssh-session host #:key user port +(define* (open-ssh-session host #:key user port identity (compression %compression)) "Open an SSH session for HOST and return it. When USER and PORT are #f, use default values or whatever '~/.ssh/config' specifies; otherwise use them. Throw an error on failure." (let ((session (make-session #:user user + #:identity identity #:host host #:port port #:timeout 10 ;seconds -- 2.22.0 ^ permalink raw reply related [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 3/6] gnu: Add machine type for deployment specifications. 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 ` Jakob L. Kreuze 2019-06-27 18:40 ` [bug#36404] [PATCH 4/6] Export the (gnu machine) interface Jakob L. Kreuze 0 siblings, 1 reply; 84+ messages in thread From: Jakob L. Kreuze @ 2019-06-27 18:40 UTC (permalink / raw) To: 36404 2019-06-26 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org> * tests/machine.scm: New file. * Makefile.am (SCM_TESTS): Add it. * gnu/machine/ssh.scm: New file. * gnu/local.mk (GNU_SYSTEM_MODULES): Add it. * gnu/machine.scm (machine, sshable-machine): Delete. * gnu/machine.scm: (machine): New record type. * gnu/machine.scm: (display-name, build-os, deploy-os, host-name) (ssh-port, ssh-user): Delete. * gnu/machine.scm: (remote-eval): Rewrite procedure. * gnu/machine.scm: (machine-display-name, build-machine) (deploy-machine): New procedures. All callers changed. --- Makefile.am | 3 +- gnu/local.mk | 4 +- gnu/machine.scm | 140 ++++++++----- gnu/machine/ssh.scm | 355 +++++++++++++++++++++++++++++++ guix/scripts/deploy.scm | 8 +- tests/machine.scm | 450 ++++++++++++++++++++++++++++++++++++++++ 6 files changed, 899 insertions(+), 61 deletions(-) create mode 100644 gnu/machine/ssh.scm create mode 100644 tests/machine.scm diff --git a/Makefile.am b/Makefile.am index ba01264a4b..8dbc220489 100644 --- a/Makefile.am +++ b/Makefile.am @@ -424,7 +424,8 @@ SCM_TESTS = \ tests/import-utils.scm \ tests/store-database.scm \ tests/store-deduplication.scm \ - tests/store-roots.scm + tests/store-roots.scm \ + tests/machine.scm SH_TESTS = \ tests/guix-build.sh \ diff --git a/gnu/local.mk b/gnu/local.mk index f973a8d804..ad87de5ea7 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -563,7 +563,9 @@ GNU_SYSTEM_MODULES = \ %D%/system/shadow.scm \ %D%/system/uuid.scm \ %D%/system/vm.scm \ - %D%/machine.scm \ + \ + %D%/machine.scm \ + %D%/machine/ssh.scm \ \ %D%/build/accounts.scm \ %D%/build/activation.scm \ diff --git a/gnu/machine.scm b/gnu/machine.scm index 4fde7d5c01..900a2020dc 100644 --- a/gnu/machine.scm +++ b/gnu/machine.scm @@ -1,59 +1,89 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 David Thompson <davet@gnu.org> +;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org> +;;; +;;; 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 <http://www.gnu.org/licenses/>. + (define-module (gnu machine) - #:use-module ((gnu packages package-management) #:select (guix)) #:use-module (gnu system) #:use-module (guix derivations) - #:use-module (guix inferior) - #:use-module (guix packages) - #:use-module (guix ssh) + #:use-module (guix monads) + #:use-module (guix records) #:use-module (guix store) - #:use-module (oop goops) - #:use-module (ssh session) - #:export (<machine> - system - display-name - build-os - deploy-os - remote-eval - - <sshable-machine> - host-name - ssh-port - ssh-user)) - -(define-class <machine> () - (system #:getter system #:init-keyword #:system)) - -(define-method (display-name (machine <machine>)) - (operating-system-host-name (system machine))) - -(define-method (build-os (machine <machine>) store) - (let* ((guixdrv (run-with-store store (package->derivation guix))) - (guixdir (and (build-derivations store (list guixdrv)) - (derivation->output-path guixdrv))) - (osdrv (run-with-store store (operating-system-derivation - (system machine))))) - (and (build-derivations store (list osdrv)) - (list (derivation-file-name osdrv) - (derivation->output-path osdrv))))) - -(define-method (deploy-os (machine <machine>) store osdrv) - (error "not implemented")) - -(define-method (remote-eval (machine <machine>) exp) - (error "not implemented")) - -(define-class <sshable-machine> (<machine>) - (host-name #:getter host-name #:init-keyword #:host-name) - (ssh-port #:getter ssh-port #:init-keyword #:ssh-port #:init-form 22) - (ssh-user #:getter ssh-user #:init-keyword #:ssh-user #:init-form "root") - ;; ??? - SSH key config? - ) - -(define-method (deploy-os (machine <sshable-machine>) store osdrvs) - (let ((session (open-ssh-session (host-name machine) - #:user (ssh-user machine) - #:port (ssh-port machine)))) - (with-store store (send-files store osdrvs - (connect-to-remote-daemon session) - #:recursive? #t)) - #t)) + #:export (machine + machine? + this-machine + + machine-system + machine-environment + machine-configuration + machine-display-name + + build-machine + deploy-machine + remote-eval)) + +;;; Commentary: +;;; +;;; This module provides the types used to declare individual machines in a +;;; heterogeneous Guix deployment. The interface allows users of specify system +;;; configurations and the means by which resources should be provisioned on a +;;; per-host basis. +;;; +;;; Code: + +(define-record-type* <machine> machine + make-machine + machine? + this-machine + (system machine-system) ; <operating-system> + (environment machine-environment) ; symbol + (configuration machine-configuration ; configuration object + (default #f))) ; specific to environment + +(define (machine-display-name machine) + "Return the host-name identifying MACHINE." + (operating-system-host-name (machine-system machine))) + +(define (build-machine machine) + "Monadic procedure that builds the system derivation for MACHINE and returning +a list containing the path of the derivation file and the path of the derivation +output." + (let ((os (machine-system machine))) + (mlet* %store-monad ((osdrv (operating-system-derivation os)) + (_ ((store-lift build-derivations) (list osdrv)))) + (return (list (derivation-file-name osdrv) + (derivation->output-path osdrv)))))) + +(define (remote-eval machine exp) + "Evaluate EXP, a gexp, on MACHINE. Ensure that all the elements EXP refers to +are built and deployed to MACHINE beforehand." + (case (machine-environment machine) + ((managed-host) + ((@@ (gnu machine ssh) remote-eval) machine exp)) + (else + (let ((type (machine-environment machine))) + (error "unsupported environment type" type))))) + +(define (deploy-machine machine) + "Monadic procedure transferring the new system's OS closure to the remote +MACHINE, activating it on MACHINE and switching MACHINE to the new generation." + (case (machine-environment machine) + ((managed-host) + ((@@ (gnu machine ssh) deploy-machine) machine)) + (else + (let ((type (machine-environment machine))) + (error "unsupported environment type" type))))) diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm new file mode 100644 index 0000000000..a8f946e19f --- /dev/null +++ b/gnu/machine/ssh.scm @@ -0,0 +1,355 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org> +;;; +;;; 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 <http://www.gnu.org/licenses/>. + +(define-module (gnu machine ssh) + #:use-module (gnu bootloader) + #:use-module (gnu machine) + #:autoload (gnu packages gnupg) (guile-gcrypt) + #:use-module (gnu services) + #:use-module (gnu services shepherd) + #:use-module (gnu system) + #:use-module (guix derivations) + #:use-module (guix gexp) + #:use-module (guix modules) + #:use-module (guix monads) + #:use-module (guix records) + #:use-module (guix ssh) + #:use-module (guix store) + #:use-module (ice-9 match) + #:use-module (srfi srfi-19) + #:export (machine-ssh-configuration + machine-ssh-configuration? + machine-ssh-configuration + + machine-ssh-configuration-host-name + machine-ssh-configuration-port + machine-ssh-configuration-user + machine-ssh-configuration-session)) + +;;; Commentary: +;;; +;;; This module implements remote evaluation and system deployment for +;;; machines that are accessable over SSH and have a known host-name. In the +;;; sense of the broader "machine" interface, we describe the environment for +;;; such machines as 'managed-host. +;;; +;;; Code: + +\f +;;; +;;; SSH client parameter configuration. +;;; + +(define-record-type* <machine-ssh-configuration> machine-ssh-configuration + make-machine-ssh-configuration + machine-ssh-configuration? + this-machine-ssh-configuration + (host-name machine-ssh-configuration-host-name) ; string + (port machine-ssh-configuration-port ; integer + (default 22)) + (user machine-ssh-configuration-user ; string + (default "root")) + (identity machine-ssh-configuration-identity ; path to a private key + (default #f)) + (session machine-ssh-configuration-session ; session + (default #f))) + +(define (machine-ssh-session machine) + "Return the SSH session that was given in MACHINE's configuration, or create +one from the configuration's parameters if one was not provided." + (let ((config (machine-configuration machine))) + (if (machine-ssh-configuration? config) + (or (machine-ssh-configuration-session config) + (let ((host-name (machine-ssh-configuration-host-name config)) + (user (machine-ssh-configuration-user config)) + (port (machine-ssh-configuration-port config)) + (identity (machine-ssh-configuration-identity config))) + (open-ssh-session host-name + #:user user + #:port port + #:identity identity))) + (error "unsupported configuration type")))) + +\f +;;; +;;; Remote evaluation. +;;; + +(define (remote-eval machine exp) + "Internal implementation of 'remote-eval' for MACHINE instances with an +environment type of 'managed-host." + (unless (machine-configuration machine) + (error (format #f (G_ "no configuration specified for machine of environment '~a'") + (symbol->string (machine-environment machine))))) + ((@ (guix remote) remote-eval) exp (machine-ssh-session machine))) + +\f +;;; +;;; 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 #$(derivation->output-path drv)) + (number (1+ (generation-number %system-profile))) + (generation (generation-file-name %system-profile number)) + (old-env (environ)) + (old-path %load-path) + (old-cpath %load-compiled-path)) + (switch-symlinks generation system) + (switch-symlinks %system-profile generation) + ;; Guard against the activation script modifying $PATH. + (dynamic-wind + (const #t) + (lambda () + (setenv "GUIX_NEW_SYSTEM" system) + ;; Guard against the activation script modifying '%load-path'. + (dynamic-wind + (const #t) + (lambda () + ;; 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)))) + (lambda () + (set! %load-path old-path) + (set! %load-compiled-path old-cpath)))) + (lambda () + (environ old-env)))))))) + + (let* ((os (machine-system machine)) + (script (operating-system-activation-script os))) + (mlet* %store-monad ((drv (operating-system-derivation os))) + (remote-eval machine (remote-exp drv script))))) + +(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)) + (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." + (define bootable-kernel-arguments + (@@ (gnu system) bootable-kernel-arguments)) + + (define remote-exp + (with-extensions (list guile-gcrypt) + (with-imported-modules (source-module-closure '((guix config) + (guix profiles))) + #~(begin + (use-modules (guix config) + (guix profiles) + (ice-9 textual-ports)) + + (define %system-profile + (string-append %state-directory "/profiles/system")) + + (define (read-file path) + (call-with-input-file path + (lambda (port) + (get-string-all port)))) + + (map (lambda (generation) + (let* ((system-path (generation-file-name %system-profile + generation)) + (boot-parameters-path (string-append system-path + "/parameters")) + (time (stat:mtime (lstat system-path)))) + (list generation + system-path + time + (read-file boot-parameters-path)))) + (reverse (generation-numbers %system-profile))))))) + + (mlet* %store-monad ((generations (remote-eval machine remote-exp))) + (return + (map (lambda (generation) + (match generation + ((generation system-path time serialized-params) + (let* ((params (call-with-input-string serialized-params + read-boot-parameters)) + (root (boot-parameters-root-device params)) + (label (boot-parameters-label params))) + (boot-parameters + (inherit params) + (label + (string-append label " (#" + (number->string generation) ", " + (let ((time (make-time time-utc 0 time))) + (date->string (time-utc->date time) + "~Y-~m-~d ~H:~M")) + ")")) + (kernel-arguments + (append (bootable-kernel-arguments system-path root) + (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")) + (old-path %load-path) + (old-cpath %load-compiled-path)) + (switch-symlinks temp-gc-root gc-root) + + (unless (false-if-exception + (begin + (install-boot-config #$bootcfg #$bootcfg-file "/") + ;; Guard against the activation script modifying + ;; '%load-path'. + (dynamic-wind + (const #t) + (lambda () + ;; 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)))) + (lambda () + (set! %load-path old-path) + (set! %load-compiled-path old-cpath))))) + (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))) + (remote-eval machine (remote-exp installer bootcfg bootcfg-file))))) + +(define (deploy-machine machine) + "Internal implementation of 'deploy-machine' for MACHINE instances with an +environment type of 'managed-host." + (unless (machine-configuration machine) + (error (format #f (G_ "no configuration specified for machine of environment '~a'") + (symbol->string (machine-environment machine))))) + (mbegin %store-monad + (switch-to-system machine) + (upgrade-shepherd-services machine) + (install-bootloader machine))) diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm index bcb3a2ea4c..0be279642b 100644 --- a/guix/scripts/deploy.scm +++ b/guix/scripts/deploy.scm @@ -64,13 +64,13 @@ ;; Build all the OSes and create a mapping from machine to OS derivation ;; for use in the deploy step. (let ((osdrvs (map (lambda (machine) - (format #t "building ~a... " (display-name machine)) - (let ((osdrv (build-os machine store))) + (format #t "building ~a... " (machine-display-name machine)) + (let ((osdrv (run-with-store store (build-machine machine)))) (display "done\n") (cons machine osdrv))) machines))) (for-each (lambda (machine) - (format #t "deploying to ~a... " (display-name machine)) - (deploy-os machine store (assq-ref osdrvs machine)) + (format #t "deploying to ~a... " (machine-display-name machine)) + (run-with-store store (deploy-machine machine)) (display "done\n")) machines))))) diff --git a/tests/machine.scm b/tests/machine.scm new file mode 100644 index 0000000000..390c0189bb --- /dev/null +++ b/tests/machine.scm @@ -0,0 +1,450 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org> +;;; +;;; 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 <http://www.gnu.org/licenses/>. + +(define-module (gnu tests machine) + #:use-module (gnu bootloader grub) + #:use-module (gnu bootloader) + #:use-module (gnu build marionette) + #:use-module (gnu build vm) + #:use-module (gnu machine) + #:use-module (gnu machine ssh) + #:use-module (gnu packages bash) + #:use-module (gnu packages virtualization) + #:use-module (gnu services base) + #:use-module (gnu services networking) + #:use-module (gnu services ssh) + #:use-module (gnu services) + #:use-module (gnu system file-systems) + #: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 pki) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (ice-9 ftw) + #:use-module (ice-9 match) + #:use-module (ice-9 textual-ports) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-64) + #:use-module (ssh auth) + #:use-module (ssh channel) + #:use-module (ssh key) + #:use-module (ssh session)) + +\f +;;; +;;; Virtual machine scaffolding. +;;; + +(define marionette-pid (@@ (gnu build marionette) marionette-pid)) + +(define (call-with-marionette path command proc) + "Invoke PROC with a marionette running COMMAND in PATH." + (let* ((marionette (make-marionette command #:socket-directory path)) + (pid (marionette-pid marionette))) + (dynamic-wind + (lambda () + (unless marionette + (error "could not start marionette"))) + (lambda () (proc marionette)) + (lambda () + (kill pid SIGTERM))))) + +(define (dir-join . components) + "Join COMPONENTS with `file-name-separator-string'." + (string-join components file-name-separator-string)) + +(define (call-with-machine-test-directory proc) + "Run PROC with the path to a temporary directory that will be cleaned up +when PROC returns. Only files that can be passed to 'delete-file' should be +created within the temporary directory; cleanup will not recurse into +subdirectories." + (let ((path (tmpnam))) + (dynamic-wind + (lambda () + (unless (mkdir path) + (error (format #f "could not create directory '~a'" path)))) + (lambda () (proc path)) + (lambda () + (let ((children (map first (cddr (file-system-tree path))))) + (for-each (lambda (child) + (false-if-exception + (delete-file (dir-join path child)))) + children) + (rmdir path)))))) + +(define (os-for-test os) + "Return an <operating-system> record derived from OS that is appropriate for +use with 'qemu-image'." + (define file-systems-to-keep + ;; Keep only file systems other than root and not normally bound to real + ;; devices. + (remove (lambda (fs) + (let ((target (file-system-mount-point fs)) + (source (file-system-device fs))) + (or (string=? target "/") + (string-prefix? "/dev/" source)))) + (operating-system-file-systems os))) + + (define root-uuid + ;; UUID of the root file system. + ((@@ (gnu system vm) operating-system-uuid) os 'dce)) + + + (operating-system + (inherit os) + ;; Assume we have an initrd with the whole QEMU shebang. + + ;; Force our own root file system. Refer to it by UUID so that + ;; it works regardless of how the image is used ("qemu -hda", + ;; Xen, etc.). + (file-systems (cons (file-system + (mount-point "/") + (device root-uuid) + (type "ext4")) + file-systems-to-keep)))) + +(define (qemu-image-for-test os) + "Return a derivation producing a QEMU disk image running OS. This procedure +is similar to 'system-qemu-image' in (gnu system vm), but makes use of +'os-for-test' so that callers may obtain the same system derivation that will +be booted by the image." + (define root-uuid ((@@ (gnu system vm) operating-system-uuid) os 'dce)) + (let* ((os (os-for-test os)) + (bootcfg (operating-system-bootcfg os))) + (qemu-image #:os os + #:bootcfg-drv bootcfg + #:bootloader (bootloader-configuration-bootloader + (operating-system-bootloader os)) + #:disk-image-size (* 9000 (expt 2 20)) + #:file-system-type "ext4" + #:file-system-uuid root-uuid + #:inputs `(("system" ,os) + ("bootcfg" ,bootcfg)) + #:copy-inputs? #t))) + +(define (make-writable-image image) + "Return a derivation producing a script to create a writable disk image +overlay of IMAGE, writing the overlay to the the path given as a command-line +argument to the script." + (define qemu-img-exec + #~(list (string-append #$qemu-minimal "/bin/qemu-img") + "create" "-f" "qcow2" + "-o" (string-append "backing_file=" #$image))) + + (define builder + #~(call-with-output-file #$output + (lambda (port) + (format port "#!~a~% exec ~a \"$@\"~%" + #$(file-append bash "/bin/sh") + (string-join #$qemu-img-exec " ")) + (chmod port #o555)))) + + (gexp->derivation "make-writable-image.sh" builder)) + +(define (run-os-for-test os) + "Return a derivation producing a script to run OS as a qemu guest, whose +first argument is the path to a writable disk image. Additional arguments are +passed as-is to qemu." + (define kernel-arguments + #~(list "console=ttyS0" + #+@(operating-system-kernel-arguments os "/dev/sda1"))) + + (define qemu-exec + #~(begin + (list (string-append #$qemu-minimal "/bin/" #$(qemu-command (%current-system))) + "-kernel" #$(operating-system-kernel-file os) + "-initrd" #$(file-append os "/initrd") + (format #f "-append ~s" + (string-join #$kernel-arguments " ")) + #$@(if (file-exists? "/dev/kvm") + '("-enable-kvm") + '()) + "-no-reboot" + "-net nic,model=virtio" + "-object" "rng-random,filename=/dev/urandom,id=guixsd-vm-rng" + "-device" "virtio-rng-pci,rng=guixsd-vm-rng" + "-vga" "std" + "-m" "256" + "-net" "user,hostfwd=tcp::2222-:22"))) + + (define builder + #~(call-with-output-file #$output + (lambda (port) + (format port "#!~a~% exec ~a -drive \"file=$@\"~%" + #$(file-append bash "/bin/sh") + (string-join #$qemu-exec " ")) + (chmod port #o555)))) + + (gexp->derivation "run-vm.sh" builder)) + +(define (scripts-for-test os) + "Build and return a list containing the paths of: + +- A script to make a writable disk image overlay of OS. +- A script to run that disk image overlay as a qemu guest." + (let ((virtualized-os (os-for-test os))) + (mlet* %store-monad ((osdrv (operating-system-derivation virtualized-os)) + (imgdrv (qemu-image-for-test os)) + + ;; Ungexping 'imgdrv' or 'osdrv' will result in an + ;; error if the derivations don't exist in the store, + ;; so we ensure they're built prior to invoking + ;; 'run-vm' or 'make-image'. + (_ ((store-lift build-derivations) (list imgdrv))) + + (run-vm (run-os-for-test virtualized-os)) + (make-image + (make-writable-image (derivation->output-path imgdrv)))) + (mbegin %store-monad + ((store-lift build-derivations) (list imgdrv make-image run-vm)) + (return (list (derivation->output-path make-image) + (derivation->output-path run-vm))))))) + +(define (call-with-marionette-and-session os proc) + "Construct a marionette backed by OS in a temporary test environment and +invoke PROC with two arguments: the marionette object, and an SSH session +connected to the marionette." + (call-with-machine-test-directory + (lambda (path) + (match (with-store store + (run-with-store store + (scripts-for-test %system))) + ((make-image run-vm) + (let ((image (dir-join path "image"))) + ;; Create the writable image overlay. + (system (string-join (list make-image image) " ")) + (call-with-marionette + path + (list run-vm image) + (lambda (marionette) + ;; XXX: The guest clearly has (gcrypt pk-crypto) since this + ;; works, but trying to import it from 'marionette-eval' fails as + ;; the Marionette REPL does not have 'guile-gcrypt' in its + ;; %load-path. + (marionette-eval + `(begin + (use-modules (ice-9 popen)) + (let ((port (open-pipe* OPEN_WRITE "guix" "archive" "--authorize"))) + (put-string port ,%signing-key) + (close port))) + marionette) + ;; XXX: This is an absolute hack to work around potential quirks + ;; in the operating system. For one, we invoke 'herd' from the + ;; command-line to ensure that the Shepherd socket file + ;; exists. Second, we enable 'ssh-daemon', as there's a chance + ;; the service will be disabled upon booting the image. + (marionette-eval + `(system "herd enable ssh-daemon") + marionette) + (marionette-eval + '(begin + (use-modules (gnu services herd)) + (start-service 'ssh-daemon)) + marionette) + (call-with-connected-session/auth + (lambda (session) + (proc marionette session))))))))))) + +\f +;;; +;;; SSH session management. These are borrowed from (gnu tests ssh). +;;; + +(define (make-session-for-test) + "Make a session with predefined parameters for a test." + (make-session #:user "root" + #:port 2222 + #:host "localhost")) + +(define (call-with-connected-session proc) + "Call the one-argument procedure PROC with a freshly created and +connected SSH session object, return the result of the procedure call. The +session is disconnected when the PROC is finished." + (let ((session (make-session-for-test))) + (dynamic-wind + (lambda () + (let ((result (connect! session))) + (unless (equal? result 'ok) + (error "Could not connect to a server" + session result)))) + (lambda () (proc session)) + (lambda () (disconnect! session))))) + +(define (call-with-connected-session/auth proc) + "Make an authenticated session. We should be able to connect as +root with an empty password." + (call-with-connected-session + (lambda (session) + ;; Try the simple authentication methods. Dropbear requires + ;; 'none' when there are no passwords, whereas OpenSSH accepts + ;; 'password' with an empty password. + (let loop ((methods (list (cut userauth-password! <> "") + (cut userauth-none! <>)))) + (match methods + (() + (error "all the authentication methods failed")) + ((auth rest ...) + (match (pk 'auth (auth session)) + ('success + (proc session)) + ('denied + (loop rest))))))))) + +\f +;;; +;;; Virtual machines for use in the test suite. +;;; + +(define %system + ;; A "bare bones" operating system running both an OpenSSH daemon and the + ;; "marionette" service. + (marionette-operating-system + (operating-system + (host-name "gnu") + (timezone "Etc/UTC") + (bootloader (bootloader-configuration + (bootloader grub-bootloader) + (target "/dev/sda") + (terminal-outputs '(console)))) + (file-systems (cons (file-system + (mount-point "/") + (device "/dev/vda1") + (type "ext4")) + %base-file-systems)) + (services + (append (list (service dhcp-client-service-type) + (service openssh-service-type + (openssh-configuration + (permit-root-login #t) + (allow-empty-passwords? #t)))) + %base-services))) + #:imported-modules '((gnu services herd) + (guix combinators)))) + +(define %signing-key + ;; The host's signing key, encoded as a string. The "marionette" will reject + ;; any files signed by an unauthorized host, so we'll need to send this key + ;; over and authorize it. + (call-with-input-file %public-key-file + (lambda (port) + (get-string-all port)))) + +\f +(test-begin "machine") + +(define (system-generations 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)) + +(define (running-services marionette) + (marionette-eval + '(begin + (use-modules (gnu services herd) + (srfi srfi-1)) + (map (compose first live-service-provision) + (filter live-service-running (current-services)))) + marionette)) + +(define (count-grub-cfg-entries marionette) + (marionette-eval + '(begin + (define grub-cfg + (call-with-input-file "/boot/grub/grub.cfg" + (lambda (port) + (get-string-all port)))) + + (let loop ((n 0) + (start 0)) + (let ((index (string-contains grub-cfg "menuentry" start))) + (if index + (loop (1+ n) (1+ index)) + n)))) + marionette)) + +(define %target-system + (marionette-operating-system + (operating-system + (host-name "gnu-deployed") + (timezone "Etc/UTC") + (bootloader (bootloader-configuration + (bootloader grub-bootloader) + (target "/dev/sda") + (terminal-outputs '(console)))) + (file-systems (cons (file-system + (mount-point "/") + (device "/dev/vda1") + (type "ext4")) + %base-file-systems)) + (services + (append (list (service tor-service-type) + (service dhcp-client-service-type) + (service openssh-service-type + (openssh-configuration + (permit-root-login #t) + (allow-empty-passwords? #t)))) + %base-services))) + #:imported-modules '((gnu services herd) + (guix combinators)))) + +(call-with-marionette-and-session + (os-for-test %system) + (lambda (marionette session) + (let ((generations-prior (system-generations marionette)) + (services-prior (running-services marionette)) + (grub-entry-count-prior (count-grub-cfg-entries marionette)) + (machine (machine + (system %target-system) + (environment 'managed-host) + (configuration (machine-ssh-configuration + (host-name "localhost") + (session session)))))) + (with-store store + (run-with-store store + (build-machine machine)) + (run-with-store store + (deploy-machine machine))) + (test-equal "deployment created new generation" + (length (system-generations marionette)) + (1+ (length generations-prior))) + (test-assert "deployment started new service" + (and (not (memq 'tor services-prior)) + (memq 'tor (running-services marionette)))) + (test-equal "deployment created new menu entry" + (count-grub-cfg-entries marionette) + ;; A Grub configuration that contains a single menu entry does not have + ;; an "old configurations" submenu. Deployment, then, would result in + ;; this submenu being created, meaning an additional two 'menuentry' + ;; fields rather than just one. + (if (= grub-entry-count-prior 1) + (+ 2 grub-entry-count-prior) + (1+ grub-entry-count-prior)))))) + +(test-end "machine") -- 2.22.0 ^ permalink raw reply related [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 4/6] Export the (gnu machine) interface. 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 ` Jakob L. Kreuze 2019-06-27 18:41 ` [bug#36404] [PATCH 5/6] Add 'guix deploy' Jakob L. Kreuze ` (2 more replies) 0 siblings, 3 replies; 84+ messages in thread From: Jakob L. Kreuze @ 2019-06-27 18:40 UTC (permalink / raw) To: 36404 This is so machine declarations can have a simple (use-modules (gnu)) rather than having to import the machine module explicitly. 2019-06-26 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org> * gnu.scm (%public-modules): Add '(gnu machine)'. * gnu.scm (use-machine-modules): New macro. --- gnu.scm | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/gnu.scm b/gnu.scm index 2c29b6dc3f..fa643a5b92 100644 --- a/gnu.scm +++ b/gnu.scm @@ -27,7 +27,8 @@ #:use-module (guix packages) #:use-module (gnu packages) #:use-module (gnu services) - #:export (use-package-modules + #:export (use-machine-modules + use-package-modules use-service-modules use-system-modules)) @@ -45,6 +46,7 @@ (gnu system file-systems) (gnu bootloader) (gnu bootloader grub) + (gnu machine) (gnu system keyboard) (gnu system pam) (gnu system shadow) ; 'user-account' @@ -142,6 +144,10 @@ Try adding @code{(use-service-modules ~a)}.") (current-source-location)) hint))) +(define-syntax-rule (use-machine-modules module ...) + (try-use-modules package-module-hint + (gnu machine module) ...)) + (define-syntax-rule (use-package-modules module ...) (try-use-modules package-module-hint (gnu packages module) ...)) -- 2.22.0 ^ permalink raw reply related [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 5/6] Add 'guix deploy'. 2019-06-27 18:40 ` [bug#36404] [PATCH 4/6] Export the (gnu machine) interface Jakob L. Kreuze @ 2019-06-27 18:41 ` Jakob L. Kreuze 2019-06-27 18:42 ` [bug#36404] [PATCH 6/6] doc: Add section for " 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 2 siblings, 2 replies; 84+ messages in thread From: Jakob L. Kreuze @ 2019-06-27 18:41 UTC (permalink / raw) To: 36404 2019-06-26 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org> * guix/scripts/deploy.scm: Add on-line help and limit verbosity. --- guix/scripts/deploy.scm | 52 ++++++++++++++++++++++++++--------------- 1 file changed, 33 insertions(+), 19 deletions(-) diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm index 0be279642b..c52434f518 100644 --- a/guix/scripts/deploy.scm +++ b/guix/scripts/deploy.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2019 David Thompson <davet@gnu.org> +;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,17 +19,35 @@ (define-module (guix scripts deploy) #:use-module (gnu machine) - #:use-module (guix ui) #:use-module (guix scripts) #:use-module (guix scripts build) #:use-module (guix store) + #:use-module (guix ui) #:use-module (ice-9 format) #:use-module (srfi srfi-1) #:use-module (srfi srfi-37) #:export (guix-deploy)) +;;; Commentary: +;;; +;;; This program provides a command-line interface to (gnu machine), allowing +;;; users to perform remote deployments through specification files. +;;; +;;; Code: + +\f + (define (show-help) - (display (G_ "Usage: guix deploy WHATEVER\n"))) + (display (G_ "Usage: guix deploy [OPTION] FILE... +Perform the deployment specified by FILE.\n")) + (show-build-options-help) + (newline) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) (define %options (cons* (option '(#\h "help") #f #f @@ -42,13 +61,11 @@ (substitutes? . #t) (build-hook? . #t) (graft? . #t) - (print-build-trace? . #t) - (print-extended-build-trace? . #t) - (multiplexed-build-output? . #t) (debug . 0) (verbosity . 2))) (define (load-source-file file) + "Load FILE as a user module." (let ((module (make-user-module '()))) (load* file module))) @@ -58,19 +75,16 @@ (let* ((opts (parse-command-line args %options (list %default-options) #:argument-handler handle-argument)) (file (assq-ref opts 'file)) - (machines (load-source-file file))) + (machines (or (and file (load-source-file file)) '()))) (with-store store (set-build-options-from-command-line store opts) - ;; Build all the OSes and create a mapping from machine to OS derivation - ;; for use in the deploy step. - (let ((osdrvs (map (lambda (machine) - (format #t "building ~a... " (machine-display-name machine)) - (let ((osdrv (run-with-store store (build-machine machine)))) - (display "done\n") - (cons machine osdrv))) - machines))) - (for-each (lambda (machine) - (format #t "deploying to ~a... " (machine-display-name machine)) - (run-with-store store (deploy-machine machine)) - (display "done\n")) - machines))))) + (for-each (lambda (machine) + (format #t "building ~a... " (machine-display-name machine)) + (run-with-store store (build-machine machine)) + (display "done\n")) + machines) + (for-each (lambda (machine) + (format #t "deploying to ~a... " (machine-display-name machine)) + (run-with-store store (deploy-machine machine)) + (display "done\n")) + machines)))) -- 2.22.0 ^ permalink raw reply related [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 6/6] doc: Add section for 'guix deploy'. 2019-06-27 18:41 ` [bug#36404] [PATCH 5/6] Add 'guix deploy' Jakob L. Kreuze @ 2019-06-27 18:42 ` Jakob L. Kreuze 2019-06-29 21:43 ` Christopher Lemmer Webber 2019-06-29 21:38 ` [bug#36404] [PATCH 5/6] Add " Christopher Lemmer Webber 1 sibling, 1 reply; 84+ messages in thread From: Jakob L. Kreuze @ 2019-06-27 18:42 UTC (permalink / raw) To: 36404 2019-06-26 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org> doc/guix.texi: Add section "Invoking guix deploy". --- doc/guix.texi | 103 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 103 insertions(+) diff --git a/doc/guix.texi b/doc/guix.texi index f0d148ace0..948767d8c8 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -81,6 +81,7 @@ Documentation License''. * guix gc: (guix)Invoking guix gc. Reclaiming unused disk space. * guix pull: (guix)Invoking guix pull. Update the list of available packages. * guix system: (guix)Invoking guix system. Manage the operating system configuration. +* guix deploy: (guix)Invoking guix deploy. Manage operating system configurations for remote hosts. @end direntry @dircategory Software development @@ -269,6 +270,7 @@ System Configuration * Initial RAM Disk:: Linux-Libre bootstrapping. * Bootloader Configuration:: Configuring the boot loader. * Invoking guix system:: Instantiating a system configuration. +* Invoking guix deploy:: Deploying a system configuration to a remote host. * Running Guix in a VM:: How to run Guix System in a virtual machine. * Defining Services:: Adding new service definitions. @@ -10303,6 +10305,7 @@ instance to support new system services. * Initial RAM Disk:: Linux-Libre bootstrapping. * Bootloader Configuration:: Configuring the boot loader. * Invoking guix system:: Instantiating a system configuration. +* Invoking guix deploy:: Deploying a system configuration to a remote host. * Running Guix in a VM:: How to run Guix System in a virtual machine. * Defining Services:: Adding new service definitions. @end menu @@ -25399,6 +25402,106 @@ example graph. @end table +@node Invoking guix deploy +@section Invoking @code{guix deploy} + +In addition to managing a machine's configuration locally through operating +system declarations, Guix also provides the ability to managing multiple remote +hosts as a logical ``deployment''. This is done using @command{guix deploy}. + +@example +guix deploy @var{file} +@end example + +Such an invocation will deploy the machines that the code within @var{file} +evaluates to. As an example, @var{file} might contain a definition like this: + +@example +;; This is a Guix deployment of a "bare bones" setup, with +;; no X11 display server, to a machine with an SSH daemon +;; listening on localhost:2222. A configuration such as this +;; may be appropriate for virtual machine with ports +;; forwarded to the host's loopback interface. + +(use-modules (gnu) (guix)) +(use-machine-modules ssh) +(use-service-modules networking ssh) +(use-package-modules bootloaders) + +(define %system + (operating-system + (host-name "gnu-deployed") + (timezone "Etc/UTC") + (bootloader (bootloader-configuration + (bootloader grub-bootloader) + (target "/dev/vda") + (terminal-outputs '(console)))) + (file-systems (cons (file-system + (mount-point "/") + (device "/dev/vda1") + (type "ext4")) + %base-file-systems)) + (services + (append (list (service dhcp-client-service-type) + (service openssh-service-type + (openssh-configuration + (permit-root-login #t) + (allow-empty-passwords? #t)))) + %base-services)))) + +(list (machine + (system %system) + (environment 'managed-host) + (configuration (machine-ssh-configuration + (host-name "localhost") + (identity "./id_rsa") + (port 2222))))) +@end example + +The file should evaluate to a list of machines, rather than just one. This +example, upon being deployed, will create a new generation on the remote system +realizing the operating-system configuration @var{%system}. @var{environment} +and @var{configuration} specify how the machine should be provisioned--that is, +deployment and management of computing resources. The above example does not +provision any resources -- a @code{'managed-host} is a machine that is already +up and running the Guix system. A more complex deployment may involve +i.e. starting virtual machines through a VPS provider, however, in which case a +different @var{environment} types would be used. + +@deftp {Data Type} machine +This is the data type representing a single machine in a heterogeneous Guix +deployment. + +@table @asis +@item @code{system} +The object of the operating system configuration to deploy. + +@item @code{environment} +A symbol describing how the machine should be provisioned. At the moment, only +the only supported value is @code{'managed-host}. + +@item @code{configuration} (default: @code{#f}) +An object describing the configuration for the machine's @code{environment}. If +the @code{environment} has a default configuration, @code{#f} can be used. If +@code{#f} is used for an environment with no default configuration, however, an +error will be thrown. +@end table +@end deftp + +@deftp {Data Type} machine-ssh-configuration +This is the data type representing the SSH client parameters for connecting to a +@code{'managed-host}. + +@table @asis +@item @code{host-name} +@item @code{port} (default: @code{22}) +@item @code{user} (default: @code{"root"}) +@item @code{identity} (default: @code{#f}) +If specified, the path to the SSH private key to use to authenticate with the +remote host. +@end table +@end deftp + @node Running Guix in a VM @section Running Guix in a Virtual Machine -- 2.22.0 ^ permalink raw reply related [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 6/6] doc: Add section for 'guix deploy'. 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 0 siblings, 1 reply; 84+ messages in thread From: Christopher Lemmer Webber @ 2019-06-29 21:43 UTC (permalink / raw) To: 36404 Jakob L. Kreuze writes: > +The file should evaluate to a list of machines, rather than just one. This phrasing confused me for a second, because it could be just one machine in that list. How about: The file should evaluate to a list of @var{machine} objects. or: The file should evaluate to a list of @var{<machine>} objects. Not sure whether the angle brackets help or hurt. Looks great otherwise. I left a few other comments in response to the other patches; please review and make changes, but I think there isn't too much to do to get this in. IMO we should get this in as quickly as possible; I'd love to do so ideally in the next week so it doesn't stagnate and so people can start trying to use it. Really thrilling stuff Jakob; great work! It's exciting to have you as part of the Guix team. ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 6/6] doc: Add section for 'guix deploy'. 2019-06-29 21:43 ` Christopher Lemmer Webber @ 2019-06-30 0:35 ` Jakob L. Kreuze 0 siblings, 0 replies; 84+ messages in thread From: Jakob L. Kreuze @ 2019-06-30 0:35 UTC (permalink / raw) To: Christopher Lemmer Webber; +Cc: 36404 [-- Attachment #1: Type: text/plain, Size: 1099 bytes --] Christopher Lemmer Webber <cwebber@dustycloud.org> writes: > This phrasing confused me for a second, because it could be just one > machine in that list. > > How about: > > The file should evaluate to a list of @var{machine} objects. > or: > The file should evaluate to a list of @var{<machine>} objects. > > Not sure whether the angle brackets help or hurt. I couldn't find anywhere else in the manual where the brackets are used for type names (at least with @var), so I went with the former. > Looks great otherwise. I left a few other comments in response to the > other patches; please review and make changes, but I think there isn't > too much to do to get this in. IMO we should get this in as quickly as > possible; I'd love to do so ideally in the next week so it doesn't > stagnate and so people can start trying to use it. Awesome, I'll get on putting together the revised patch series. > Really thrilling stuff Jakob; great work! It's exciting to have you as > part of the Guix team. Aw, shucks. That made my day. It's exciting to be a part of the Guix team! Regards, Jakob [-- Attachment #2: signature.asc --] [-- Type: application/pgp-signature, Size: 832 bytes --] ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 5/6] Add 'guix deploy'. 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:38 ` Christopher Lemmer Webber 1 sibling, 0 replies; 84+ messages in thread From: Christopher Lemmer Webber @ 2019-06-29 21:38 UTC (permalink / raw) To: 36404 Jakob L. Kreuze writes: > 2019-06-26 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org> > > * guix/scripts/deploy.scm: Add on-line help and limit verbosity. Looks good. No comments on this one. ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 4/6] Export the (gnu machine) interface. 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-29 21:36 ` Christopher Lemmer Webber 2019-06-29 22:04 ` Ricardo Wurmus 2 siblings, 0 replies; 84+ messages in thread From: Christopher Lemmer Webber @ 2019-06-29 21:36 UTC (permalink / raw) To: 36404 Jakob L. Kreuze writes: > This is so machine declarations can have a simple (use-modules (gnu)) > rather than having to import the machine module explicitly. +1 ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 4/6] Export the (gnu machine) interface. 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-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 2 siblings, 1 reply; 84+ messages in thread From: Ricardo Wurmus @ 2019-06-29 22:04 UTC (permalink / raw) To: zerodaysfordays; +Cc: 36404 Hi Jakob, > This is so machine declarations can have a simple (use-modules (gnu)) > rather than having to import the machine module explicitly. Do we need this at all or could “guix deploy” evaluate the machine declaration in an environment where the machine module is available? We do something like that for evaluating manifests – no module relating to manifest loading needs to be specified by users and yet “specifications->manifest” is available. Would it make sense to do something similar here instead of exporting (gnu machine) in (gnu)? -- Ricardo ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 4/6] Export the (gnu machine) interface. 2019-06-29 22:04 ` Ricardo Wurmus @ 2019-06-30 0:41 ` Jakob L. Kreuze 0 siblings, 0 replies; 84+ messages in thread From: Jakob L. Kreuze @ 2019-06-30 0:41 UTC (permalink / raw) To: Ricardo Wurmus; +Cc: 36404 [-- Attachment #1: Type: text/plain, Size: 783 bytes --] Hi Ricardo, Ricardo Wurmus <rekado@elephly.net> writes: > Do we need this at all or could “guix deploy” evaluate the machine > declaration in an environment where the machine module is available? > We do something like that for evaluating manifests – no module > relating to manifest loading needs to be specified by users and yet > “specifications->manifest” is available. > > Would it make sense to do something similar here instead of exporting > (gnu machine) in (gnu)? Thanks for that comment; I'd completely forgotten about not having to import 'specifications->manifest'. I doubt the machine types will see much use outside of deployment specifications, so something like that would definitely make sense here. I'll add it in. Regards, Jakob [-- Attachment #2: signature.asc --] [-- Type: application/pgp-signature, Size: 832 bytes --] ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 0/6] Add 'guix deploy'. 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 20:05 ` Thompson, David 2019-06-28 13:34 ` [bug#36404] [PATCH 0/5] " Jakob L. Kreuze 2019-06-29 14:37 ` [bug#36404] [PATCH 0/6] Add 'guix deploy' Christopher Lemmer Webber ` (2 subsequent siblings) 4 siblings, 1 reply; 84+ messages in thread From: Thompson, David @ 2019-06-27 20:05 UTC (permalink / raw) To: Jakob L. Kreuze; +Cc: 36404 Hi Jakob, On Thu, Jun 27, 2019 at 2:38 PM Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org> wrote: > > Hello, Guix! > > This patch provides the basis for 'guix deploy', implementing what I've > referred to as the "simple case" in my progress reports: in-place > updates to machines (physical or virtual) whose name and IP address we > know well. First of all: Wooooooooooooooo!!!!!!!!!!!!!! This is a huge first step! Second of all: Could you please squash these 5 commits into one commit? No one needs to review my WIP code that uses GOOPS that later gets dropped in one of your commits. :) Thanks! - Dave ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 0/5] Add 'guix deploy'. 2019-06-27 20:05 ` [bug#36404] [PATCH 0/6] Add 'guix deploy' Thompson, David @ 2019-06-28 13:34 ` Jakob L. Kreuze 2019-06-28 13:35 ` [bug#36404] [PATCH 1/5] ssh: Add 'identity' keyword to 'open-ssh-session' Jakob L. Kreuze 0 siblings, 1 reply; 84+ messages in thread From: Jakob L. Kreuze @ 2019-06-28 13:34 UTC (permalink / raw) To: Thompson, David; +Cc: 36404 [-- Attachment #1: Type: text/plain, Size: 1089 bytes --] Hey Dave, Thanks for the initial feedback. I squashed that first commit of yours and used the opportunity to move the addition of 'deploy.scm' into the "Add 'guix deploy' commit". Here's the cleaned up patch set. Jakob L. Kreuze (5): ssh: Add 'identity' keyword to 'open-ssh-session'. gnu: Add machine type for deployment specifications. Add 'guix deploy'. Export the (gnu machine) interface. doc: Add section for 'guix deploy'. Makefile.am | 4 +- doc/guix.texi | 103 +++++++++ gnu.scm | 8 +- gnu/local.mk | 5 +- gnu/machine.scm | 89 ++++++++ gnu/machine/ssh.scm | 355 +++++++++++++++++++++++++++++++ guix/scripts/deploy.scm | 90 ++++++++ guix/ssh.scm | 3 +- tests/machine.scm | 450 ++++++++++++++++++++++++++++++++++++++++ 9 files changed, 1103 insertions(+), 4 deletions(-) create mode 100644 gnu/machine.scm create mode 100644 gnu/machine/ssh.scm create mode 100644 guix/scripts/deploy.scm create mode 100644 tests/machine.scm -- 2.22.0 [-- Attachment #2: signature.asc --] [-- Type: application/pgp-signature, Size: 832 bytes --] ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 1/5] ssh: Add 'identity' keyword to 'open-ssh-session'. 2019-06-28 13:34 ` [bug#36404] [PATCH 0/5] " Jakob L. Kreuze @ 2019-06-28 13:35 ` 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-29 14:42 ` [bug#36404] [PATCH 1/5] ssh: Add 'identity' keyword to 'open-ssh-session' Christopher Lemmer Webber 0 siblings, 2 replies; 84+ messages in thread From: Jakob L. Kreuze @ 2019-06-28 13:35 UTC (permalink / raw) To: Thompson, David; +Cc: 36404 [-- Attachment #1: Type: text/plain, Size: 960 bytes --] * guix/ssh.scm (open-ssh-session): Add 'identity' keyword argument. --- guix/ssh.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/guix/ssh.scm b/guix/ssh.scm index 9b9baf54ea..a2387564a4 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -57,12 +57,13 @@ (define %compression "zlib@openssh.com,zlib") -(define* (open-ssh-session host #:key user port +(define* (open-ssh-session host #:key user port identity (compression %compression)) "Open an SSH session for HOST and return it. When USER and PORT are #f, use default values or whatever '~/.ssh/config' specifies; otherwise use them. Throw an error on failure." (let ((session (make-session #:user user + #:identity identity #:host host #:port port #:timeout 10 ;seconds -- 2.22.0 [-- Attachment #2: signature.asc --] [-- Type: application/pgp-signature, Size: 832 bytes --] ^ permalink raw reply related [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 2/5] gnu: Add machine type for deployment specifications. 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 ` Jakob L. Kreuze 2019-06-28 13:36 ` [bug#36404] [PATCH 3/5] Add '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-29 14:42 ` [bug#36404] [PATCH 1/5] ssh: Add 'identity' keyword to 'open-ssh-session' Christopher Lemmer Webber 1 sibling, 2 replies; 84+ messages in thread From: Jakob L. Kreuze @ 2019-06-28 13:35 UTC (permalink / raw) To: Thompson, David; +Cc: 36404 [-- Attachment #1: Type: text/plain, Size: 39940 bytes --] * gnu/machine.scm: New file. * gnu/machine/ssh.scm: New file. * gnu/local.mk (GNU_SYSTEM_MODULES): Add it. * tests/machine.scm: New file. * Makefile.am (SCM_TESTS): Add it. --- Makefile.am | 3 +- gnu/local.mk | 5 +- gnu/machine.scm | 89 +++++++++ gnu/machine/ssh.scm | 355 ++++++++++++++++++++++++++++++++++ tests/machine.scm | 450 ++++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 900 insertions(+), 2 deletions(-) create mode 100644 gnu/machine.scm create mode 100644 gnu/machine/ssh.scm create mode 100644 tests/machine.scm diff --git a/Makefile.am b/Makefile.am index 80be73e4bf..9156554635 100644 --- a/Makefile.am +++ b/Makefile.am @@ -423,7 +423,8 @@ SCM_TESTS = \ tests/import-utils.scm \ tests/store-database.scm \ tests/store-deduplication.scm \ - tests/store-roots.scm + tests/store-roots.scm \ + tests/machine.scm SH_TESTS = \ tests/guix-build.sh \ diff --git a/gnu/local.mk b/gnu/local.mk index f5d53b49b8..ad87de5ea7 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -564,6 +564,9 @@ GNU_SYSTEM_MODULES = \ %D%/system/uuid.scm \ %D%/system/vm.scm \ \ + %D%/machine.scm \ + %D%/machine/ssh.scm \ + \ %D%/build/accounts.scm \ %D%/build/activation.scm \ %D%/build/bootloader.scm \ @@ -629,7 +632,7 @@ INSTALLER_MODULES = \ %D%/installer/newt/user.scm \ %D%/installer/newt/utils.scm \ %D%/installer/newt/welcome.scm \ - %D%/installer/newt/wifi.scm + %D%/installer/newt/wifi.scm # Always ship the installer modules but compile them only when # ENABLE_INSTALLER is true. diff --git a/gnu/machine.scm b/gnu/machine.scm new file mode 100644 index 0000000000..900a2020dc --- /dev/null +++ b/gnu/machine.scm @@ -0,0 +1,89 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 David Thompson <davet@gnu.org> +;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org> +;;; +;;; 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 <http://www.gnu.org/licenses/>. + +(define-module (gnu machine) + #:use-module (gnu system) + #:use-module (guix derivations) + #:use-module (guix monads) + #:use-module (guix records) + #:use-module (guix store) + #:export (machine + machine? + this-machine + + machine-system + machine-environment + machine-configuration + machine-display-name + + build-machine + deploy-machine + remote-eval)) + +;;; Commentary: +;;; +;;; This module provides the types used to declare individual machines in a +;;; heterogeneous Guix deployment. The interface allows users of specify system +;;; configurations and the means by which resources should be provisioned on a +;;; per-host basis. +;;; +;;; Code: + +(define-record-type* <machine> machine + make-machine + machine? + this-machine + (system machine-system) ; <operating-system> + (environment machine-environment) ; symbol + (configuration machine-configuration ; configuration object + (default #f))) ; specific to environment + +(define (machine-display-name machine) + "Return the host-name identifying MACHINE." + (operating-system-host-name (machine-system machine))) + +(define (build-machine machine) + "Monadic procedure that builds the system derivation for MACHINE and returning +a list containing the path of the derivation file and the path of the derivation +output." + (let ((os (machine-system machine))) + (mlet* %store-monad ((osdrv (operating-system-derivation os)) + (_ ((store-lift build-derivations) (list osdrv)))) + (return (list (derivation-file-name osdrv) + (derivation->output-path osdrv)))))) + +(define (remote-eval machine exp) + "Evaluate EXP, a gexp, on MACHINE. Ensure that all the elements EXP refers to +are built and deployed to MACHINE beforehand." + (case (machine-environment machine) + ((managed-host) + ((@@ (gnu machine ssh) remote-eval) machine exp)) + (else + (let ((type (machine-environment machine))) + (error "unsupported environment type" type))))) + +(define (deploy-machine machine) + "Monadic procedure transferring the new system's OS closure to the remote +MACHINE, activating it on MACHINE and switching MACHINE to the new generation." + (case (machine-environment machine) + ((managed-host) + ((@@ (gnu machine ssh) deploy-machine) machine)) + (else + (let ((type (machine-environment machine))) + (error "unsupported environment type" type))))) diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm new file mode 100644 index 0000000000..a8f946e19f --- /dev/null +++ b/gnu/machine/ssh.scm @@ -0,0 +1,355 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org> +;;; +;;; 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 <http://www.gnu.org/licenses/>. + +(define-module (gnu machine ssh) + #:use-module (gnu bootloader) + #:use-module (gnu machine) + #:autoload (gnu packages gnupg) (guile-gcrypt) + #:use-module (gnu services) + #:use-module (gnu services shepherd) + #:use-module (gnu system) + #:use-module (guix derivations) + #:use-module (guix gexp) + #:use-module (guix modules) + #:use-module (guix monads) + #:use-module (guix records) + #:use-module (guix ssh) + #:use-module (guix store) + #:use-module (ice-9 match) + #:use-module (srfi srfi-19) + #:export (machine-ssh-configuration + machine-ssh-configuration? + machine-ssh-configuration + + machine-ssh-configuration-host-name + machine-ssh-configuration-port + machine-ssh-configuration-user + machine-ssh-configuration-session)) + +;;; Commentary: +;;; +;;; This module implements remote evaluation and system deployment for +;;; machines that are accessable over SSH and have a known host-name. In the +;;; sense of the broader "machine" interface, we describe the environment for +;;; such machines as 'managed-host. +;;; +;;; Code: + +\f +;;; +;;; SSH client parameter configuration. +;;; + +(define-record-type* <machine-ssh-configuration> machine-ssh-configuration + make-machine-ssh-configuration + machine-ssh-configuration? + this-machine-ssh-configuration + (host-name machine-ssh-configuration-host-name) ; string + (port machine-ssh-configuration-port ; integer + (default 22)) + (user machine-ssh-configuration-user ; string + (default "root")) + (identity machine-ssh-configuration-identity ; path to a private key + (default #f)) + (session machine-ssh-configuration-session ; session + (default #f))) + +(define (machine-ssh-session machine) + "Return the SSH session that was given in MACHINE's configuration, or create +one from the configuration's parameters if one was not provided." + (let ((config (machine-configuration machine))) + (if (machine-ssh-configuration? config) + (or (machine-ssh-configuration-session config) + (let ((host-name (machine-ssh-configuration-host-name config)) + (user (machine-ssh-configuration-user config)) + (port (machine-ssh-configuration-port config)) + (identity (machine-ssh-configuration-identity config))) + (open-ssh-session host-name + #:user user + #:port port + #:identity identity))) + (error "unsupported configuration type")))) + +\f +;;; +;;; Remote evaluation. +;;; + +(define (remote-eval machine exp) + "Internal implementation of 'remote-eval' for MACHINE instances with an +environment type of 'managed-host." + (unless (machine-configuration machine) + (error (format #f (G_ "no configuration specified for machine of environment '~a'") + (symbol->string (machine-environment machine))))) + ((@ (guix remote) remote-eval) exp (machine-ssh-session machine))) + +\f +;;; +;;; 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 #$(derivation->output-path drv)) + (number (1+ (generation-number %system-profile))) + (generation (generation-file-name %system-profile number)) + (old-env (environ)) + (old-path %load-path) + (old-cpath %load-compiled-path)) + (switch-symlinks generation system) + (switch-symlinks %system-profile generation) + ;; Guard against the activation script modifying $PATH. + (dynamic-wind + (const #t) + (lambda () + (setenv "GUIX_NEW_SYSTEM" system) + ;; Guard against the activation script modifying '%load-path'. + (dynamic-wind + (const #t) + (lambda () + ;; 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)))) + (lambda () + (set! %load-path old-path) + (set! %load-compiled-path old-cpath)))) + (lambda () + (environ old-env)))))))) + + (let* ((os (machine-system machine)) + (script (operating-system-activation-script os))) + (mlet* %store-monad ((drv (operating-system-derivation os))) + (remote-eval machine (remote-exp drv script))))) + +(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)) + (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." + (define bootable-kernel-arguments + (@@ (gnu system) bootable-kernel-arguments)) + + (define remote-exp + (with-extensions (list guile-gcrypt) + (with-imported-modules (source-module-closure '((guix config) + (guix profiles))) + #~(begin + (use-modules (guix config) + (guix profiles) + (ice-9 textual-ports)) + + (define %system-profile + (string-append %state-directory "/profiles/system")) + + (define (read-file path) + (call-with-input-file path + (lambda (port) + (get-string-all port)))) + + (map (lambda (generation) + (let* ((system-path (generation-file-name %system-profile + generation)) + (boot-parameters-path (string-append system-path + "/parameters")) + (time (stat:mtime (lstat system-path)))) + (list generation + system-path + time + (read-file boot-parameters-path)))) + (reverse (generation-numbers %system-profile))))))) + + (mlet* %store-monad ((generations (remote-eval machine remote-exp))) + (return + (map (lambda (generation) + (match generation + ((generation system-path time serialized-params) + (let* ((params (call-with-input-string serialized-params + read-boot-parameters)) + (root (boot-parameters-root-device params)) + (label (boot-parameters-label params))) + (boot-parameters + (inherit params) + (label + (string-append label " (#" + (number->string generation) ", " + (let ((time (make-time time-utc 0 time))) + (date->string (time-utc->date time) + "~Y-~m-~d ~H:~M")) + ")")) + (kernel-arguments + (append (bootable-kernel-arguments system-path root) + (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")) + (old-path %load-path) + (old-cpath %load-compiled-path)) + (switch-symlinks temp-gc-root gc-root) + + (unless (false-if-exception + (begin + (install-boot-config #$bootcfg #$bootcfg-file "/") + ;; Guard against the activation script modifying + ;; '%load-path'. + (dynamic-wind + (const #t) + (lambda () + ;; 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)))) + (lambda () + (set! %load-path old-path) + (set! %load-compiled-path old-cpath))))) + (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))) + (remote-eval machine (remote-exp installer bootcfg bootcfg-file))))) + +(define (deploy-machine machine) + "Internal implementation of 'deploy-machine' for MACHINE instances with an +environment type of 'managed-host." + (unless (machine-configuration machine) + (error (format #f (G_ "no configuration specified for machine of environment '~a'") + (symbol->string (machine-environment machine))))) + (mbegin %store-monad + (switch-to-system machine) + (upgrade-shepherd-services machine) + (install-bootloader machine))) diff --git a/tests/machine.scm b/tests/machine.scm new file mode 100644 index 0000000000..390c0189bb --- /dev/null +++ b/tests/machine.scm @@ -0,0 +1,450 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org> +;;; +;;; 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 <http://www.gnu.org/licenses/>. + +(define-module (gnu tests machine) + #:use-module (gnu bootloader grub) + #:use-module (gnu bootloader) + #:use-module (gnu build marionette) + #:use-module (gnu build vm) + #:use-module (gnu machine) + #:use-module (gnu machine ssh) + #:use-module (gnu packages bash) + #:use-module (gnu packages virtualization) + #:use-module (gnu services base) + #:use-module (gnu services networking) + #:use-module (gnu services ssh) + #:use-module (gnu services) + #:use-module (gnu system file-systems) + #: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 pki) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (ice-9 ftw) + #:use-module (ice-9 match) + #:use-module (ice-9 textual-ports) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-64) + #:use-module (ssh auth) + #:use-module (ssh channel) + #:use-module (ssh key) + #:use-module (ssh session)) + +\f +;;; +;;; Virtual machine scaffolding. +;;; + +(define marionette-pid (@@ (gnu build marionette) marionette-pid)) + +(define (call-with-marionette path command proc) + "Invoke PROC with a marionette running COMMAND in PATH." + (let* ((marionette (make-marionette command #:socket-directory path)) + (pid (marionette-pid marionette))) + (dynamic-wind + (lambda () + (unless marionette + (error "could not start marionette"))) + (lambda () (proc marionette)) + (lambda () + (kill pid SIGTERM))))) + +(define (dir-join . components) + "Join COMPONENTS with `file-name-separator-string'." + (string-join components file-name-separator-string)) + +(define (call-with-machine-test-directory proc) + "Run PROC with the path to a temporary directory that will be cleaned up +when PROC returns. Only files that can be passed to 'delete-file' should be +created within the temporary directory; cleanup will not recurse into +subdirectories." + (let ((path (tmpnam))) + (dynamic-wind + (lambda () + (unless (mkdir path) + (error (format #f "could not create directory '~a'" path)))) + (lambda () (proc path)) + (lambda () + (let ((children (map first (cddr (file-system-tree path))))) + (for-each (lambda (child) + (false-if-exception + (delete-file (dir-join path child)))) + children) + (rmdir path)))))) + +(define (os-for-test os) + "Return an <operating-system> record derived from OS that is appropriate for +use with 'qemu-image'." + (define file-systems-to-keep + ;; Keep only file systems other than root and not normally bound to real + ;; devices. + (remove (lambda (fs) + (let ((target (file-system-mount-point fs)) + (source (file-system-device fs))) + (or (string=? target "/") + (string-prefix? "/dev/" source)))) + (operating-system-file-systems os))) + + (define root-uuid + ;; UUID of the root file system. + ((@@ (gnu system vm) operating-system-uuid) os 'dce)) + + + (operating-system + (inherit os) + ;; Assume we have an initrd with the whole QEMU shebang. + + ;; Force our own root file system. Refer to it by UUID so that + ;; it works regardless of how the image is used ("qemu -hda", + ;; Xen, etc.). + (file-systems (cons (file-system + (mount-point "/") + (device root-uuid) + (type "ext4")) + file-systems-to-keep)))) + +(define (qemu-image-for-test os) + "Return a derivation producing a QEMU disk image running OS. This procedure +is similar to 'system-qemu-image' in (gnu system vm), but makes use of +'os-for-test' so that callers may obtain the same system derivation that will +be booted by the image." + (define root-uuid ((@@ (gnu system vm) operating-system-uuid) os 'dce)) + (let* ((os (os-for-test os)) + (bootcfg (operating-system-bootcfg os))) + (qemu-image #:os os + #:bootcfg-drv bootcfg + #:bootloader (bootloader-configuration-bootloader + (operating-system-bootloader os)) + #:disk-image-size (* 9000 (expt 2 20)) + #:file-system-type "ext4" + #:file-system-uuid root-uuid + #:inputs `(("system" ,os) + ("bootcfg" ,bootcfg)) + #:copy-inputs? #t))) + +(define (make-writable-image image) + "Return a derivation producing a script to create a writable disk image +overlay of IMAGE, writing the overlay to the the path given as a command-line +argument to the script." + (define qemu-img-exec + #~(list (string-append #$qemu-minimal "/bin/qemu-img") + "create" "-f" "qcow2" + "-o" (string-append "backing_file=" #$image))) + + (define builder + #~(call-with-output-file #$output + (lambda (port) + (format port "#!~a~% exec ~a \"$@\"~%" + #$(file-append bash "/bin/sh") + (string-join #$qemu-img-exec " ")) + (chmod port #o555)))) + + (gexp->derivation "make-writable-image.sh" builder)) + +(define (run-os-for-test os) + "Return a derivation producing a script to run OS as a qemu guest, whose +first argument is the path to a writable disk image. Additional arguments are +passed as-is to qemu." + (define kernel-arguments + #~(list "console=ttyS0" + #+@(operating-system-kernel-arguments os "/dev/sda1"))) + + (define qemu-exec + #~(begin + (list (string-append #$qemu-minimal "/bin/" #$(qemu-command (%current-system))) + "-kernel" #$(operating-system-kernel-file os) + "-initrd" #$(file-append os "/initrd") + (format #f "-append ~s" + (string-join #$kernel-arguments " ")) + #$@(if (file-exists? "/dev/kvm") + '("-enable-kvm") + '()) + "-no-reboot" + "-net nic,model=virtio" + "-object" "rng-random,filename=/dev/urandom,id=guixsd-vm-rng" + "-device" "virtio-rng-pci,rng=guixsd-vm-rng" + "-vga" "std" + "-m" "256" + "-net" "user,hostfwd=tcp::2222-:22"))) + + (define builder + #~(call-with-output-file #$output + (lambda (port) + (format port "#!~a~% exec ~a -drive \"file=$@\"~%" + #$(file-append bash "/bin/sh") + (string-join #$qemu-exec " ")) + (chmod port #o555)))) + + (gexp->derivation "run-vm.sh" builder)) + +(define (scripts-for-test os) + "Build and return a list containing the paths of: + +- A script to make a writable disk image overlay of OS. +- A script to run that disk image overlay as a qemu guest." + (let ((virtualized-os (os-for-test os))) + (mlet* %store-monad ((osdrv (operating-system-derivation virtualized-os)) + (imgdrv (qemu-image-for-test os)) + + ;; Ungexping 'imgdrv' or 'osdrv' will result in an + ;; error if the derivations don't exist in the store, + ;; so we ensure they're built prior to invoking + ;; 'run-vm' or 'make-image'. + (_ ((store-lift build-derivations) (list imgdrv))) + + (run-vm (run-os-for-test virtualized-os)) + (make-image + (make-writable-image (derivation->output-path imgdrv)))) + (mbegin %store-monad + ((store-lift build-derivations) (list imgdrv make-image run-vm)) + (return (list (derivation->output-path make-image) + (derivation->output-path run-vm))))))) + +(define (call-with-marionette-and-session os proc) + "Construct a marionette backed by OS in a temporary test environment and +invoke PROC with two arguments: the marionette object, and an SSH session +connected to the marionette." + (call-with-machine-test-directory + (lambda (path) + (match (with-store store + (run-with-store store + (scripts-for-test %system))) + ((make-image run-vm) + (let ((image (dir-join path "image"))) + ;; Create the writable image overlay. + (system (string-join (list make-image image) " ")) + (call-with-marionette + path + (list run-vm image) + (lambda (marionette) + ;; XXX: The guest clearly has (gcrypt pk-crypto) since this + ;; works, but trying to import it from 'marionette-eval' fails as + ;; the Marionette REPL does not have 'guile-gcrypt' in its + ;; %load-path. + (marionette-eval + `(begin + (use-modules (ice-9 popen)) + (let ((port (open-pipe* OPEN_WRITE "guix" "archive" "--authorize"))) + (put-string port ,%signing-key) + (close port))) + marionette) + ;; XXX: This is an absolute hack to work around potential quirks + ;; in the operating system. For one, we invoke 'herd' from the + ;; command-line to ensure that the Shepherd socket file + ;; exists. Second, we enable 'ssh-daemon', as there's a chance + ;; the service will be disabled upon booting the image. + (marionette-eval + `(system "herd enable ssh-daemon") + marionette) + (marionette-eval + '(begin + (use-modules (gnu services herd)) + (start-service 'ssh-daemon)) + marionette) + (call-with-connected-session/auth + (lambda (session) + (proc marionette session))))))))))) + +\f +;;; +;;; SSH session management. These are borrowed from (gnu tests ssh). +;;; + +(define (make-session-for-test) + "Make a session with predefined parameters for a test." + (make-session #:user "root" + #:port 2222 + #:host "localhost")) + +(define (call-with-connected-session proc) + "Call the one-argument procedure PROC with a freshly created and +connected SSH session object, return the result of the procedure call. The +session is disconnected when the PROC is finished." + (let ((session (make-session-for-test))) + (dynamic-wind + (lambda () + (let ((result (connect! session))) + (unless (equal? result 'ok) + (error "Could not connect to a server" + session result)))) + (lambda () (proc session)) + (lambda () (disconnect! session))))) + +(define (call-with-connected-session/auth proc) + "Make an authenticated session. We should be able to connect as +root with an empty password." + (call-with-connected-session + (lambda (session) + ;; Try the simple authentication methods. Dropbear requires + ;; 'none' when there are no passwords, whereas OpenSSH accepts + ;; 'password' with an empty password. + (let loop ((methods (list (cut userauth-password! <> "") + (cut userauth-none! <>)))) + (match methods + (() + (error "all the authentication methods failed")) + ((auth rest ...) + (match (pk 'auth (auth session)) + ('success + (proc session)) + ('denied + (loop rest))))))))) + +\f +;;; +;;; Virtual machines for use in the test suite. +;;; + +(define %system + ;; A "bare bones" operating system running both an OpenSSH daemon and the + ;; "marionette" service. + (marionette-operating-system + (operating-system + (host-name "gnu") + (timezone "Etc/UTC") + (bootloader (bootloader-configuration + (bootloader grub-bootloader) + (target "/dev/sda") + (terminal-outputs '(console)))) + (file-systems (cons (file-system + (mount-point "/") + (device "/dev/vda1") + (type "ext4")) + %base-file-systems)) + (services + (append (list (service dhcp-client-service-type) + (service openssh-service-type + (openssh-configuration + (permit-root-login #t) + (allow-empty-passwords? #t)))) + %base-services))) + #:imported-modules '((gnu services herd) + (guix combinators)))) + +(define %signing-key + ;; The host's signing key, encoded as a string. The "marionette" will reject + ;; any files signed by an unauthorized host, so we'll need to send this key + ;; over and authorize it. + (call-with-input-file %public-key-file + (lambda (port) + (get-string-all port)))) + +\f +(test-begin "machine") + +(define (system-generations 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)) + +(define (running-services marionette) + (marionette-eval + '(begin + (use-modules (gnu services herd) + (srfi srfi-1)) + (map (compose first live-service-provision) + (filter live-service-running (current-services)))) + marionette)) + +(define (count-grub-cfg-entries marionette) + (marionette-eval + '(begin + (define grub-cfg + (call-with-input-file "/boot/grub/grub.cfg" + (lambda (port) + (get-string-all port)))) + + (let loop ((n 0) + (start 0)) + (let ((index (string-contains grub-cfg "menuentry" start))) + (if index + (loop (1+ n) (1+ index)) + n)))) + marionette)) + +(define %target-system + (marionette-operating-system + (operating-system + (host-name "gnu-deployed") + (timezone "Etc/UTC") + (bootloader (bootloader-configuration + (bootloader grub-bootloader) + (target "/dev/sda") + (terminal-outputs '(console)))) + (file-systems (cons (file-system + (mount-point "/") + (device "/dev/vda1") + (type "ext4")) + %base-file-systems)) + (services + (append (list (service tor-service-type) + (service dhcp-client-service-type) + (service openssh-service-type + (openssh-configuration + (permit-root-login #t) + (allow-empty-passwords? #t)))) + %base-services))) + #:imported-modules '((gnu services herd) + (guix combinators)))) + +(call-with-marionette-and-session + (os-for-test %system) + (lambda (marionette session) + (let ((generations-prior (system-generations marionette)) + (services-prior (running-services marionette)) + (grub-entry-count-prior (count-grub-cfg-entries marionette)) + (machine (machine + (system %target-system) + (environment 'managed-host) + (configuration (machine-ssh-configuration + (host-name "localhost") + (session session)))))) + (with-store store + (run-with-store store + (build-machine machine)) + (run-with-store store + (deploy-machine machine))) + (test-equal "deployment created new generation" + (length (system-generations marionette)) + (1+ (length generations-prior))) + (test-assert "deployment started new service" + (and (not (memq 'tor services-prior)) + (memq 'tor (running-services marionette)))) + (test-equal "deployment created new menu entry" + (count-grub-cfg-entries marionette) + ;; A Grub configuration that contains a single menu entry does not have + ;; an "old configurations" submenu. Deployment, then, would result in + ;; this submenu being created, meaning an additional two 'menuentry' + ;; fields rather than just one. + (if (= grub-entry-count-prior 1) + (+ 2 grub-entry-count-prior) + (1+ grub-entry-count-prior)))))) + +(test-end "machine") -- 2.22.0 [-- Attachment #2: signature.asc --] [-- Type: application/pgp-signature, Size: 832 bytes --] ^ permalink raw reply related [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 3/5] Add 'guix deploy'. 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 ` Jakob L. Kreuze 2019-06-28 13:37 ` [bug#36404] [PATCH 4/5] Export the (gnu machine) interface Jakob L. Kreuze 2019-06-29 21:36 ` [bug#36404] [PATCH 2/5] gnu: Add machine type for deployment specifications Christopher Lemmer Webber 1 sibling, 1 reply; 84+ messages in thread From: Jakob L. Kreuze @ 2019-06-28 13:36 UTC (permalink / raw) To: Thompson, David; +Cc: 36404 [-- Attachment #1: Type: text/plain, Size: 4092 bytes --] * guix/scripts/deploy.scm: New file. * Makefile.am (MODULES): Add it. --- Makefile.am | 1 + guix/scripts/deploy.scm | 90 +++++++++++++++++++++++++++++++++++++++++ 2 files changed, 91 insertions(+) create mode 100644 guix/scripts/deploy.scm diff --git a/Makefile.am b/Makefile.am index 9156554635..8dbc220489 100644 --- a/Makefile.am +++ b/Makefile.am @@ -266,6 +266,7 @@ MODULES = \ guix/scripts/weather.scm \ guix/scripts/container.scm \ guix/scripts/container/exec.scm \ + guix/scripts/deploy.scm \ guix.scm \ $(GNU_SYSTEM_MODULES) diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm new file mode 100644 index 0000000000..c52434f518 --- /dev/null +++ b/guix/scripts/deploy.scm @@ -0,0 +1,90 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 David Thompson <davet@gnu.org> +;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org> +;;; +;;; 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 <http://www.gnu.org/licenses/>. + +(define-module (guix scripts deploy) + #:use-module (gnu machine) + #:use-module (guix scripts) + #:use-module (guix scripts build) + #:use-module (guix store) + #:use-module (guix ui) + #:use-module (ice-9 format) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-37) + #:export (guix-deploy)) + +;;; Commentary: +;;; +;;; This program provides a command-line interface to (gnu machine), allowing +;;; users to perform remote deployments through specification files. +;;; +;;; Code: + +\f + +(define (show-help) + (display (G_ "Usage: guix deploy [OPTION] FILE... +Perform the deployment specified by FILE.\n")) + (show-build-options-help) + (newline) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + (cons* (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + %standard-build-options)) + +(define %default-options + '((system . ,(%current-system)) + (substitutes? . #t) + (build-hook? . #t) + (graft? . #t) + (debug . 0) + (verbosity . 2))) + +(define (load-source-file file) + "Load FILE as a user module." + (let ((module (make-user-module '()))) + (load* file module))) + +(define (guix-deploy . args) + (define (handle-argument arg result) + (alist-cons 'file arg result)) + (let* ((opts (parse-command-line args %options (list %default-options) + #:argument-handler handle-argument)) + (file (assq-ref opts 'file)) + (machines (or (and file (load-source-file file)) '()))) + (with-store store + (set-build-options-from-command-line store opts) + (for-each (lambda (machine) + (format #t "building ~a... " (machine-display-name machine)) + (run-with-store store (build-machine machine)) + (display "done\n")) + machines) + (for-each (lambda (machine) + (format #t "deploying to ~a... " (machine-display-name machine)) + (run-with-store store (deploy-machine machine)) + (display "done\n")) + machines)))) -- 2.22.0 [-- Attachment #2: signature.asc --] [-- Type: application/pgp-signature, Size: 832 bytes --] ^ permalink raw reply related [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 4/5] Export the (gnu machine) interface. 2019-06-28 13:36 ` [bug#36404] [PATCH 3/5] Add 'guix deploy' Jakob L. Kreuze @ 2019-06-28 13:37 ` Jakob L. Kreuze 2019-06-28 13:37 ` [bug#36404] [PATCH 5/5] doc: Add section for 'guix deploy' Jakob L. Kreuze 0 siblings, 1 reply; 84+ messages in thread From: Jakob L. Kreuze @ 2019-06-28 13:37 UTC (permalink / raw) To: Thompson, David; +Cc: 36404 [-- Attachment #1: Type: text/plain, Size: 1292 bytes --] * gnu.scm (%public-modules): Add '(gnu machine)'. * gnu.scm (use-machine-modules): New macro. --- gnu.scm | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/gnu.scm b/gnu.scm index 2c29b6dc3f..fa643a5b92 100644 --- a/gnu.scm +++ b/gnu.scm @@ -27,7 +27,8 @@ #:use-module (guix packages) #:use-module (gnu packages) #:use-module (gnu services) - #:export (use-package-modules + #:export (use-machine-modules + use-package-modules use-service-modules use-system-modules)) @@ -45,6 +46,7 @@ (gnu system file-systems) (gnu bootloader) (gnu bootloader grub) + (gnu machine) (gnu system keyboard) (gnu system pam) (gnu system shadow) ; 'user-account' @@ -142,6 +144,10 @@ Try adding @code{(use-service-modules ~a)}.") (current-source-location)) hint))) +(define-syntax-rule (use-machine-modules module ...) + (try-use-modules package-module-hint + (gnu machine module) ...)) + (define-syntax-rule (use-package-modules module ...) (try-use-modules package-module-hint (gnu packages module) ...)) -- 2.22.0 [-- Attachment #2: signature.asc --] [-- Type: application/pgp-signature, Size: 832 bytes --] ^ permalink raw reply related [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 5/5] doc: Add section for 'guix deploy'. 2019-06-28 13:37 ` [bug#36404] [PATCH 4/5] Export the (gnu machine) interface Jakob L. Kreuze @ 2019-06-28 13:37 ` Jakob L. Kreuze 0 siblings, 0 replies; 84+ messages in thread From: Jakob L. Kreuze @ 2019-06-28 13:37 UTC (permalink / raw) To: Thompson, David; +Cc: 36404 [-- Attachment #1: Type: text/plain, Size: 5823 bytes --] * doc/guix.texi: Add section "Invoking guix deploy". --- doc/guix.texi | 103 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 103 insertions(+) diff --git a/doc/guix.texi b/doc/guix.texi index f0d148ace0..948767d8c8 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -81,6 +81,7 @@ Documentation License''. * guix gc: (guix)Invoking guix gc. Reclaiming unused disk space. * guix pull: (guix)Invoking guix pull. Update the list of available packages. * guix system: (guix)Invoking guix system. Manage the operating system configuration. +* guix deploy: (guix)Invoking guix deploy. Manage operating system configurations for remote hosts. @end direntry @dircategory Software development @@ -269,6 +270,7 @@ System Configuration * Initial RAM Disk:: Linux-Libre bootstrapping. * Bootloader Configuration:: Configuring the boot loader. * Invoking guix system:: Instantiating a system configuration. +* Invoking guix deploy:: Deploying a system configuration to a remote host. * Running Guix in a VM:: How to run Guix System in a virtual machine. * Defining Services:: Adding new service definitions. @@ -10303,6 +10305,7 @@ instance to support new system services. * Initial RAM Disk:: Linux-Libre bootstrapping. * Bootloader Configuration:: Configuring the boot loader. * Invoking guix system:: Instantiating a system configuration. +* Invoking guix deploy:: Deploying a system configuration to a remote host. * Running Guix in a VM:: How to run Guix System in a virtual machine. * Defining Services:: Adding new service definitions. @end menu @@ -25399,6 +25402,106 @@ example graph. @end table +@node Invoking guix deploy +@section Invoking @code{guix deploy} + +In addition to managing a machine's configuration locally through operating +system declarations, Guix also provides the ability to managing multiple remote +hosts as a logical ``deployment''. This is done using @command{guix deploy}. + +@example +guix deploy @var{file} +@end example + +Such an invocation will deploy the machines that the code within @var{file} +evaluates to. As an example, @var{file} might contain a definition like this: + +@example +;; This is a Guix deployment of a "bare bones" setup, with +;; no X11 display server, to a machine with an SSH daemon +;; listening on localhost:2222. A configuration such as this +;; may be appropriate for virtual machine with ports +;; forwarded to the host's loopback interface. + +(use-modules (gnu) (guix)) +(use-machine-modules ssh) +(use-service-modules networking ssh) +(use-package-modules bootloaders) + +(define %system + (operating-system + (host-name "gnu-deployed") + (timezone "Etc/UTC") + (bootloader (bootloader-configuration + (bootloader grub-bootloader) + (target "/dev/vda") + (terminal-outputs '(console)))) + (file-systems (cons (file-system + (mount-point "/") + (device "/dev/vda1") + (type "ext4")) + %base-file-systems)) + (services + (append (list (service dhcp-client-service-type) + (service openssh-service-type + (openssh-configuration + (permit-root-login #t) + (allow-empty-passwords? #t)))) + %base-services)))) + +(list (machine + (system %system) + (environment 'managed-host) + (configuration (machine-ssh-configuration + (host-name "localhost") + (identity "./id_rsa") + (port 2222))))) +@end example + +The file should evaluate to a list of machines, rather than just one. This +example, upon being deployed, will create a new generation on the remote system +realizing the operating-system configuration @var{%system}. @var{environment} +and @var{configuration} specify how the machine should be provisioned--that is, +deployment and management of computing resources. The above example does not +provision any resources -- a @code{'managed-host} is a machine that is already +up and running the Guix system. A more complex deployment may involve +i.e. starting virtual machines through a VPS provider, however, in which case a +different @var{environment} types would be used. + +@deftp {Data Type} machine +This is the data type representing a single machine in a heterogeneous Guix +deployment. + +@table @asis +@item @code{system} +The object of the operating system configuration to deploy. + +@item @code{environment} +A symbol describing how the machine should be provisioned. At the moment, only +the only supported value is @code{'managed-host}. + +@item @code{configuration} (default: @code{#f}) +An object describing the configuration for the machine's @code{environment}. If +the @code{environment} has a default configuration, @code{#f} can be used. If +@code{#f} is used for an environment with no default configuration, however, an +error will be thrown. +@end table +@end deftp + +@deftp {Data Type} machine-ssh-configuration +This is the data type representing the SSH client parameters for connecting to a +@code{'managed-host}. + +@table @asis +@item @code{host-name} +@item @code{port} (default: @code{22}) +@item @code{user} (default: @code{"root"}) +@item @code{identity} (default: @code{#f}) +If specified, the path to the SSH private key to use to authenticate with the +remote host. +@end table +@end deftp + @node Running Guix in a VM @section Running Guix in a Virtual Machine -- 2.22.0 [-- Attachment #2: signature.asc --] [-- Type: application/pgp-signature, Size: 832 bytes --] ^ permalink raw reply related [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 2/5] gnu: Add machine type for deployment specifications. 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-29 21:36 ` Christopher Lemmer Webber 2019-06-30 0:30 ` Jakob L. Kreuze 1 sibling, 1 reply; 84+ messages in thread From: Christopher Lemmer Webber @ 2019-06-29 21:36 UTC (permalink / raw) To: 36404 Jakob L. Kreuze writes: > * gnu/machine.scm: New file. > * gnu/machine/ssh.scm: New file. > * gnu/local.mk (GNU_SYSTEM_MODULES): Add it. > * tests/machine.scm: New file. > * Makefile.am (SCM_TESTS): Add it. > --- > Makefile.am | 3 +- > gnu/local.mk | 5 +- > gnu/machine.scm | 89 +++++++++ > gnu/machine/ssh.scm | 355 ++++++++++++++++++++++++++++++++++ > tests/machine.scm | 450 ++++++++++++++++++++++++++++++++++++++++++++ > 5 files changed, 900 insertions(+), 2 deletions(-) > create mode 100644 gnu/machine.scm > create mode 100644 gnu/machine/ssh.scm > create mode 100644 tests/machine.scm > > diff --git a/Makefile.am b/Makefile.am > index 80be73e4bf..9156554635 100644 > --- a/Makefile.am > +++ b/Makefile.am > @@ -423,7 +423,8 @@ SCM_TESTS = \ > tests/import-utils.scm \ > tests/store-database.scm \ > tests/store-deduplication.scm \ > - tests/store-roots.scm > + tests/store-roots.scm \ > + tests/machine.scm > > SH_TESTS = \ > tests/guix-build.sh \ > diff --git a/gnu/local.mk b/gnu/local.mk > index f5d53b49b8..ad87de5ea7 100644 > --- a/gnu/local.mk > +++ b/gnu/local.mk > @@ -564,6 +564,9 @@ GNU_SYSTEM_MODULES = \ > %D%/system/uuid.scm \ > %D%/system/vm.scm \ > \ > + %D%/machine.scm \ > + %D%/machine/ssh.scm \ > + \ > %D%/build/accounts.scm \ > %D%/build/activation.scm \ > %D%/build/bootloader.scm \ > @@ -629,7 +632,7 @@ INSTALLER_MODULES = \ > %D%/installer/newt/user.scm \ > %D%/installer/newt/utils.scm \ > %D%/installer/newt/welcome.scm \ > - %D%/installer/newt/wifi.scm > + %D%/installer/newt/wifi.scm > > # Always ship the installer modules but compile them only when > # ENABLE_INSTALLER is true. > diff --git a/gnu/machine.scm b/gnu/machine.scm > new file mode 100644 > index 0000000000..900a2020dc > --- /dev/null > +++ b/gnu/machine.scm > @@ -0,0 +1,89 @@ > +;;; GNU Guix --- Functional package management for GNU > +;;; Copyright © 2019 David Thompson <davet@gnu.org> > +;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org> > +;;; > +;;; 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 <http://www.gnu.org/licenses/>. > + > +(define-module (gnu machine) > + #:use-module (gnu system) > + #:use-module (guix derivations) > + #:use-module (guix monads) > + #:use-module (guix records) > + #:use-module (guix store) > + #:export (machine > + machine? > + this-machine > + > + machine-system > + machine-environment > + machine-configuration > + machine-display-name > + > + build-machine > + deploy-machine > + remote-eval)) Maybe it would make sense to call it machine-remote-eval to distinguish it? I dunno. > + > +;;; Commentary: > +;;; > +;;; This module provides the types used to declare individual machines in a > +;;; heterogeneous Guix deployment. The interface allows users of specify system > +;;; configurations and the means by which resources should be provisioned on a > +;;; per-host basis. > +;;; > +;;; Code: > + > +(define-record-type* <machine> machine > + make-machine > + machine? > + this-machine > + (system machine-system) ; <operating-system> > + (environment machine-environment) ; symbol > + (configuration machine-configuration ; configuration object > + (default #f))) ; specific to environment > + > +(define (machine-display-name machine) > + "Return the host-name identifying MACHINE." > + (operating-system-host-name (machine-system machine))) > + > +(define (build-machine machine) > + "Monadic procedure that builds the system derivation for MACHINE and returning > +a list containing the path of the derivation file and the path of the derivation > +output." > + (let ((os (machine-system machine))) > + (mlet* %store-monad ((osdrv (operating-system-derivation os)) > + (_ ((store-lift build-derivations) (list osdrv)))) > + (return (list (derivation-file-name osdrv) > + (derivation->output-path osdrv)))))) > + > +(define (remote-eval machine exp) > + "Evaluate EXP, a gexp, on MACHINE. Ensure that all the elements EXP refers to > +are built and deployed to MACHINE beforehand." > + (case (machine-environment machine) > + ((managed-host) > + ((@@ (gnu machine ssh) remote-eval) machine exp)) @@ is a (sometimes useful) antipattern. But in general, if something is importing something with @@, it's a good indication that we should just be exporting it. What do you think? > + (else > + (let ((type (machine-environment machine))) > + (error "unsupported environment type" type))))) > + > +(define (deploy-machine machine) > + "Monadic procedure transferring the new system's OS closure to the remote > +MACHINE, activating it on MACHINE and switching MACHINE to the new generation." > + (case (machine-environment machine) > + ((managed-host) > + ((@@ (gnu machine ssh) deploy-machine) machine)) > + (else > + (let ((type (machine-environment machine))) > + (error "unsupported environment type" type))))) So I guess here's where we'd switch out the environment from being a symbol to being a struct or procedure (or struct containing a procedure). Maybe it wouldn't be so hard to do? In fact, now that I look at it, we could solve both problems at once: there's no need to export deploy-machine and remote-eval if they're wrapped in another structure. Instead, maybe this code could look like: #+BEGIN_SRC scheme (define (remote-eval machine exp) "Evaluate EXP, a gexp, on MACHINE. Ensure that all the elements EXP refers to are built and deployed to MACHINE beforehand." (let* ((environment (machine-environment machine)) (remote-eval (environment-remote-eval environment))) (remote-eval machine exp))) (define (deploy-machine machine) "Monadic procedure transferring the new system's OS closure to the remote MACHINE, activating it on MACHINE and switching MACHINE to the new generation." (let* ((environment (machine-environment machine)) (deploy-machine (environment-deploy-machine environment))) (deploy-machine machine))) #+END_SRC Thoughts? > diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm > new file mode 100644 > index 0000000000..a8f946e19f > --- /dev/null > +++ b/gnu/machine/ssh.scm > @@ -0,0 +1,355 @@ > +;;; GNU Guix --- Functional package management for GNU > +;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org> > +;;; > +;;; 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 <http://www.gnu.org/licenses/>. > + > +(define-module (gnu machine ssh) > + #:use-module (gnu bootloader) > + #:use-module (gnu machine) > + #:autoload (gnu packages gnupg) (guile-gcrypt) > + #:use-module (gnu services) > + #:use-module (gnu services shepherd) > + #:use-module (gnu system) > + #:use-module (guix derivations) > + #:use-module (guix gexp) > + #:use-module (guix modules) > + #:use-module (guix monads) > + #:use-module (guix records) > + #:use-module (guix ssh) > + #:use-module (guix store) > + #:use-module (ice-9 match) > + #:use-module (srfi srfi-19) > + #:export (machine-ssh-configuration > + machine-ssh-configuration? > + machine-ssh-configuration > + > + machine-ssh-configuration-host-name > + machine-ssh-configuration-port > + machine-ssh-configuration-user > + machine-ssh-configuration-session)) > + > +;;; Commentary: > +;;; > +;;; This module implements remote evaluation and system deployment for > +;;; machines that are accessable over SSH and have a known host-name. In the > +;;; sense of the broader "machine" interface, we describe the environment for > +;;; such machines as 'managed-host. > +;;; > +;;; Code: > + > +\f > +;;; > +;;; SSH client parameter configuration. > +;;; > + > +(define-record-type* <machine-ssh-configuration> machine-ssh-configuration > + make-machine-ssh-configuration > + machine-ssh-configuration? > + this-machine-ssh-configuration > + (host-name machine-ssh-configuration-host-name) ; string > + (port machine-ssh-configuration-port ; integer > + (default 22)) > + (user machine-ssh-configuration-user ; string > + (default "root")) > + (identity machine-ssh-configuration-identity ; path to a private key > + (default #f)) > + (session machine-ssh-configuration-session ; session > + (default #f))) > + > +(define (machine-ssh-session machine) > + "Return the SSH session that was given in MACHINE's configuration, or create > +one from the configuration's parameters if one was not provided." > + (let ((config (machine-configuration machine))) > + (if (machine-ssh-configuration? config) Feels like better polymorphism than this is desirable, but I'm not sure I have advice on how to do it right now. Probably services provide the right form of inspiration. At any rate, it's probably not a blocker to merging this first set, but I'd love to see if we could get something more future-extensible. > + (or (machine-ssh-configuration-session config) > + (let ((host-name (machine-ssh-configuration-host-name config)) > + (user (machine-ssh-configuration-user config)) > + (port (machine-ssh-configuration-port config)) > + (identity (machine-ssh-configuration-identity config))) > + (open-ssh-session host-name > + #:user user > + #:port port > + #:identity identity))) > + (error "unsupported configuration type")))) > > +\f > +;;; > +;;; Remote evaluation. > +;;; > + > +(define (remote-eval machine exp) > + "Internal implementation of 'remote-eval' for MACHINE instances with an > +environment type of 'managed-host." > + (unless (machine-configuration machine) > + (error (format #f (G_ "no configuration specified for machine of environment '~a'") > + (symbol->string (machine-environment machine))))) > + ((@ (guix remote) remote-eval) exp (machine-ssh-session machine))) Why not just import remote-eval in the define-module? > + > +\f > +;;; > +;;; 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) It's so cool that this works across machines. Dang! > + (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 #$(derivation->output-path drv)) > + (number (1+ (generation-number %system-profile))) > + (generation (generation-file-name %system-profile number)) > + (old-env (environ)) > + (old-path %load-path) > + (old-cpath %load-compiled-path)) > + (switch-symlinks generation system) > + (switch-symlinks %system-profile generation) > + ;; Guard against the activation script modifying $PATH. Yeah that sounds like it would be bad. But I'm curious... could you explain the specific bug it's preventing here? I'd like to know. > + (dynamic-wind > + (const #t) > + (lambda () > + (setenv "GUIX_NEW_SYSTEM" system) > + ;; Guard against the activation script modifying '%load-path'. > + (dynamic-wind > + (const #t) > + (lambda () > + ;; 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)))) > + (lambda () > + (set! %load-path old-path) > + (set! %load-compiled-path old-cpath)))) > + (lambda () > + (environ old-env)))))))) > + > + (let* ((os (machine-system machine)) > + (script (operating-system-activation-script os))) > + (mlet* %store-monad ((drv (operating-system-derivation os))) > + (remote-eval machine (remote-exp drv script))))) > + > +(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))) This is a curious procedure, but I see why it exists. I guess these really are the only things? Maybe it will change at some point in the future, but seems to make sense for now. > + (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)))) Just to see if I understand it... this is kind of so we can identify and "garbage collect" services that don't apply to the new system? > + (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)) I'm a bit unsure from the above code... I'm guessing one of two things is happening: - Either it's starting services that haven't been started yet, but leaving alone services that are running but which aren't "new" - Or it's restarting services that are currently running Which is it? And mind adding a comment explaining it? By the way, is there anything about the dependency order in which services might need to be restarted to be considered? I'm honestly not sure. > + #t))) > + > + (mlet %store-monad ((target-services target-services)) > + (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." > + (define bootable-kernel-arguments > + (@@ (gnu system) bootable-kernel-arguments)) > + > + (define remote-exp > + (with-extensions (list guile-gcrypt) > + (with-imported-modules (source-module-closure '((guix config) > + (guix profiles))) > + #~(begin > + (use-modules (guix config) > + (guix profiles) > + (ice-9 textual-ports)) > + > + (define %system-profile > + (string-append %state-directory "/profiles/system")) > + > + (define (read-file path) > + (call-with-input-file path > + (lambda (port) > + (get-string-all port)))) > + > + (map (lambda (generation) > + (let* ((system-path (generation-file-name %system-profile > + generation)) > + (boot-parameters-path (string-append system-path > + "/parameters")) > + (time (stat:mtime (lstat system-path)))) > + (list generation > + system-path > + time > + (read-file boot-parameters-path)))) > + (reverse (generation-numbers %system-profile))))))) > + > + (mlet* %store-monad ((generations (remote-eval machine remote-exp))) > + (return > + (map (lambda (generation) > + (match generation > + ((generation system-path time serialized-params) > + (let* ((params (call-with-input-string serialized-params > + read-boot-parameters)) > + (root (boot-parameters-root-device params)) > + (label (boot-parameters-label params))) > + (boot-parameters > + (inherit params) > + (label > + (string-append label " (#" > + (number->string generation) ", " > + (let ((time (make-time time-utc 0 time))) > + (date->string (time-utc->date time) > + "~Y-~m-~d ~H:~M")) > + ")")) > + (kernel-arguments > + (append (bootable-kernel-arguments system-path root) > + (boot-parameters-kernel-arguments params)))))))) > + generations)))) So I guess this is derivative of some of the stuff in guix/scripts/system.scm. That makes me feel like it would be nice if it could be generalized, but I haven't spent enough time with the code to figure out if it really can be. I don't want to block the merge on that desire, though if you agree that generalization between those sections of code is desirable, maybe add a comment to that effect? > +(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")) > + (old-path %load-path) > + (old-cpath %load-compiled-path)) > + (switch-symlinks temp-gc-root gc-root) > + > + (unless (false-if-exception > + (begin > + (install-boot-config #$bootcfg #$bootcfg-file "/") > + ;; Guard against the activation script modifying > + ;; '%load-path'. > + (dynamic-wind > + (const #t) > + (lambda () > + ;; 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)))) > + (lambda () > + (set! %load-path old-path) > + (set! %load-compiled-path old-cpath))))) > + (delete-file temp-gc-root) > + (error "failed to install bootloader")) > + > + (rename-file temp-gc-root gc-root) > + #t))))) This code also looks very similar, but I compared them and I can see that they aren't quite the same, at least in that you had to install the dynamic-wind. But I get the feeling that it still might be possible to generalize them, so could you leave a comment here as well? Unless you think it's really not possible to generalize them to share code for reasons I'm not yet aware of. > + (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))) > + (remote-eval machine (remote-exp installer bootcfg bootcfg-file))))) > + > +(define (deploy-machine machine) > + "Internal implementation of 'deploy-machine' for MACHINE instances with an > +environment type of 'managed-host." > + (unless (machine-configuration machine) > + (error (format #f (G_ "no configuration specified for machine of environment '~a'") > + (symbol->string (machine-environment machine))))) > + (mbegin %store-monad > + (switch-to-system machine) > + (upgrade-shepherd-services machine) > + (install-bootloader machine))) > diff --git a/tests/machine.scm b/tests/machine.scm > new file mode 100644 > index 0000000000..390c0189bb > --- /dev/null > +++ b/tests/machine.scm > @@ -0,0 +1,450 @@ > +;;; GNU Guix --- Functional package management for GNU > +;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org> > +;;; > +;;; 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 <http://www.gnu.org/licenses/>. > + > +(define-module (gnu tests machine) > + #:use-module (gnu bootloader grub) > + #:use-module (gnu bootloader) > + #:use-module (gnu build marionette) > + #:use-module (gnu build vm) > + #:use-module (gnu machine) > + #:use-module (gnu machine ssh) > + #:use-module (gnu packages bash) > + #:use-module (gnu packages virtualization) > + #:use-module (gnu services base) > + #:use-module (gnu services networking) > + #:use-module (gnu services ssh) > + #:use-module (gnu services) > + #:use-module (gnu system file-systems) > + #: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 pki) > + #:use-module (guix store) > + #:use-module (guix utils) > + #:use-module (ice-9 ftw) > + #:use-module (ice-9 match) > + #:use-module (ice-9 textual-ports) > + #:use-module (srfi srfi-1) > + #:use-module (srfi srfi-26) > + #:use-module (srfi srfi-64) > + #:use-module (ssh auth) > + #:use-module (ssh channel) > + #:use-module (ssh key) > + #:use-module (ssh session)) Hoo! That's a lot of imports! Makes sense I guess... > +\f > +;;; > +;;; Virtual machine scaffolding. > +;;; > + > +(define marionette-pid (@@ (gnu build marionette) marionette-pid)) > + > +(define (call-with-marionette path command proc) > + "Invoke PROC with a marionette running COMMAND in PATH." > + (let* ((marionette (make-marionette command #:socket-directory path)) > + (pid (marionette-pid marionette))) > + (dynamic-wind > + (lambda () > + (unless marionette > + (error "could not start marionette"))) > + (lambda () (proc marionette)) > + (lambda () > + (kill pid SIGTERM))))) > + > +(define (dir-join . components) > + "Join COMPONENTS with `file-name-separator-string'." > + (string-join components file-name-separator-string)) > + > +(define (call-with-machine-test-directory proc) > + "Run PROC with the path to a temporary directory that will be cleaned up > +when PROC returns. Only files that can be passed to 'delete-file' should be > +created within the temporary directory; cleanup will not recurse into > +subdirectories." > + (let ((path (tmpnam))) > + (dynamic-wind > + (lambda () > + (unless (mkdir path) > + (error (format #f "could not create directory '~a'" path)))) > + (lambda () (proc path)) > + (lambda () > + (let ((children (map first (cddr (file-system-tree path))))) > + (for-each (lambda (child) > + (false-if-exception > + (delete-file (dir-join path child)))) > + children) > + (rmdir path)))))) > + > +(define (os-for-test os) > + "Return an <operating-system> record derived from OS that is appropriate for > +use with 'qemu-image'." > + (define file-systems-to-keep > + ;; Keep only file systems other than root and not normally bound to real > + ;; devices. > + (remove (lambda (fs) > + (let ((target (file-system-mount-point fs)) > + (source (file-system-device fs))) > + (or (string=? target "/") > + (string-prefix? "/dev/" source)))) > + (operating-system-file-systems os))) > + > + (define root-uuid > + ;; UUID of the root file system. > + ((@@ (gnu system vm) operating-system-uuid) os 'dce)) > + > + > + (operating-system > + (inherit os) > + ;; Assume we have an initrd with the whole QEMU shebang. > + > + ;; Force our own root file system. Refer to it by UUID so that > + ;; it works regardless of how the image is used ("qemu -hda", > + ;; Xen, etc.). > + (file-systems (cons (file-system > + (mount-point "/") > + (device root-uuid) > + (type "ext4")) > + file-systems-to-keep)))) > + > +(define (qemu-image-for-test os) > + "Return a derivation producing a QEMU disk image running OS. This procedure > +is similar to 'system-qemu-image' in (gnu system vm), but makes use of > +'os-for-test' so that callers may obtain the same system derivation that will > +be booted by the image." > + (define root-uuid ((@@ (gnu system vm) operating-system-uuid) os 'dce)) > + (let* ((os (os-for-test os)) > + (bootcfg (operating-system-bootcfg os))) > + (qemu-image #:os os > + #:bootcfg-drv bootcfg > + #:bootloader (bootloader-configuration-bootloader > + (operating-system-bootloader os)) > + #:disk-image-size (* 9000 (expt 2 20)) > + #:file-system-type "ext4" > + #:file-system-uuid root-uuid > + #:inputs `(("system" ,os) > + ("bootcfg" ,bootcfg)) > + #:copy-inputs? #t))) > + > +(define (make-writable-image image) > + "Return a derivation producing a script to create a writable disk image > +overlay of IMAGE, writing the overlay to the the path given as a command-line > +argument to the script." > + (define qemu-img-exec > + #~(list (string-append #$qemu-minimal "/bin/qemu-img") > + "create" "-f" "qcow2" > + "-o" (string-append "backing_file=" #$image))) > + > + (define builder > + #~(call-with-output-file #$output > + (lambda (port) > + (format port "#!~a~% exec ~a \"$@\"~%" > + #$(file-append bash "/bin/sh") > + (string-join #$qemu-img-exec " ")) > + (chmod port #o555)))) > + > + (gexp->derivation "make-writable-image.sh" builder)) > + > +(define (run-os-for-test os) > + "Return a derivation producing a script to run OS as a qemu guest, whose > +first argument is the path to a writable disk image. Additional arguments are > +passed as-is to qemu." > + (define kernel-arguments > + #~(list "console=ttyS0" > + #+@(operating-system-kernel-arguments os "/dev/sda1"))) > + > + (define qemu-exec > + #~(begin > + (list (string-append #$qemu-minimal "/bin/" #$(qemu-command (%current-system))) > + "-kernel" #$(operating-system-kernel-file os) > + "-initrd" #$(file-append os "/initrd") > + (format #f "-append ~s" > + (string-join #$kernel-arguments " ")) > + #$@(if (file-exists? "/dev/kvm") > + '("-enable-kvm") > + '()) > + "-no-reboot" > + "-net nic,model=virtio" > + "-object" "rng-random,filename=/dev/urandom,id=guixsd-vm-rng" > + "-device" "virtio-rng-pci,rng=guixsd-vm-rng" > + "-vga" "std" > + "-m" "256" > + "-net" "user,hostfwd=tcp::2222-:22"))) > + > + (define builder > + #~(call-with-output-file #$output > + (lambda (port) > + (format port "#!~a~% exec ~a -drive \"file=$@\"~%" > + #$(file-append bash "/bin/sh") > + (string-join #$qemu-exec " ")) > + (chmod port #o555)))) > + > + (gexp->derivation "run-vm.sh" builder)) > + > +(define (scripts-for-test os) > + "Build and return a list containing the paths of: > + > +- A script to make a writable disk image overlay of OS. > +- A script to run that disk image overlay as a qemu guest." > + (let ((virtualized-os (os-for-test os))) > + (mlet* %store-monad ((osdrv (operating-system-derivation virtualized-os)) > + (imgdrv (qemu-image-for-test os)) > + > + ;; Ungexping 'imgdrv' or 'osdrv' will result in an > + ;; error if the derivations don't exist in the store, > + ;; so we ensure they're built prior to invoking > + ;; 'run-vm' or 'make-image'. > + (_ ((store-lift build-derivations) (list imgdrv))) > + > + (run-vm (run-os-for-test virtualized-os)) > + (make-image > + (make-writable-image (derivation->output-path imgdrv)))) > + (mbegin %store-monad > + ((store-lift build-derivations) (list imgdrv make-image run-vm)) > + (return (list (derivation->output-path make-image) > + (derivation->output-path run-vm))))))) > + > +(define (call-with-marionette-and-session os proc) > + "Construct a marionette backed by OS in a temporary test environment and > +invoke PROC with two arguments: the marionette object, and an SSH session > +connected to the marionette." > + (call-with-machine-test-directory > + (lambda (path) > + (match (with-store store > + (run-with-store store > + (scripts-for-test %system))) > + ((make-image run-vm) > + (let ((image (dir-join path "image"))) > + ;; Create the writable image overlay. > + (system (string-join (list make-image image) " ")) > + (call-with-marionette > + path > + (list run-vm image) > + (lambda (marionette) > + ;; XXX: The guest clearly has (gcrypt pk-crypto) since this > + ;; works, but trying to import it from 'marionette-eval' fails as > + ;; the Marionette REPL does not have 'guile-gcrypt' in its > + ;; %load-path. > + (marionette-eval > + `(begin > + (use-modules (ice-9 popen)) > + (let ((port (open-pipe* OPEN_WRITE "guix" "archive" "--authorize"))) > + (put-string port ,%signing-key) > + (close port))) > + marionette) > + ;; XXX: This is an absolute hack to work around potential quirks > + ;; in the operating system. For one, we invoke 'herd' from the > + ;; command-line to ensure that the Shepherd socket file > + ;; exists. Second, we enable 'ssh-daemon', as there's a chance > + ;; the service will be disabled upon booting the image. > + (marionette-eval > + `(system "herd enable ssh-daemon") > + marionette) > + (marionette-eval > + '(begin > + (use-modules (gnu services herd)) > + (start-service 'ssh-daemon)) > + marionette) > + (call-with-connected-session/auth > + (lambda (session) > + (proc marionette session))))))))))) > + > +\f > +;;; > +;;; SSH session management. These are borrowed from (gnu tests ssh). > +;;; > + > +(define (make-session-for-test) > + "Make a session with predefined parameters for a test." > + (make-session #:user "root" > + #:port 2222 > + #:host "localhost")) > + > +(define (call-with-connected-session proc) > + "Call the one-argument procedure PROC with a freshly created and > +connected SSH session object, return the result of the procedure call. The > +session is disconnected when the PROC is finished." > + (let ((session (make-session-for-test))) > + (dynamic-wind > + (lambda () > + (let ((result (connect! session))) > + (unless (equal? result 'ok) > + (error "Could not connect to a server" > + session result)))) > + (lambda () (proc session)) > + (lambda () (disconnect! session))))) > + > +(define (call-with-connected-session/auth proc) > + "Make an authenticated session. We should be able to connect as > +root with an empty password." > + (call-with-connected-session > + (lambda (session) > + ;; Try the simple authentication methods. Dropbear requires > + ;; 'none' when there are no passwords, whereas OpenSSH accepts > + ;; 'password' with an empty password. > + (let loop ((methods (list (cut userauth-password! <> "") > + (cut userauth-none! <>)))) > + (match methods > + (() > + (error "all the authentication methods failed")) > + ((auth rest ...) > + (match (pk 'auth (auth session)) > + ('success > + (proc session)) > + ('denied > + (loop rest))))))))) > + > +\f > +;;; > +;;; Virtual machines for use in the test suite. > +;;; > + > +(define %system > + ;; A "bare bones" operating system running both an OpenSSH daemon and the > + ;; "marionette" service. > + (marionette-operating-system > + (operating-system > + (host-name "gnu") > + (timezone "Etc/UTC") > + (bootloader (bootloader-configuration > + (bootloader grub-bootloader) > + (target "/dev/sda") > + (terminal-outputs '(console)))) > + (file-systems (cons (file-system > + (mount-point "/") > + (device "/dev/vda1") > + (type "ext4")) > + %base-file-systems)) > + (services > + (append (list (service dhcp-client-service-type) > + (service openssh-service-type > + (openssh-configuration > + (permit-root-login #t) > + (allow-empty-passwords? #t)))) > + %base-services))) > + #:imported-modules '((gnu services herd) > + (guix combinators)))) > + > +(define %signing-key > + ;; The host's signing key, encoded as a string. The "marionette" will reject > + ;; any files signed by an unauthorized host, so we'll need to send this key > + ;; over and authorize it. > + (call-with-input-file %public-key-file > + (lambda (port) > + (get-string-all port)))) > + > +\f > +(test-begin "machine") > + > +(define (system-generations 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)) > + > +(define (running-services marionette) > + (marionette-eval > + '(begin > + (use-modules (gnu services herd) > + (srfi srfi-1)) > + (map (compose first live-service-provision) > + (filter live-service-running (current-services)))) > + marionette)) > + > +(define (count-grub-cfg-entries marionette) > + (marionette-eval > + '(begin > + (define grub-cfg > + (call-with-input-file "/boot/grub/grub.cfg" > + (lambda (port) > + (get-string-all port)))) > + > + (let loop ((n 0) > + (start 0)) > + (let ((index (string-contains grub-cfg "menuentry" start))) > + (if index > + (loop (1+ n) (1+ index)) > + n)))) > + marionette)) > + > +(define %target-system > + (marionette-operating-system > + (operating-system > + (host-name "gnu-deployed") > + (timezone "Etc/UTC") > + (bootloader (bootloader-configuration > + (bootloader grub-bootloader) > + (target "/dev/sda") > + (terminal-outputs '(console)))) > + (file-systems (cons (file-system > + (mount-point "/") > + (device "/dev/vda1") > + (type "ext4")) > + %base-file-systems)) > + (services > + (append (list (service tor-service-type) > + (service dhcp-client-service-type) > + (service openssh-service-type > + (openssh-configuration > + (permit-root-login #t) > + (allow-empty-passwords? #t)))) > + %base-services))) > + #:imported-modules '((gnu services herd) > + (guix combinators)))) > + > +(call-with-marionette-and-session > + (os-for-test %system) > + (lambda (marionette session) > + (let ((generations-prior (system-generations marionette)) > + (services-prior (running-services marionette)) > + (grub-entry-count-prior (count-grub-cfg-entries marionette)) > + (machine (machine > + (system %target-system) > + (environment 'managed-host) > + (configuration (machine-ssh-configuration > + (host-name "localhost") > + (session session)))))) > + (with-store store > + (run-with-store store > + (build-machine machine)) > + (run-with-store store > + (deploy-machine machine))) > + (test-equal "deployment created new generation" > + (length (system-generations marionette)) > + (1+ (length generations-prior))) > + (test-assert "deployment started new service" > + (and (not (memq 'tor services-prior)) > + (memq 'tor (running-services marionette)))) > + (test-equal "deployment created new menu entry" > + (count-grub-cfg-entries marionette) > + ;; A Grub configuration that contains a single menu entry does not have > + ;; an "old configurations" submenu. Deployment, then, would result in > + ;; this submenu being created, meaning an additional two 'menuentry' > + ;; fields rather than just one. > + (if (= grub-entry-count-prior 1) > + (+ 2 grub-entry-count-prior) > + (1+ grub-entry-count-prior)))))) > + > +(test-end "machine") Seems good from a quick scan, but I'll admit I didn't read these as carefully as I did the rest of the code. This patch looks great overall! I know it was a lot of work to figure out, and I'm impressed by how quickly you came up to speed on it. ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 2/5] gnu: Add machine type for deployment specifications. 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:28 ` Christopher Lemmer Webber 0 siblings, 2 replies; 84+ messages in thread From: Jakob L. Kreuze @ 2019-06-30 0:30 UTC (permalink / raw) To: Christopher Lemmer Webber; +Cc: 36404 [-- Attachment #1: Type: text/plain, Size: 6331 bytes --] Christopher Lemmer Webber <cwebber@dustycloud.org> writes: > Maybe it would make sense to call it machine-remote-eval to > distinguish it? I dunno. Considering the naming used for everything else that '(gnu machine)' exports, I think that makes more sense. And that way I'll be able to just import '(gnu remote ssh)' without shadowing 'remote-eval'. I went ahead and changed it. > @@ is a (sometimes useful) antipattern. But in general, if something is > importing something with @@, it's a good indication that we should just > be exporting it. What do you think? My thinking was that, when we have more than one environment type, @@ could be used with module reflection to get a specific environment's implementation of 'remote-eval'. But going back to your point in an earlier email about implementing environments as distinct types rather than symbols, it would be pretty easy to expose some sort of 'remote-eval' field on those environment types. > Maybe it wouldn't be so hard to do? > > In fact, now that I look at it, we could solve both problems at once: > there's no need to export deploy-machine and remote-eval if they're > wrapped in another structure. Instead, maybe this code could look like: > > #+BEGIN_SRC scheme > (define (remote-eval machine exp) > > "Evaluate EXP, a gexp, on MACHINE. Ensure that all the elements EXP refers to > are built and deployed to MACHINE beforehand." > (let* ((environment (machine-environment machine)) > (remote-eval (environment-remote-eval environment))) > (remote-eval machine exp))) > > (define (deploy-machine machine) > "Monadic procedure transferring the new system's OS closure to the remote > MACHINE, activating it on MACHINE and switching MACHINE to the new generation." > (let* ((environment (machine-environment machine)) > (deploy-machine (environment-deploy-machine environment))) > (deploy-machine machine))) > #+END_SRC > > Thoughts? Whoops, wrote the above paragraph before getting here. :] > Feels like better polymorphism than this is desirable, but I'm not > sure I have advice on how to do it right now. Probably services > provide the right form of inspiration. Are you talking about service extensions? I'm starting to see your point regarding polymorphism, since SSH would be the backbone for a lot of these environment types. Does anyone else have suggestions for implementing that sort of polymorphism? > Why not just import remote-eval in the define-module? To avoid a Guile warning about shadowing symbols. This goes away with the renaming of 'remote-eval' to 'machine-remote-eval', though. > It's so cool that this works across machines. Dang! :) > Yeah that sounds like it would be bad. But I'm curious... could you > explain the specific bug it's preventing here? I'd like to know. You've found something I've overlooked. There wasn't a bug, it's something I put in since 'guix system' does it when loading the activation script. But after looking through the 'guix system' code, I noticed that there's a comment reading "[t]his is necessary to ensure that 'upgrade-shepherd-services' gets to see the right modules when it computes derivations with 'gexp->derivation'." Yet, I'm invoking my version of 'upgrade-shepherd-services' outside of that excursion. I haven't had any issues with it so far, but then again, I haven't done much with trying to register new services with 'guix deploy'. I think it's worth fixing. > Just to see if I understand it... this is kind of so we can identify > and "garbage collect" services that don't apply to the new system? Yep. > > I'm a bit unsure from the above code... I'm guessing one of two things > is happening: > > - Either it's starting services that haven't been started yet, but > leaving alone services that are running but which aren't "new" > - Or it's restarting services that are currently running > > Which is it? And mind adding a comment explaining it? The former. I've intentionally avoided restarting services since 'guix system' warns that "many essential services cannot be meaningfully restarted." (which is why 'guix system reconfigure' spits out "To complete the upgrade, run 'herd restart SERVICE' to stop, upgrade, and restart each service that was not automatically restarted." (which AFAIK is always none of them)). > By the way, is there anything about the dependency order in which > services might need to be restarted to be considered? I'm honestly not > sure. I'm not sure either. Would any Shepherd hackers out there care to chime in? > So I guess this is derivative of some of the stuff in > guix/scripts/system.scm. That makes me feel like it would be nice if > it could be generalized, but I haven't spent enough time with the code > to figure out if it really can be. > > I don't want to block the merge on that desire, though if you agree > that generalization between those sections of code is desirable, maybe > add a comment to that effect? You're right, and I agree 100%. I think I can commit to refactoring out the common code, albeit after this patch series is merged -- that's something that deserves its own commit, and it would probably take me some time to get right anyway. > This code also looks very similar, but I compared them and I can see > that they aren't quite the same, at least in that you had to install > the dynamic-wind. But I get the feeling that it still might be > possible to generalize them, so could you leave a comment here as > well? Unless you think it's really not possible to generalize them to > share code for reasons I'm not yet aware of. I think it can be generalized. In fact, 'guix system' does with 'save-load-path-excursion' and 'save-environment-excursion'. If I can't generalize the code from '(gnu machine)' and 'guix system', I'll at least see about exporting those excursions from 'guix system' (they're unexported at the moment). > Seems good from a quick scan, but I'll admit I didn't read these as > carefully as I did the rest of the code. I'm not sure it's really worth reading right now, this is the "me way" of testing everything and I suspect some significant changes are going to be made. > This patch looks great overall! I know it was a lot of work to figure > out, and I'm impressed by how quickly you came up to speed on it. Thank you :) [-- Attachment #2: signature.asc --] [-- Type: application/pgp-signature, Size: 832 bytes --] ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 2/5] gnu: Add machine type for deployment specifications. 2019-06-30 0:30 ` Jakob L. Kreuze @ 2019-06-30 4:58 ` Carlo Zancanaro 2019-06-30 12:34 ` Christopher Lemmer Webber 2019-06-30 12:28 ` Christopher Lemmer Webber 1 sibling, 1 reply; 84+ messages in thread From: Carlo Zancanaro @ 2019-06-30 4:58 UTC (permalink / raw) To: 36404 Hey Jakob/Chris, I can't comment on much of the deploy code, but I can help out with some stuff about the Shepherd. On Sun, Jun 30 2019, Jakob L. Kreuze wrote: >> I'm a bit unsure from the above code... I'm guessing one of two >> things >> is happening: >> >> - Either it's starting services that haven't been started yet, >> but >> leaving alone services that are running but which aren't >> "new" >> - Or it's restarting services that are currently running >> >> Which is it? And mind adding a comment explaining it? > > The former. I've intentionally avoided restarting services since > 'guix > system' warns that "many essential services cannot be > meaningfully > restarted." (which is why 'guix system reconfigure' spits out > "To > complete the upgrade, run 'herd restart SERVICE' to stop, > upgrade, and > restart each service that was not automatically restarted." > (which AFAIK > is always none of them)). There was discussion earlier this year around restarting services that are already running during a reconfigure[1]. I wonder if this problem is more worth solving if we're deploying to remote systems. I have a few patches in that issue to implement service restarting, but I didn't follow them up enough to get them into Guix. [1]: https://issues.guix.info/issue/33508 >> By the way, is there anything about the dependency order in >> which >> services might need to be restarted to be considered? I'm >> honestly not >> sure. > > I'm not sure either. Would any Shepherd hackers out there care > to chime > in? The Shepherd will start any necessary dependencies in an appropriate order. Carlo ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 2/5] gnu: Add machine type for deployment specifications. 2019-06-30 4:58 ` Carlo Zancanaro @ 2019-06-30 12:34 ` Christopher Lemmer Webber 2019-07-01 23:51 ` Jakob L. Kreuze 0 siblings, 1 reply; 84+ messages in thread From: Christopher Lemmer Webber @ 2019-06-30 12:34 UTC (permalink / raw) To: Carlo Zancanaro; +Cc: 36404 Carlo Zancanaro writes: > Hey Jakob/Chris, > > I can't comment on much of the deploy code, but I can help out with > some stuff about the Shepherd. > > On Sun, Jun 30 2019, Jakob L. Kreuze wrote: >>> I'm a bit unsure from the above code... I'm guessing one of two >>> things >>> is happening: >>> >>> - Either it's starting services that haven't been started yet, >>> but >>> leaving alone services that are running but which aren't >>> "new" >>> - Or it's restarting services that are currently running >>> >>> Which is it? And mind adding a comment explaining it? >> >> The former. I've intentionally avoided restarting services since >> 'guix >> system' warns that "many essential services cannot be meaningfully >> restarted." (which is why 'guix system reconfigure' spits out "To >> complete the upgrade, run 'herd restart SERVICE' to stop, upgrade, >> and >> restart each service that was not automatically restarted." (which >> AFAIK >> is always none of them)). > > There was discussion earlier this year around restarting services that > are already running during a reconfigure[1]. I wonder if this problem > is more worth solving if we're deploying to remote systems. I have a > few patches in that issue to implement service restarting, but I > didn't follow them up enough to get them into Guix. > > [1]: https://issues.guix.info/issue/33508 Wow! This seems highly desireable, especially if, as you pointed out in the issue, an update to nginx is pushed across the wire with a security update... in that case, we'd want to restart that, too. Jakob, do you mind checking out the issue above? I think it shouldn't block merging these patches but perhaps we should file an issue saying that when the shepherd issue is merged, changes should be made to guix deploy as well. What do you think? >>> By the way, is there anything about the dependency order in which >>> services might need to be restarted to be considered? I'm honestly >>> not >>> sure. >> >> I'm not sure either. Would any Shepherd hackers out there care to >> chime >> in? > > The Shepherd will start any necessary dependencies in an appropriate > order. > > Carlo Ok, good to know! ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 2/5] gnu: Add machine type for deployment specifications. 2019-06-30 12:34 ` Christopher Lemmer Webber @ 2019-07-01 23:51 ` Jakob L. Kreuze 2019-07-04 12:48 ` Christopher Lemmer Webber 0 siblings, 1 reply; 84+ messages in thread From: Jakob L. Kreuze @ 2019-07-01 23:51 UTC (permalink / raw) To: Christopher Lemmer Webber; +Cc: 36404 [-- Attachment #1: Type: text/plain, Size: 423 bytes --] Christopher Lemmer Webber <cwebber@dustycloud.org> writes: > Jakob, do you mind checking out the issue above? I think it shouldn't > block merging these patches but perhaps we should file an issue saying > that when the shepherd issue is merged, changes should be made to guix > deploy as well. What do you think? I took a peek and added a comment about it to machine.scm, are you suggesting that we track it on debbugs? [-- Attachment #2: signature.asc --] [-- Type: application/pgp-signature, Size: 832 bytes --] ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 2/5] gnu: Add machine type for deployment specifications. 2019-07-01 23:51 ` Jakob L. Kreuze @ 2019-07-04 12:48 ` Christopher Lemmer Webber 2019-07-04 16:05 ` Jakob L. Kreuze 0 siblings, 1 reply; 84+ messages in thread From: Christopher Lemmer Webber @ 2019-07-04 12:48 UTC (permalink / raw) To: Jakob L. Kreuze; +Cc: 36404 Jakob L. Kreuze writes: > Christopher Lemmer Webber <cwebber@dustycloud.org> writes: > >> Jakob, do you mind checking out the issue above? I think it shouldn't >> block merging these patches but perhaps we should file an issue saying >> that when the shepherd issue is merged, changes should be made to guix >> deploy as well. What do you think? > > I took a peek and added a comment about it to machine.scm, are you > suggesting that we track it on debbugs? Yeha, it will help us be less likely to forget it as well as having a nicer place to track it... I think? :) ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 2/5] gnu: Add machine type for deployment specifications. 2019-07-04 12:48 ` Christopher Lemmer Webber @ 2019-07-04 16:05 ` Jakob L. Kreuze 0 siblings, 0 replies; 84+ messages in thread From: Jakob L. Kreuze @ 2019-07-04 16:05 UTC (permalink / raw) To: Christopher Lemmer Webber; +Cc: 36404 [-- Attachment #1: Type: text/plain, Size: 325 bytes --] Christopher Lemmer Webber <cwebber@dustycloud.org> writes: > Yeha, it will help us be less likely to forget it as well as having a > nicer place to track it... I think? :) Sounds good to me. I'll file it as soon as this patch gets merged upstream, since we have Carlo's ticket for tracking it in 'guix system reconfigure'. [-- Attachment #2: signature.asc --] [-- Type: application/pgp-signature, Size: 832 bytes --] ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 2/5] gnu: Add machine type for deployment specifications. 2019-06-30 0:30 ` Jakob L. Kreuze 2019-06-30 4:58 ` Carlo Zancanaro @ 2019-06-30 12:28 ` Christopher Lemmer Webber 2019-07-02 0:03 ` Jakob L. Kreuze 1 sibling, 1 reply; 84+ messages in thread From: Christopher Lemmer Webber @ 2019-06-30 12:28 UTC (permalink / raw) To: Jakob L. Kreuze; +Cc: 36404 Jakob L. Kreuze writes: > Christopher Lemmer Webber <cwebber@dustycloud.org> writes: > >> Feels like better polymorphism than this is desirable, but I'm not >> sure I have advice on how to do it right now. Probably services >> provide the right form of inspiration. > > Are you talking about service extensions? I'm starting to see your point > regarding polymorphism, since SSH would be the backbone for a lot of > these environment types. Does anyone else have suggestions for > implementing that sort of polymorphism? Right now it looks like you're hard-coding dispatch into the procedure by doing a case analysis of what type it is, but this doesn't allow us to extend it. Here I'd look at how service-type works. Check out gnu/services.scm and then some examples of how services are defined in say, gnu/services/admin.scm or something (eg rotlog-service-type). I'm not saying structure it in exactly this way, but that seems to be the right general pattern to do extensibility in the guix'y way: - Have a common outer type (eg <service-type>) which actually sets up the structure of this service type - Then have the actual records that are specific to the service type represented as the service-value. Section 8.16.2 "Serivce Types and Services" and 6.16.3 "Service Reference" for details. Note that I wish there was a way to generalize the ideas behind this pattern rather than have it be reinvented for everything that needs them. This is part of why David and I turned to GOOPS in the initial prototype implementation; it's a lot of work figuring out how to set up extensibility in this way, at least for me. You might want to write a quick GOOPS version to understand what all the parameters are that are needed, then convert it to the services way of doing a general structure that wraps a specific structure. I suspect you won't need as much composability as services currently need, so the implementation of whatever this extensibility is is probably not as complicated as it is for services. As for how to share the ssh code, maybe just having the building-block procedures is good enough? Since all we support, so far, is this kind of ssh'ing, I don't want this to block the patch though. It could be that we file this as a bug and add a TODO above the code for the moment saying "we know this isn't right/ideal". However, there is some risk that this could result in people writing out machine configurations that later break... I dunno. Thoughts? >> Why not just import remote-eval in the define-module? > > To avoid a Guile warning about shadowing symbols. This goes away with > the renaming of 'remote-eval' to 'machine-remote-eval', though. Heh :) >> Yeah that sounds like it would be bad. But I'm curious... could you >> explain the specific bug it's preventing here? I'd like to know. > > You've found something I've overlooked. There wasn't a bug, it's > something I put in since 'guix system' does it when loading the > activation script. But after looking through the 'guix system' code, I > noticed that there's a comment reading "[t]his is necessary to ensure > that 'upgrade-shepherd-services' gets to see the right modules when it > computes derivations with 'gexp->derivation'." Yet, I'm invoking my > version of 'upgrade-shepherd-services' outside of that excursion. I > haven't had any issues with it so far, but then again, I haven't done > much with trying to register new services with 'guix deploy'. I think > it's worth fixing. Cool. Yay reviews! If you remove it, please leave a comment noting the difference between this and "guix system" and why you thought it was safe to remove. If it turns out to not be the case, there's a breadcrumb there to figure out how to add it back. >> Just to see if I understand it... this is kind of so we can identify >> and "garbage collect" services that don't apply to the new system? > > Yep. > >> >> I'm a bit unsure from the above code... I'm guessing one of two things >> is happening: >> >> - Either it's starting services that haven't been started yet, but >> leaving alone services that are running but which aren't "new" >> - Or it's restarting services that are currently running >> >> Which is it? And mind adding a comment explaining it? > > The former. I've intentionally avoided restarting services since 'guix > system' warns that "many essential services cannot be meaningfully > restarted." (which is why 'guix system reconfigure' spits out "To > complete the upgrade, run 'herd restart SERVICE' to stop, upgrade, and > restart each service that was not automatically restarted." (which AFAIK > is always none of them)). Aha. Thank you for explaining! This make ssense. >> By the way, is there anything about the dependency order in which >> services might need to be restarted to be considered? I'm honestly not >> sure. > > I'm not sure either. Would any Shepherd hackers out there care to chime > in? I guess if you aren't restarting the services, it's no longer a big deal. >> So I guess this is derivative of some of the stuff in >> guix/scripts/system.scm. That makes me feel like it would be nice if >> it could be generalized, but I haven't spent enough time with the code >> to figure out if it really can be. >> >> I don't want to block the merge on that desire, though if you agree >> that generalization between those sections of code is desirable, maybe >> add a comment to that effect? > > You're right, and I agree 100%. I think I can commit to refactoring out > the common code, albeit after this patch series is merged -- that's > something that deserves its own commit, and it would probably take me > some time to get right anyway. Great! >> This code also looks very similar, but I compared them and I can see >> that they aren't quite the same, at least in that you had to install >> the dynamic-wind. But I get the feeling that it still might be >> possible to generalize them, so could you leave a comment here as >> well? Unless you think it's really not possible to generalize them to >> share code for reasons I'm not yet aware of. > > I think it can be generalized. In fact, 'guix system' does with > 'save-load-path-excursion' and 'save-environment-excursion'. If I can't > generalize the code from '(gnu machine)' and 'guix system', I'll at > least see about exporting those excursions from 'guix system' (they're > unexported at the moment). Okay, cool. >> Seems good from a quick scan, but I'll admit I didn't read these as >> carefully as I did the rest of the code. > > I'm not sure it's really worth reading right now, this is the "me way" > of testing everything and I suspect some significant changes are going > to be made. Kk. >> This patch looks great overall! I know it was a lot of work to figure >> out, and I'm impressed by how quickly you came up to speed on it. > > Thank you :) Thank *you*! ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 2/5] gnu: Add machine type for deployment specifications. 2019-06-30 12:28 ` Christopher Lemmer Webber @ 2019-07-02 0:03 ` Jakob L. Kreuze 0 siblings, 0 replies; 84+ messages in thread From: Jakob L. Kreuze @ 2019-07-02 0:03 UTC (permalink / raw) To: Christopher Lemmer Webber; +Cc: 36404 [-- Attachment #1: Type: text/plain, Size: 2618 bytes --] Christopher Lemmer Webber <cwebber@dustycloud.org> writes: > Right now it looks like you're hard-coding dispatch into the procedure > by doing a case analysis of what type it is, but this doesn't allow us > to extend it. > > Here I'd look at how service-type works. Check out gnu/services.scm > and then some examples of how services are defined in say, > gnu/services/admin.scm or something (eg rotlog-service-type). I'm not > saying structure it in exactly this way, but that seems to be the > right general pattern to do extensibility in the guix'y way: > > - Have a common outer type (eg <service-type>) which actually sets up > the structure of this service type > - Then have the actual records that are specific to the service type > represented as the service-value. > > Section 8.16.2 "Serivce Types and Services" and 6.16.3 "Service > Reference" for details. > > Note that I wish there was a way to generalize the ideas behind this > pattern rather than have it be reinvented for everything that needs > them. This is part of why David and I turned to GOOPS in the initial > prototype implementation; it's a lot of work figuring out how to set > up extensibility in this way, at least for me. You might want to write > a quick GOOPS version to understand what all the parameters are that > are needed, then convert it to the services way of doing a general > structure that wraps a specific structure. > > I suspect you won't need as much composability as services currently > need, so the implementation of whatever this extensibility is is > probably not as complicated as it is for services. > > As for how to share the ssh code, maybe just having the building-block > procedures is good enough? > > Since all we support, so far, is this kind of ssh'ing, I don't want > this to block the patch though. It could be that we file this as a bug > and add a TODO above the code for the moment saying "we know this > isn't right/ideal". However, there is some risk that this could result > in people writing out machine configurations that later break... I > dunno. > > Thoughts? Ah, so you mean having the configuration as part of the environment type rather than the machine type? I think that does make more sense... If that is what you meant, let me know and I'll send another patch implementing the change tomorrow. It should be an easy fix. > If you remove it, please leave a comment noting the difference between > this and "guix system" and why you thought it was safe to remove. If it > turns out to not be the case, there's a breadcrumb there to figure out > how to add it back. Added :] [-- Attachment #2: signature.asc --] [-- Type: application/pgp-signature, Size: 832 bytes --] ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 1/5] ssh: Add 'identity' keyword to 'open-ssh-session'. 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-29 14:42 ` Christopher Lemmer Webber 2019-06-29 23:45 ` Jakob L. Kreuze 1 sibling, 1 reply; 84+ messages in thread From: Christopher Lemmer Webber @ 2019-06-29 14:42 UTC (permalink / raw) To: 36404 Jakob L. Kreuze writes: > * guix/ssh.scm (open-ssh-session): Add 'identity' keyword argument. > --- > guix/ssh.scm | 3 ++- > 1 file changed, 2 insertions(+), 1 deletion(-) > > diff --git a/guix/ssh.scm b/guix/ssh.scm > index 9b9baf54ea..a2387564a4 100644 > --- a/guix/ssh.scm > +++ b/guix/ssh.scm > @@ -57,12 +57,13 @@ > (define %compression > "zlib@openssh.com,zlib") > > -(define* (open-ssh-session host #:key user port > +(define* (open-ssh-session host #:key user port identity > (compression %compression)) > "Open an SSH session for HOST and return it. When USER and PORT are #f, use > default values or whatever '~/.ssh/config' specifies; otherwise use them. > Throw an error on failure." Looks good, but could you add to the docstring here explaining the new identity keyword? > (let ((session (make-session #:user user > + #:identity identity > #:host host > #:port port > #:timeout 10 ;seconds ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 1/5] ssh: Add 'identity' keyword to 'open-ssh-session'. 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 0 siblings, 0 replies; 84+ messages in thread From: Jakob L. Kreuze @ 2019-06-29 23:45 UTC (permalink / raw) To: Christopher Lemmer Webber; +Cc: 36404 [-- Attachment #1: Type: text/plain, Size: 169 bytes --] Christopher Lemmer Webber <cwebber@dustycloud.org> writes: > Looks good, but could you add to the docstring here explaining the new > identity keyword? Added, thanks! [-- Attachment #2: signature.asc --] [-- Type: application/pgp-signature, Size: 832 bytes --] ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 0/6] Add 'guix deploy'. 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 20:05 ` [bug#36404] [PATCH 0/6] Add 'guix deploy' Thompson, David @ 2019-06-29 14:37 ` Christopher Lemmer Webber 2019-06-29 23:42 ` Jakob L. Kreuze ` (2 more replies) 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 4 siblings, 3 replies; 84+ messages in thread From: Christopher Lemmer Webber @ 2019-06-29 14:37 UTC (permalink / raw) To: 36404 Jakob L. Kreuze writes: > Hello, Guix! > > This patch provides the basis for 'guix deploy', implementing what I've > referred to as the "simple case" in my progress reports: in-place > updates to machines (physical or virtual) whose name and IP address we > know well. Do note that these commits depend on Ludovic's implementation > of 'remote-eval'.[1] Horray! > #+BEGIN_SRC scheme > ;; [...] > (list (machine > (system %system) > (environment 'managed-host) > (configuration (machine-ssh-configuration > (host-name "localhost") > (identity "./id_rsa") > (port 2222))))) > #+END_SRC scheme > > The 'environment' field is where we declare how machines should be > provisioned. In this case, the only type of provisioning that's been > implemented is 'managed-host' -- the "simple case" of in-place updates > to a machine that's already running GuixSD. The parameters for > provisioning are given in the form of an environment-specific > configuration type. In the example, this is 'machine-ssh-configuration', > which describes how 'guix deploy' should make an SSH connection to the > machine. I'm sure you can imagine something along the lines of a > 'machine-digitalocean-configuration', describing some parameters for a > droplet. In the future I think it would be good to make this extensible as well. Dispatching on a symbol means that Guix must itself provide a fixed set of possible environment types. If we made this an extensible structure, akin to services or something, we could allow for more flexibility in the future. Thoughts for the future, but not a blocker on this patch. > There are two things in this patch series that I'd like comments on in > particular. > > First, I still haven't figured out the whole testing situation. The > tests, as of now, spin up a virtual machine, create a machine instance, > deploy that to the virtual machine, and then make assertions about > changes made to the system. These tests were originally in the system > test suite as they deal with virtual machines, but I've since moved it > into the normal Guix test suite because of how much needs to be done on > the host side -- I spent an absurd amount of time trying to fit a call > to 'deploy-machine' into a derivation that could be run by the system > test suite, but I just wasn't able to make it work. I'm hoping someone > will have thoughts about how we can test 'guix deploy'. Should we have > them disabled by default? Is there some way to implement them in the a > system test suite that I've overlooked? Should the tests be included at > all? Ludo, do you have comments? I suspect this is up your area of expertise. > I look forward to your comments. Yes, now for me to look at the actual patches :) ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 0/6] Add 'guix deploy'. 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 2 siblings, 1 reply; 84+ messages in thread From: Jakob L. Kreuze @ 2019-06-29 23:42 UTC (permalink / raw) To: Christopher Lemmer Webber; +Cc: 36404 [-- Attachment #1: Type: text/plain, Size: 784 bytes --] Hi, Chris! Christopher Lemmer Webber <cwebber@dustycloud.org> writes: > In the future I think it would be good to make this extensible as > well. Dispatching on a symbol means that Guix must itself provide a > fixed set of possible environment types. If we made this an extensible > structure, akin to services or something, we could allow for more > flexibility in the future. Thoughts for the future, but not a blocker > on this patch. +1. Initially, I thought the service types _were_ symbols, but I see now that they're actually procedures. Thanks for pointing that out. I'll see about implementing environment types similarly in my revised patch set, since I think that's a change that we'd want to make before any other environment types come into existence. Regards, Jakob [-- Attachment #2: signature.asc --] [-- Type: application/pgp-signature, Size: 832 bytes --] ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 0/6] Add 'guix deploy'. 2019-06-29 23:42 ` Jakob L. Kreuze @ 2019-07-01 12:50 ` Ludovic Courtès 0 siblings, 0 replies; 84+ messages in thread From: Ludovic Courtès @ 2019-07-01 12:50 UTC (permalink / raw) To: Jakob L. Kreuze; +Cc: 36404 zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) skribis: > Christopher Lemmer Webber <cwebber@dustycloud.org> writes: > >> In the future I think it would be good to make this extensible as >> well. Dispatching on a symbol means that Guix must itself provide a >> fixed set of possible environment types. If we made this an extensible >> structure, akin to services or something, we could allow for more >> flexibility in the future. Thoughts for the future, but not a blocker >> on this patch. > > +1. Initially, I thought the service types _were_ symbols, but I see now > that they're actually procedures. Thanks for pointing that out. I'll see > about implementing environment types similarly in my revised patch set, > since I think that's a change that we'd want to make before any other > environment types come into existence. It’s a pattern similar to that of <build-system> for packages. I think it should provide the flexibility and extensibility we need. Ludo’. ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 0/6] Add 'guix deploy'. 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 10:09 ` Ricardo Wurmus 2019-07-01 12:53 ` Ludovic Courtès 2 siblings, 0 replies; 84+ messages in thread From: Ricardo Wurmus @ 2019-07-01 10:09 UTC (permalink / raw) To: Christopher Lemmer Webber; +Cc: 36404 Christopher Lemmer Webber <cwebber@dustycloud.org> writes: >> First, I still haven't figured out the whole testing situation. The >> tests, as of now, spin up a virtual machine, create a machine instance, >> deploy that to the virtual machine, and then make assertions about >> changes made to the system. These tests were originally in the system >> test suite as they deal with virtual machines, but I've since moved it >> into the normal Guix test suite because of how much needs to be done on >> the host side -- I spent an absurd amount of time trying to fit a call >> to 'deploy-machine' into a derivation that could be run by the system >> test suite, but I just wasn't able to make it work. I'm hoping someone >> will have thoughts about how we can test 'guix deploy'. Should we have >> them disabled by default? Is there some way to implement them in the a >> system test suite that I've overlooked? Should the tests be included at >> all? > > Ludo, do you have comments? I suspect this is up your area of expertise. Building and running virtual machines as part of the tests seems expensive. Would it be feasible to mock the remote interactions? -- Ricardo ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 0/6] Add 'guix deploy'. 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 10:09 ` Ricardo Wurmus @ 2019-07-01 12:53 ` Ludovic Courtès 2019-07-02 0:10 ` Jakob L. Kreuze 2019-07-02 0:14 ` [bug#36404] [PATCH 0/4] Add 'guix deploy' Jakob L. Kreuze 2 siblings, 2 replies; 84+ messages in thread From: Ludovic Courtès @ 2019-07-01 12:53 UTC (permalink / raw) To: Christopher Lemmer Webber; +Cc: 36404 Hi! Christopher Lemmer Webber <cwebber@dustycloud.org> skribis: > Jakob L. Kreuze writes: [...] >> There are two things in this patch series that I'd like comments on in >> particular. >> >> First, I still haven't figured out the whole testing situation. The >> tests, as of now, spin up a virtual machine, create a machine instance, >> deploy that to the virtual machine, and then make assertions about >> changes made to the system. These tests were originally in the system >> test suite as they deal with virtual machines, but I've since moved it >> into the normal Guix test suite because of how much needs to be done on >> the host side -- I spent an absurd amount of time trying to fit a call >> to 'deploy-machine' into a derivation that could be run by the system >> test suite, but I just wasn't able to make it work. I'm hoping someone >> will have thoughts about how we can test 'guix deploy'. Should we have >> them disabled by default? Is there some way to implement them in the a >> system test suite that I've overlooked? Should the tests be included at >> all? > > Ludo, do you have comments? I suspect this is up your area of expertise. As Ricardo wrote, I think that’s too much work to do in “make check”. Plus this would only run when a “host store” is available, as we can’t reasonably build QEMU and everything in $builddir/test-tmp. So I feel that the system test suite is a better fit, but I don’t fully understand the limitations you hit, Jakob. Do you still have a draft of a system test that you wrote and/or notes about what went wrong? Ludo’. ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 0/6] Add 'guix deploy'. 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-02 0:14 ` [bug#36404] [PATCH 0/4] Add 'guix deploy' Jakob L. Kreuze 1 sibling, 1 reply; 84+ messages in thread From: Jakob L. Kreuze @ 2019-07-02 0:10 UTC (permalink / raw) To: Ludovic Courtès; +Cc: 36404 [-- Attachment #1: Type: text/plain, Size: 1376 bytes --] Hi, Ludovic + Ricardo! Ricardo Wurmus <rekado@elephly.net> writes: > Building and running virtual machines as part of the tests > seems expensive. Would it be feasible to mock the remote > interactions? I agree 100%. I've decoupled it from my patch series for now. We can always add it back later when it's implemented in a less expensive way. As for mocking -- I do like that idea, but that would only really be testing that calls to 'deploy-machine' et al. don't fail rather than ensuring that the implementation of 'guix deploy' does what it's supposed to do. The current tests make assertions about changes to the virtual machine. Ludovic Courtès <ludo@gnu.org> writes: > As Ricardo wrote, I think that’s too much work to do in “make check”. > Plus this would only run when a “host store” is available, as we can’t > reasonably build QEMU and everything in $builddir/test-tmp. > > So I feel that the system test suite is a better fit, but I don’t > fully understand the limitations you hit, Jakob. > > Do you still have a draft of a system test that you wrote and/or notes > about what went wrong? Yep, I have an unsquashed commit history on my personal branch with all renditions of the test suite. I can pull it out tomorrow and write a detailed report on the issues I ran into. Thanks for both of your comments! [-- Attachment #2: signature.asc --] [-- Type: application/pgp-signature, Size: 832 bytes --] ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 0/6] Add 'guix deploy'. 2019-07-02 0:10 ` Jakob L. Kreuze @ 2019-07-02 22:14 ` Jakob L. Kreuze 2019-07-04 16:48 ` Jakob L. Kreuze 0 siblings, 1 reply; 84+ messages in thread From: Jakob L. Kreuze @ 2019-07-02 22:14 UTC (permalink / raw) To: Ludovic Courtès; +Cc: 36404 [-- Attachment #1: Type: text/plain, Size: 6956 bytes --] Hi Ludovic, zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) writes: > Yep, I have an unsquashed commit history on my personal branch with > all renditions of the test suite. I can pull it out tomorrow and write > a detailed report on the issues I ran into. So we begin as I did about a month ago with a very naïve test, ensuring that we can create a 'machine' object. This isn't particularly hard to pull off in the system test suite. #+BEGIN_SRC scheme (define (run-sshable-machine-test) (define os (marionette-operating-system (simple-operating-system (service dhcp-client-service-type) (service openssh-service-type (openssh-configuration (permit-root-login #t) (allow-empty-passwords? #t)))) #:imported-modules '((gnu services herd) (guix combinators)))) (define vm (virtual-machine (operating-system os) (port-forwardings '((2222 . 22))))) (define test (with-extensions (list guile-bytestructures guile-gcrypt guile-git guile-ssh guile-sqlite3 guix) (with-imported-modules '((gnu build marionette) (gnu) (gnu machine) (gnu machine ssh) (guix remote)) #~(begin (use-modules (gnu build marionette) (gnu) (gnu machine) (gnu machine ssh) (srfi srfi-64)) (use-service-modules networking ssh) (define %system (operating-system (host-name "gnu-deployed") (timezone "Etc/UTC") (bootloader (bootloader-configuration (bootloader grub-bootloader) (target "/dev/vda") (terminal-outputs '(console)))) (file-systems (cons (file-system (mount-point "/") (device "/dev/vda1") (type "ext4")) %base-file-systems)) (services (append (list (service dhcp-client-service-type) (service openssh-service-type (openssh-configuration (permit-root-login #t) (allow-empty-passwords? #t)))) %base-services)))) (define %machine (machine (system %system) (environment managed-host-environment-type) (configuration (machine-ssh-configuration (host-name "localhost") (port 2222))))) (define marionette (make-marionette (list #$vm))) (mkdir #$output) (chdir #$output) (test-begin "remote-eval") (test-assert "machine instance was created" %machine) (test-end) (exit (= (test-runner-fail-count (test-runner-current)) 0)))))) (gexp->derivation "sshable-machine" test)) (define %test-sshable-machine (system-test (name "sshable-machine") (description "Create a machine object") (value (run-sshable-machine-test)))) #+END_SRC For onlookers unfamiliar with the system test suite, this is mostly boilerplate. The important code begins at 'define %system' and ends at 'test-end'. Wonderful! We've ensured that we can import '(gnu machine)', and that we can create instances of 'machine'. Where to now? How about testing 'remote-eval'? (This snippet requires more changes to the surrounding code to work. If you need a reproducible version, let me know.) #+BEGIN_SRC scheme (test-assert "can invoke machine-remote-eval" (with-store store (run-with-store store (machine-remote-eval %machine #~#t)))) #+END_SRC Alas, this doesn't work in the context of a derivation. #+BEGIN_SRC scheme (srfi-34 #<condition &store-connection-error [file: "/var/guix/daemon-socket/socket" errno: 2] 101e0c0>) #+END_SRC This is around when I began to pester you on IRC with questions that I realize are kind of silly now. In general, system tests can't use the store. The only workaround that I'm aware of is 'gnu/tests/install.scm', which makes use of the store monad to perform store operations before running the test. For example: #+BEGIN_SRC scheme (define %test-iso-image-installer (system-test (name "iso-image-installer") (description "") (value (mlet* %store-monad ((image (run-install %minimal-os-on-vda %minimal-os-on-vda-source #:script %simple-installation-script-for-/dev/vda #:installation-disk-image-file-system-type "iso9660")) (command (qemu-command/writable-image image))) (run-basic-test %minimal-os-on-vda command name))))) #+END_SRC This is a bit less complicated than system deployment, since the tests only need the store to build the virtual machine image. Deployment to a machine requires that the machine is /up/, but if you look at the initial, naïve test, you can see that the virtual machine isn't started until the test derivation runs -- which is after everything in the store monad is run. c6e01898[1] has a version that starts the virtual machine while the store monad is running so it can deploy to it. This is an absolute mess, as seen in 'call-with-marionette'. Also, the use of 'dynamic-wind' in that rendition causes the SSH session to close during deployment, which is why that test fails. (I didn't figure that out until around the time I began reimplementing the tests in the normal test suite.) In theory, _I could fix that issue and implement the tests this way_. Another possibility would be to spawn two virtual machines and have one deploy to the other. This is implemented in 358f1287[2], which I believe I would also be able to adapt now that I know I need to create writable disk images for the virtual machines. Before I go ahead with either, though, I'd like to know if either is the "right way". Or if there's something better than what I'm suggesting. Regards, Jakob [1]: https://git.sr.ht/~jakob/guix/tree/c6e01898dc774eef318c042595d6490e50e19486/gnu/tests/machine.scm [2]: https://git.sr.ht/~jakob/guix/tree/358f12871326085c3e108181887ea36a8577de73/gnu/tests/machine.scm [-- Attachment #2: signature.asc --] [-- Type: application/pgp-signature, Size: 832 bytes --] ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 0/6] Add 'guix deploy'. 2019-07-02 22:14 ` Jakob L. Kreuze @ 2019-07-04 16:48 ` Jakob L. Kreuze 2019-07-05 8:00 ` Ludovic Courtès 0 siblings, 1 reply; 84+ messages in thread From: Jakob L. Kreuze @ 2019-07-04 16:48 UTC (permalink / raw) To: Ludovic Courtès; +Cc: 36404 [-- Attachment #1: Type: text/plain, Size: 636 bytes --] Hi Ludovic + Ricardo, Something hit me today. There aren't any tests for 'guix system reconfigure'. There are for 'guix system init' in 'gnu/tests/install.scm', but not for 'guix system reconfigure', which makes me think that I'm going about testing this the wrong way. I feel I should begin by isolate the behavior that's common between 'guix system reconfigure' and 'guix deploy' as you suggested, and then writing tests for that common code in the system test suite. Then, as Ricardo suggested, mocking can be used for the parts that are specific only to 'guix deploy'. I will look into this today and report back. Regards, Jakob [-- Attachment #2: signature.asc --] [-- Type: application/pgp-signature, Size: 832 bytes --] ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 0/6] Add 'guix deploy'. 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 0 siblings, 1 reply; 84+ messages in thread From: Ludovic Courtès @ 2019-07-05 8:00 UTC (permalink / raw) To: Jakob L. Kreuze; +Cc: 36404 Hi Jakob, zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) skribis: > Something hit me today. There aren't any tests for 'guix system > reconfigure'. There are for 'guix system init' in > 'gnu/tests/install.scm', but not for 'guix system reconfigure', which > makes me think that I'm going about testing this the wrong way. I feel I > should begin by isolate the behavior that's common between 'guix system > reconfigure' and 'guix deploy' as you suggested, and then writing tests > for that common code in the system test suite. That would be great, especially factorizing these bits. Note that writing tests could be tricky because it’s about testing the effect of these reconfigure actions. At any rate, let us know how it goes! > Then, as Ricardo suggested, mocking can be used for the parts that are > specific only to 'guix deploy'. Sounds good. Thank you! Ludo’. ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 0/3] Refactor out common behavior for system reconfiguration. 2019-07-05 8:00 ` Ludovic Courtès @ 2019-07-05 23:45 ` Jakob L. Kreuze 2019-07-05 23:46 ` [bug#36404] [PATCH 1/3] guix system: Add 'reconfigure' module Jakob L. Kreuze ` (2 more replies) 0 siblings, 3 replies; 84+ messages in thread From: Jakob L. Kreuze @ 2019-07-05 23:45 UTC (permalink / raw) To: Ludovic Courtès; +Cc: 36404 [-- Attachment #1: Type: text/plain, Size: 1454 bytes --] Ludovic Courtès <ludo@gnu.org> writes: > Note that writing tests could be tricky because it’s about testing the > effect of these reconfigure actions. At any rate, let us know how it > goes! This is a _very_ preliminary patch series. I'm not nearly done with it yet; the procedures in guix/scripts/system.scm that I've replaced have some handling for i.e. installing the bootloader configuration without running the installer script, which my reimplementations don't yet support. I'm sending this tonight to make sure I'm on the right track: is this sort of what you meant by extracting the common behavior into scripts? Also, I didn't include any tests as part of this series, but implementing reconfiguration like this does, indeed, make testing for 'guix deploy' much, much easier. And we'll get some tests for the behavior of 'guix system reconfigure' out of it, too! Jakob L. Kreuze (3): guix system: Add 'reconfigure' module. machine: Reimplement 'managed-host-environment-type' deployment. guix system: Reimplement 'reconfigure'. Makefile.am | 1 + gnu/machine/ssh.scm | 235 ++++++++-------------------- guix/scripts/system.scm | 162 ++++++------------- guix/scripts/system/reconfigure.scm | 157 +++++++++++++++++++ 4 files changed, 270 insertions(+), 285 deletions(-) create mode 100644 guix/scripts/system/reconfigure.scm -- 2.22.0 [-- Attachment #2: signature.asc --] [-- Type: application/pgp-signature, Size: 832 bytes --] ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 1/3] guix system: Add 'reconfigure' module. 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 ` Jakob L. Kreuze 2019-07-05 23:47 ` [bug#36404] [PATCH 2/3] machine: Reimplement 'managed-host-environment-type' deployment Jakob L. Kreuze 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 2 siblings, 2 replies; 84+ messages in thread From: Jakob L. Kreuze @ 2019-07-05 23:46 UTC (permalink / raw) To: Ludovic Courtès; +Cc: 36404 [-- Attachment #1: Type: text/plain, Size: 8821 bytes --] * guix/scripts/system/reconfigure.scm: New file. * Makefile.am (MODULES): Add it. * guix/scripts/system.scm (bootloader-installer-script): Export variable. --- Makefile.am | 1 + guix/scripts/system.scm | 1 + guix/scripts/system/reconfigure.scm | 157 ++++++++++++++++++++++++++++ 3 files changed, 159 insertions(+) create mode 100644 guix/scripts/system/reconfigure.scm diff --git a/Makefile.am b/Makefile.am index 4d3024e58..1934a21b1 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/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)) \f diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm new file mode 100644 index 000000000..f4ca6b4b1 --- /dev/null +++ b/guix/scripts/system/reconfigure.scm @@ -0,0 +1,157 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org> +;;; +;;; 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 <http://www.gnu.org/licenses/>. + +(define-module (guix scripts system reconfigure) + #:autoload (gnu packages gnupg) (guile-gcrypt) + #:use-module (guix gexp) + #:use-module (guix modules) + #:export (switch-to-system + upgrade-shepherd-services + 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: + +(define (switch-to-system system-derivation activation-script) + "Return a G-Expression that, upon being evaluated, will create a new +generation for SYSTEM-DERIVATION and execute ACTIVATION-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 #$system-derivation) + (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 #$activation-script)))))))) + +;; XXX: Currently, this does NOT attempt to restart running services. See +;; <https://issues.guix.info/issue/33508> for details. +(define (upgrade-shepherd-services target-services) + "Return a G-Expression that, upon being evaluated, will use TARGET-SERVICES, +a list of (shepherd-service-canonical-name, shepherd-service-file) pairs to +determine which services are obsolete and need to be unloaded, as well as +which services are new and need to be started." + (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))))) + +(define (install-bootloader installer-script bootcfg bootcfg-file target) + "Return a G-Expression that, upon being evaluated, will install BOOTCFG to +BOOTCFG-FILE, a target path, on TARGET, a mount point, and subsequently run +INSTALLER-SCRIPT." + (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 #$target) + ;; 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-script))))) + (delete-file temp-gc-root) + (error "failed to install bootloader")) + + (rename-file temp-gc-root gc-root)))))) -- 2.22.0 [-- Attachment #2: signature.asc --] [-- Type: application/pgp-signature, Size: 832 bytes --] ^ permalink raw reply related [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 2/3] machine: Reimplement 'managed-host-environment-type' deployment. 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 2019-07-05 23:48 ` [bug#36404] [PATCH 3/3] guix system: Reimplement 'reconfigure' Jakob L. Kreuze ` (2 more replies) 2019-07-06 22:11 ` [bug#36404] [PATCH 1/3] guix system: Add 'reconfigure' module Ludovic Courtès 1 sibling, 3 replies; 84+ messages in thread From: Jakob L. Kreuze @ 2019-07-05 23:47 UTC (permalink / raw) To: Ludovic Courtès; +Cc: 36404 [-- 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 --] ^ permalink raw reply related [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 3/3] guix system: Reimplement 'reconfigure'. 2019-07-05 23:47 ` [bug#36404] [PATCH 2/3] machine: Reimplement 'managed-host-environment-type' deployment Jakob L. Kreuze @ 2019-07-05 23:48 ` 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 2 siblings, 1 reply; 84+ messages in thread From: Jakob L. Kreuze @ 2019-07-05 23:48 UTC (permalink / raw) To: Ludovic Courtès; +Cc: 36404 [-- Attachment #1: Type: text/plain, Size: 11031 bytes --] * 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 | 161 +++++++++++++--------------------------- 1 file changed, 50 insertions(+), 111 deletions(-) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 21858ee7d..1f7912dcf 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,16 @@ 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 + (scheme-file "install-bootloader.scm" + (install-bootloader installer bootcfg + bootcfg-file + target)))) + (_ (built-derivations (list file)))) + (primitive-load (derivation->output-path file)))) (define* (install os-drv target #:key (log-port (current-output-port)) @@ -266,10 +245,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)))))) \f ;;; @@ -336,81 +313,47 @@ unload." (warning (G_ "failed to obtain list of shepherd services~%")) (return #f))))) -(define (upgrade-shepherd-services os) +(define (%upgrade-shepherd-services os) "Upgrade the Shepherd (PID 1) by unloading obsolete services and loading new 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 - (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 <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=22039#30>. - (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." + (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 os) + #:target-type shepherd-root-service-type)))) + + (mlet* %store-monad ((target-services target-services) + (file (lower-object + (scheme-file "upgrade-shepherd-services.scm" + (upgrade-shepherd-services + target-services)))) + (_ (built-derivations (list file)))) + (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 ((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)))) + (script (lower-object + (operating-system-activation-script os))) + (file (lower-object + (scheme-file "switch-to-system.scm" + (switch-to-system drv script)))) + (_ (built-derivations (list file)))) + (primitive-load (derivation->output-path file)))) (define-syntax-rule (unless-file-not-found exp) (catch 'system-error @@ -514,10 +457,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)))))) \f ;;; @@ -919,12 +859,11 @@ static checks." (case action ((reconfigure) (mbegin %store-monad - (switch-to-system os) + (%switch-to-system os) + (%upgrade-shepherd-services os) (mwhen install-bootloader? - (install-bootloader bootloader-script - #:bootcfg bootcfg - #:bootcfg-file bootcfg-file - #:target "/")))) + (%install-bootloader bootloader-script bootcfg + bootcfg-file (or target "/"))))) ((init) (newline) (format #t (G_ "initializing operating system under '~a'...~%") -- 2.22.0 [-- Attachment #2: signature.asc --] [-- Type: application/pgp-signature, Size: 832 bytes --] ^ permalink raw reply related [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 3/3] guix system: Reimplement 'reconfigure'. 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 0 siblings, 0 replies; 84+ messages in thread From: Ludovic Courtès @ 2019-07-06 22:20 UTC (permalink / raw) To: Jakob L. Kreuze; +Cc: 36404 Hi, zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) skribis: > +(define (%upgrade-shepherd-services os) > "Upgrade the Shepherd (PID 1) by unloading obsolete services and loading new > 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 > - (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) I think you’d need to include the ‘call-with-service-upgrade-info’ call in the service-upgrade program that (guix scripts system reconfigure) produces. It’s an important part of reconfiguration. However, ‘call-with-service-upgrade-info’ relies on (guix graph), which pulls in (guix monads) and many modules that we don’t actually need. It’s probably just an annoyance more than a real problem, but I think we should eventually change the (guix graph) API so that it no longer relies on the ‘%store-monad’, which in turn will make it a better fit in this context. Thanks for quickly hacking on this! Ludo’. ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 2/3] machine: Reimplement 'managed-host-environment-type' deployment. 2019-07-05 23:47 ` [bug#36404] [PATCH 2/3] machine: Reimplement 'managed-host-environment-type' deployment Jakob L. Kreuze 2019-07-05 23:48 ` [bug#36404] [PATCH 3/3] guix system: Reimplement 'reconfigure' Jakob L. Kreuze @ 2019-07-06 22:13 ` Ludovic Courtès 2019-07-07 7:13 ` Christopher Lemmer Webber 2 siblings, 0 replies; 84+ messages in thread From: Ludovic Courtès @ 2019-07-06 22:13 UTC (permalink / raw) To: Jakob L. Kreuze; +Cc: 36404 zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) skribis: > + (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))))) Normally you should never need to call ‘operating-system-derivation’ because you can just insert an <operating-system> in a gexp and it’ll do the right thing: #~(frob #$os) Ludo’. ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 2/3] machine: Reimplement 'managed-host-environment-type' deployment. 2019-07-05 23:47 ` [bug#36404] [PATCH 2/3] machine: Reimplement 'managed-host-environment-type' deployment Jakob L. Kreuze 2019-07-05 23:48 ` [bug#36404] [PATCH 3/3] guix system: Reimplement 'reconfigure' Jakob L. Kreuze 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 2 siblings, 1 reply; 84+ messages in thread From: Christopher Lemmer Webber @ 2019-07-07 7:13 UTC (permalink / raw) To: Jakob L. Kreuze; +Cc: 36404 In some ways it looks like a portion of the previous patch and a portion of this patch are a "move and modify" of what are sort-of the same chunks of code. But it's a bit weird to me that the code is added in the previous commit and removed in this one? It might be clearer to the reader that this is what is happening if it's in the same commit. Jakob L. Kreuze writes: > * 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 > ;;; ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 2/3] machine: Reimplement 'managed-host-environment-type' deployment. 2019-07-07 7:13 ` Christopher Lemmer Webber @ 2019-07-07 13:05 ` Ludovic Courtès 0 siblings, 0 replies; 84+ messages in thread From: Ludovic Courtès @ 2019-07-07 13:05 UTC (permalink / raw) To: Christopher Lemmer Webber; +Cc: 36404 Christopher Lemmer Webber <cwebber@dustycloud.org> skribis: > In some ways it looks like a portion of the previous patch and a portion > of this patch are a "move and modify" of what are sort-of the same > chunks of code. But it's a bit weird to me that the code is added in > the previous commit and removed in this one? It might be clearer to the > reader that this is what is happening if it's in the same commit. Yes, good point. Ludo’. ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 1/3] guix system: Add 'reconfigure' module. 2019-07-05 23:46 ` [bug#36404] [PATCH 1/3] guix system: Add 'reconfigure' module Jakob L. Kreuze 2019-07-05 23:47 ` [bug#36404] [PATCH 2/3] machine: Reimplement 'managed-host-environment-type' deployment Jakob L. Kreuze @ 2019-07-06 22:11 ` Ludovic Courtès 1 sibling, 0 replies; 84+ messages in thread From: Ludovic Courtès @ 2019-07-06 22:11 UTC (permalink / raw) To: Jakob L. Kreuze; +Cc: 36404 zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) skribis: > * guix/scripts/system/reconfigure.scm: New file. > * Makefile.am (MODULES): Add it. > * guix/scripts/system.scm (bootloader-installer-script): Export variable. > +;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org> Could you preserve the copyright lines of (guix scripts system) that apply to these portions of code, roughly? I think all the procedures in (guix scripts system reconfigure) could return a <scheme-file> rather than a gexp. Actually a <program-file> would even be cleaner than a <scheme-file>, as it could better handle transitions like you’re on a Guile 2.2 system reconfiguring towards a Guile 3 system. Consequently you could rename ‘switch-to-system’ to ‘switch-system-program’, and so on. > +(define (switch-to-system system-derivation activation-script) I think it could simply take an <operating-system> record and derive the relevant bits from that. > + (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) This comment may become irrelevant. > + ;; 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 #$activation-script)))))))) Same here? For ‘guix system reconfigure’, we’d rather not lose messages written to stdout by ACTIVATION-SCRIPT. > + (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 #$target) > + ;; 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-script))))) Same as above. Ludo’. ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 0/3] Refactor out common behavior for system reconfiguration. 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-06 22:02 ` Ludovic Courtès 2019-07-07 7:02 ` Christopher Lemmer Webber 2 siblings, 0 replies; 84+ messages in thread From: Ludovic Courtès @ 2019-07-06 22:02 UTC (permalink / raw) To: Jakob L. Kreuze; +Cc: 36404 Hello, zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) skribis: > Ludovic Courtès <ludo@gnu.org> writes: > >> Note that writing tests could be tricky because it’s about testing the >> effect of these reconfigure actions. At any rate, let us know how it >> goes! > > This is a _very_ preliminary patch series. I'm not nearly done with it > yet; the procedures in guix/scripts/system.scm that I've replaced have > some handling for i.e. installing the bootloader configuration without > running the installer script, which my reimplementations don't yet > support. > > I'm sending this tonight to make sure I'm on the right track: is this > sort of what you meant by extracting the common behavior into scripts? Yes! > Also, I didn't include any tests as part of this series, but > implementing reconfiguration like this does, indeed, make testing for > 'guix deploy' much, much easier. And we'll get some tests for the > behavior of 'guix system reconfigure' out of it, too! As you can imagine we’ll have to be careful with ‘guix system reconfigure’—let’s not break everyone’s system. ;-) But yes, it seems like the right thing to me. Ludo’. ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 0/3] Refactor out common behavior for system reconfiguration. 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-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 2 siblings, 1 reply; 84+ messages in thread From: Christopher Lemmer Webber @ 2019-07-07 7:02 UTC (permalink / raw) To: Jakob L. Kreuze; +Cc: 36404 Side note: I closed this issue when the initial set of patches were merged. It seems there's ongoing work... should we reopen it or make a separate issue? I'm unsure. ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 0/3] Refactor out common behavior for system reconfiguration. 2019-07-07 7:02 ` Christopher Lemmer Webber @ 2019-07-07 13:06 ` Ludovic Courtès 2019-07-08 19:22 ` Jakob L. Kreuze 0 siblings, 1 reply; 84+ messages in thread From: Ludovic Courtès @ 2019-07-07 13:06 UTC (permalink / raw) To: Christopher Lemmer Webber; +Cc: 36404 Christopher Lemmer Webber <cwebber@dustycloud.org> skribis: > Side note: I closed this issue when the initial set of patches were > merged. It seems there's ongoing work... should we reopen it or make a > separate issue? I'm unsure. We should probably open a new issue, indeed! Jakob, do you want to continue the discussion in a separate issue? Thanks, Ludo’. ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 0/3] Refactor out common behavior for system reconfiguration. 2019-07-07 13:06 ` Ludovic Courtès @ 2019-07-08 19:22 ` Jakob L. Kreuze 0 siblings, 0 replies; 84+ messages in thread From: Jakob L. Kreuze @ 2019-07-08 19:22 UTC (permalink / raw) To: Ludovic Courtès; +Cc: 36404 [-- Attachment #1: Type: text/plain, Size: 3917 bytes --] Hi, Chris and Ludovic! Ludovic Courtès <ludo@gnu.org> writes: > zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) skribis: > > > * guix/scripts/system/reconfigure.scm: New file. > > * Makefile.am (MODULES): Add it. > > * guix/scripts/system.scm (bootloader-installer-script): Export variable. > > > +;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org> > > Could you preserve the copyright lines of (guix scripts system) that > apply to these portions of code, roughly? I've copied over all of the copyright lines in the original file. Briefly looking through the log for 'guix/scripts/system.scm', it seems that most of the committers have touched the code for system reconfiguration at one point or another. Let me know if you'd like me to comb through the logs more finely and update the copyright lines accordingly. > I think all the procedures in (guix scripts system reconfigure) could > return a <scheme-file> rather than a gexp. Actually a <program-file> > would even be cleaner than a <scheme-file>, as it could better handle > transitions like you’re on a Guile 2.2 system reconfiguring towards a > Guile 3 system. > > Consequently you could rename ‘switch-to-system’ to > ‘switch-system-program’, and so on. That'd make writing tests for these procedures a little bit easier, too. > I think it could simply take an <operating-system> record and derive > the relevant bits from that. You're right, and it's an especially easy change to make once I factor in your later comment about not needing to invoke 'operating-system-derivation' directly. > This comment may become irrelevant. Good catch. At this point it's little more than a historical detail. > Same here? For ‘guix system reconfigure’, we’d rather not lose > messages written to stdout by ACTIVATION-SCRIPT. That's a good point. I've modified 'install-bootloader-program' to similarly return the installer script's output as a string (it was previously being discarded.) > I think you’d need to include the ‘call-with-service-upgrade-info’ > call in the service-upgrade program that (guix scripts system > reconfigure) produces. It’s an important part of reconfiguration. > > However, ‘call-with-service-upgrade-info’ relies on (guix graph), > which pulls in (guix monads) and many modules that we don’t actually > need. > > It’s probably just an annoyance more than a real problem, but I think > we should eventually change the (guix graph) API so that it no longer > relies on the ‘%store-monad’, which in turn will make it a better fit > in this context. Services are serialized on the host side, so we can make use of 'call-with-service-upgrade-info' without drawing any of its dependencies into the G-Expression. :) It's nicer than my hacky 'target-services' expression, anyway. Christopher Lemmer Webber <cwebber@dustycloud.org> writes: > In some ways it looks like a portion of the previous patch and a > portion of this patch are a "move and modify" of what are sort-of the > same chunks of code. But it's a bit weird to me that the code is added > in the previous commit and removed in this one? It might be clearer to > the reader that this is what is happening if it's in the same commit. Looking at the diff now, I definitely see what you're talking about. Squashed! Ludovic Courtès <ludo@gnu.org> writes: > Christopher Lemmer Webber <cwebber@dustycloud.org> skribis: > >> Side note: I closed this issue when the initial set of patches were >> merged. It seems there's ongoing work... should we reopen it or make a >> separate issue? I'm unsure. > > We should probably open a new issue, indeed! Jakob, do you want to > continue the discussion in a separate issue? Yes, please! I'll open a new ticket on guix-patches with my revisions. Regards, Jakob [-- Attachment #2: signature.asc --] [-- Type: application/pgp-signature, Size: 832 bytes --] ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 0/4] Add 'guix deploy'. 2019-07-01 12:53 ` Ludovic Courtès 2019-07-02 0:10 ` Jakob L. Kreuze @ 2019-07-02 0:14 ` Jakob L. Kreuze 2019-07-02 0:16 ` [bug#36404] [PATCH 1/4] ssh: Add 'identity' keyword to 'open-ssh-session' Jakob L. Kreuze 1 sibling, 1 reply; 84+ messages in thread From: Jakob L. Kreuze @ 2019-07-02 0:14 UTC (permalink / raw) To: Ludovic Courtès; +Cc: 36404 [-- Attachment #1: Type: text/plain, Size: 1825 bytes --] Huge thanks to everyone who commented on the first two renditions of this patch series. Here's a summary of the changes I've incorporated: % The 'environment' field of <machine> is now an instance of <environment-type> -- a record similar to <service-type>. See the manual page for an example of how this looks in a deployment specification. % Deployment specifications are loaded in an environment with '(gnu)', '(gnu machine)', and '(gnu machine ssh)'. '(gnu machine)' and its descendant modules are no longer exported from '(gnu)'. % Environment and load path excursions have been removed from the deployment internals for 'managed-host-environment-type'. 'remote-eval' spawns a new Guile REPL with each invocation, so modifications to $PATH et al. aren't really relevant -- at least not with how 'deploy-managed-host' is implemented. % Wording in the manual section has been updated. % The docstring for 'open-ssh-session' has been updated. % Tests have been decoupled from the commit adding '(gnu machine)' and omitted from this patch series. I will add them back in a future patch. Jakob L. Kreuze (4): ssh: Add 'identity' keyword to 'open-ssh-session'. gnu: Add machine type for deployment specifications. Add 'guix deploy'. doc: Add section for 'guix deploy'. Makefile.am | 4 +- doc/guix.texi | 101 ++++++++++++ gnu/local.mk | 5 +- gnu/machine.scm | 118 +++++++++++++ gnu/machine/ssh.scm | 355 ++++++++++++++++++++++++++++++++++++++++ guix/scripts/deploy.scm | 90 ++++++++++ guix/ssh.scm | 10 +- 7 files changed, 677 insertions(+), 6 deletions(-) create mode 100644 gnu/machine.scm create mode 100644 gnu/machine/ssh.scm create mode 100644 guix/scripts/deploy.scm -- 2.22.0 [-- Attachment #2: signature.asc --] [-- Type: application/pgp-signature, Size: 832 bytes --] ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 1/4] ssh: Add 'identity' keyword to 'open-ssh-session'. 2019-07-02 0:14 ` [bug#36404] [PATCH 0/4] Add 'guix deploy' Jakob L. Kreuze @ 2019-07-02 0:16 ` Jakob L. Kreuze 2019-07-02 0:17 ` [bug#36404] [PATCH 2/4] gnu: Add machine type for deployment specifications Jakob L. Kreuze 0 siblings, 1 reply; 84+ messages in thread From: Jakob L. Kreuze @ 2019-07-02 0:16 UTC (permalink / raw) To: Ludovic Courtès; +Cc: 36404 [-- Attachment #1: Type: text/plain, Size: 1251 bytes --] * guix/ssh.scm (open-ssh-session): Add 'identity' keyword argument --- guix/ssh.scm | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/guix/ssh.scm b/guix/ssh.scm index 9b9baf54e..9bf10b9a0 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -57,12 +57,14 @@ (define %compression "zlib@openssh.com,zlib") -(define* (open-ssh-session host #:key user port +(define* (open-ssh-session host #:key user port identity (compression %compression)) - "Open an SSH session for HOST and return it. When USER and PORT are #f, use -default values or whatever '~/.ssh/config' specifies; otherwise use them. -Throw an error on failure." + "Open an SSH session for HOST and return it. IDENTITY specifies the path of +a private key to use for authenticating with the host. When USER, PORT, or +IDENTITY are #f, use default values or whatever '~/.ssh/config' specifies; +otherwise use them. Throw an error on failure." (let ((session (make-session #:user user + #:identity identity #:host host #:port port #:timeout 10 ;seconds -- 2.22.0 [-- Attachment #2: signature.asc --] [-- Type: application/pgp-signature, Size: 832 bytes --] ^ permalink raw reply related [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 2/4] gnu: Add machine type for deployment specifications. 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 ` Jakob L. Kreuze 2019-07-02 0:17 ` [bug#36404] [PATCH 3/4] Add 'guix deploy' Jakob L. Kreuze 0 siblings, 1 reply; 84+ messages in thread From: Jakob L. Kreuze @ 2019-07-02 0:17 UTC (permalink / raw) To: Ludovic Courtès; +Cc: 36404 [-- Attachment #1: Type: text/plain, Size: 22737 bytes --] * gnu/machine.scm: New file. * gnu/machine/ssh.scm: New file. * gnu/local.mk (GNU_SYSTEM_MODULES): Add it. --- Makefile.am | 3 +- gnu/local.mk | 5 +- gnu/machine.scm | 118 ++++++++++++++ gnu/machine/ssh.scm | 363 ++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 487 insertions(+), 2 deletions(-) create mode 100644 gnu/machine.scm create mode 100644 gnu/machine/ssh.scm diff --git a/Makefile.am b/Makefile.am index 42307abae..f10c000ea 100644 --- a/Makefile.am +++ b/Makefile.am @@ -425,7 +425,8 @@ SCM_TESTS = \ tests/import-utils.scm \ tests/store-database.scm \ tests/store-deduplication.scm \ - tests/store-roots.scm + tests/store-roots.scm \ + tests/machine.scm SH_TESTS = \ tests/guix-build.sh \ diff --git a/gnu/local.mk b/gnu/local.mk index 81de156cf..0e17af953 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -562,6 +562,9 @@ GNU_SYSTEM_MODULES = \ %D%/system/uuid.scm \ %D%/system/vm.scm \ \ + %D%/machine.scm \ + %D%/machine/ssh.scm \ + \ %D%/build/accounts.scm \ %D%/build/activation.scm \ %D%/build/bootloader.scm \ @@ -627,7 +630,7 @@ INSTALLER_MODULES = \ %D%/installer/newt/user.scm \ %D%/installer/newt/utils.scm \ %D%/installer/newt/welcome.scm \ - %D%/installer/newt/wifi.scm + %D%/installer/newt/wifi.scm # Always ship the installer modules but compile them only when # ENABLE_INSTALLER is true. diff --git a/gnu/machine.scm b/gnu/machine.scm new file mode 100644 index 000000000..3dfcab797 --- /dev/null +++ b/gnu/machine.scm @@ -0,0 +1,118 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 David Thompson <davet@gnu.org> +;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org> +;;; +;;; 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 <http://www.gnu.org/licenses/>. + +(define-module (gnu machine) + #:use-module (gnu system) + #:use-module (guix derivations) + #:use-module (guix monads) + #:use-module (guix records) + #:use-module (guix store) + #:use-module ((guix utils) #:select (source-properties->location)) + #:export (environment-type + environment-type? + environment-type-name + environment-type-description + environment-type-location + + machine + machine? + this-machine + + machine-system + machine-environment + machine-configuration + machine-display-name + + build-machine + deploy-machine + machine-remote-eval)) + +;;; Commentary: +;;; +;;; This module provides the types used to declare individual machines in a +;;; heterogeneous Guix deployment. The interface allows users of specify system +;;; configurations and the means by which resources should be provisioned on a +;;; per-host basis. +;;; +;;; Code: + +\f +;;; +;;; Declarations for resources that can be provisioned. +;;; + +(define-record-type* <environment-type> environment-type + make-environment-type + environment-type? + + ;; Interface to the environment type's deployment code. Each procedure + ;; should take the same arguments as the top-level procedure of this file + ;; that shares the same name. For example, 'machine-remote-eval' should be + ;; of the form '(machine-remote-eval machine exp)'. + (machine-remote-eval environment-type-machine-remote-eval) ; procedure + (deploy-machine environment-type-deploy-machine) ; procedure + + ;; Metadata. + (name environment-type-name) ; symbol + (description environment-type-description ; string + (default #f)) + (location environment-type-location ; <location> + (default (and=> (current-source-location) + source-properties->location)) + (innate))) + +\f +;;; +;;; Declarations for machines in a deployment. +;;; + +(define-record-type* <machine> machine + make-machine + machine? + this-machine + (system machine-system) ; <operating-system> + (environment machine-environment) ; symbol + (configuration machine-configuration ; configuration object + (default #f))) ; specific to environment + +(define (machine-display-name machine) + "Return the host-name identifying MACHINE." + (operating-system-host-name (machine-system machine))) + +(define (build-machine machine) + "Monadic procedure that builds the system derivation for MACHINE and returning +a list containing the path of the derivation file and the path of the derivation +output." + (let ((os (machine-system machine))) + (mlet* %store-monad ((osdrv (operating-system-derivation os)) + (_ ((store-lift build-derivations) (list osdrv)))) + (return (list (derivation-file-name osdrv) + (derivation->output-path osdrv)))))) + +(define (machine-remote-eval machine exp) + "Evaluate EXP, a gexp, on MACHINE. Ensure that all the elements EXP refers to +are built and deployed to MACHINE beforehand." + (let ((environment (machine-environment machine))) + ((environment-type-machine-remote-eval environment) machine exp))) + +(define (deploy-machine machine) + "Monadic procedure transferring the new system's OS closure to the remote +MACHINE, activating it on MACHINE and switching MACHINE to the new generation." + (let ((environment (machine-environment machine))) + ((environment-type-deploy-machine environment) machine))) diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm new file mode 100644 index 000000000..6ce106bb2 --- /dev/null +++ b/gnu/machine/ssh.scm @@ -0,0 +1,363 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org> +;;; +;;; 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 <http://www.gnu.org/licenses/>. + +(define-module (gnu machine ssh) + #:use-module (gnu bootloader) + #:use-module (gnu machine) + #:autoload (gnu packages gnupg) (guile-gcrypt) + #:use-module (gnu services) + #:use-module (gnu services shepherd) + #:use-module (gnu system) + #: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 ssh) + #:use-module (guix store) + #:use-module (ice-9 match) + #:use-module (srfi srfi-19) + #:export (managed-host-environment-type + + machine-ssh-configuration + machine-ssh-configuration? + machine-ssh-configuration + + machine-ssh-configuration-host-name + machine-ssh-configuration-port + machine-ssh-configuration-user + machine-ssh-configuration-session)) + +;;; Commentary: +;;; +;;; This module implements remote evaluation and system deployment for +;;; machines that are accessable over SSH and have a known host-name. In the +;;; sense of the broader "machine" interface, we describe the environment for +;;; such machines as 'managed-host. +;;; +;;; Code: + +\f +;;; +;;; Parameters for the SSH client. +;;; + +(define-record-type* <machine-ssh-configuration> machine-ssh-configuration + make-machine-ssh-configuration + machine-ssh-configuration? + this-machine-ssh-configuration + (host-name machine-ssh-configuration-host-name) ; string + (port machine-ssh-configuration-port ; integer + (default 22)) + (user machine-ssh-configuration-user ; string + (default "root")) + (identity machine-ssh-configuration-identity ; path to a private key + (default #f)) + (session machine-ssh-configuration-session ; session + (default #f))) + +(define (machine-ssh-session machine) + "Return the SSH session that was given in MACHINE's configuration, or create +one from the configuration's parameters if one was not provided." + (let ((config (machine-configuration machine))) + (if (machine-ssh-configuration? config) + (or (machine-ssh-configuration-session config) + (let ((host-name (machine-ssh-configuration-host-name config)) + (user (machine-ssh-configuration-user config)) + (port (machine-ssh-configuration-port config)) + (identity (machine-ssh-configuration-identity config))) + (open-ssh-session host-name + #:user user + #:port port + #:identity identity))) + (error "unsupported configuration type")))) + +\f +;;; +;;; Remote evaluation. +;;; + +(define (managed-host-remote-eval machine exp) + "Internal implementation of 'machine-remote-eval' for MACHINE instances with +an environment type of 'managed-host." + (maybe-raise-missing-configuration-error machine) + (remote-eval exp (machine-ssh-session machine))) + +\f +;;; +;;; 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 #$(derivation->output-path 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." + (define bootable-kernel-arguments + (@@ (gnu system) bootable-kernel-arguments)) + + (define remote-exp + (with-extensions (list guile-gcrypt) + (with-imported-modules (source-module-closure '((guix config) + (guix profiles))) + #~(begin + (use-modules (guix config) + (guix profiles) + (ice-9 textual-ports)) + + (define %system-profile + (string-append %state-directory "/profiles/system")) + + (define (read-file path) + (call-with-input-file path + (lambda (port) + (get-string-all port)))) + + (map (lambda (generation) + (let* ((system-path (generation-file-name %system-profile + generation)) + (boot-parameters-path (string-append system-path + "/parameters")) + (time (stat:mtime (lstat system-path)))) + (list generation + system-path + time + (read-file boot-parameters-path)))) + (reverse (generation-numbers %system-profile))))))) + + (mlet* %store-monad ((generations (machine-remote-eval machine remote-exp))) + (return + (map (lambda (generation) + (match generation + ((generation system-path time serialized-params) + (let* ((params (call-with-input-string serialized-params + read-boot-parameters)) + (root (boot-parameters-root-device params)) + (label (boot-parameters-label params))) + (boot-parameters + (inherit params) + (label + (string-append label " (#" + (number->string generation) ", " + (let ((time (make-time time-utc 0 time))) + (date->string (time-utc->date time) + "~Y-~m-~d ~H:~M")) + ")")) + (kernel-arguments + (append (bootable-kernel-arguments system-path root) + (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-missing-configuration-error machine) + (mbegin %store-monad + (switch-to-system machine) + (upgrade-shepherd-services machine) + (install-bootloader machine))) + +\f +;;; +;;; Environment type. +;;; + +(define managed-host-environment-type + (environment-type + (machine-remote-eval managed-host-remote-eval) + (deploy-machine deploy-managed-host) + (name 'managed-host-environment-type) + (description "Provisioning for machines that are accessable over SSH +and have a known host-name. This entails little more than maintaining an SSH +connection to the host."))) + +(define (maybe-raise-missing-configuration-error machine) + "Raise an error if MACHINE's configuration is #f." + (let ((environment (machine-environment machine))) + (unless (machine-configuration machine) + (error (format #f (G_ "no configuration specified for environment '~a'") + (symbol->string (environment-type-name environment))))))) -- 2.22.0 [-- Attachment #2: signature.asc --] [-- Type: application/pgp-signature, Size: 832 bytes --] ^ permalink raw reply related [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 3/4] Add 'guix deploy'. 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 ` Jakob L. Kreuze 2019-07-02 0:18 ` [bug#36404] [PATCH 4/4] doc: Add section for " Jakob L. Kreuze 0 siblings, 1 reply; 84+ messages in thread From: Jakob L. Kreuze @ 2019-07-02 0:17 UTC (permalink / raw) To: Ludovic Courtès; +Cc: 36404 [-- Attachment #1: Type: text/plain, Size: 4123 bytes --] * guix/scripts/deploy.scm: New file. * Makefile.am (MODULES): Add it. --- Makefile.am | 1 + guix/scripts/deploy.scm | 90 +++++++++++++++++++++++++++++++++++++++++ 2 files changed, 91 insertions(+) create mode 100644 guix/scripts/deploy.scm diff --git a/Makefile.am b/Makefile.am index f10c000ea..4d3024e58 100644 --- a/Makefile.am +++ b/Makefile.am @@ -267,6 +267,7 @@ MODULES = \ guix/scripts/weather.scm \ guix/scripts/container.scm \ guix/scripts/container/exec.scm \ + guix/scripts/deploy.scm \ guix.scm \ $(GNU_SYSTEM_MODULES) diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm new file mode 100644 index 000000000..4fb1babe8 --- /dev/null +++ b/guix/scripts/deploy.scm @@ -0,0 +1,90 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 David Thompson <davet@gnu.org> +;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org> +;;; +;;; 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 <http://www.gnu.org/licenses/>. + +(define-module (guix scripts deploy) + #:use-module (gnu machine) + #:use-module (guix scripts) + #:use-module (guix scripts build) + #:use-module (guix store) + #:use-module (guix ui) + #:use-module (ice-9 format) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-37) + #:export (guix-deploy)) + +;;; Commentary: +;;; +;;; This program provides a command-line interface to (gnu machine), allowing +;;; users to perform remote deployments through specification files. +;;; +;;; Code: + +\f + +(define (show-help) + (display (G_ "Usage: guix deploy [OPTION] FILE... +Perform the deployment specified by FILE.\n")) + (show-build-options-help) + (newline) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + (cons* (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + %standard-build-options)) + +(define %default-options + '((system . ,(%current-system)) + (substitutes? . #t) + (build-hook? . #t) + (graft? . #t) + (debug . 0) + (verbosity . 2))) + +(define (load-source-file file) + "Load FILE as a user module." + (let ((module (make-user-module '((gnu) (gnu machine) (gnu machine ssh))))) + (load* file module))) + +(define (guix-deploy . args) + (define (handle-argument arg result) + (alist-cons 'file arg result)) + (let* ((opts (parse-command-line args %options (list %default-options) + #:argument-handler handle-argument)) + (file (assq-ref opts 'file)) + (machines (or (and file (load-source-file file)) '()))) + (with-store store + (set-build-options-from-command-line store opts) + (for-each (lambda (machine) + (format #t "building ~a... " (machine-display-name machine)) + (run-with-store store (build-machine machine)) + (display "done\n")) + machines) + (for-each (lambda (machine) + (format #t "deploying to ~a... " (machine-display-name machine)) + (run-with-store store (deploy-machine machine)) + (display "done\n")) + machines)))) -- 2.22.0 [-- Attachment #2: signature.asc --] [-- Type: application/pgp-signature, Size: 832 bytes --] ^ permalink raw reply related [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 4/4] doc: Add section for 'guix deploy'. 2019-07-02 0:17 ` [bug#36404] [PATCH 3/4] Add 'guix deploy' Jakob L. Kreuze @ 2019-07-02 0:18 ` Jakob L. Kreuze [not found] ` <875zoldqah.fsf@kyleam.com> 0 siblings, 1 reply; 84+ messages in thread From: Jakob L. Kreuze @ 2019-07-02 0:18 UTC (permalink / raw) To: Ludovic Courtès; +Cc: 36404 [-- Attachment #1: Type: text/plain, Size: 5769 bytes --] * doc/guix.texi: Add section "Invoking guix deploy". --- doc/guix.texi | 101 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 101 insertions(+) diff --git a/doc/guix.texi b/doc/guix.texi index 9dc1d2a9c..23b7416ab 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -81,6 +81,7 @@ Documentation License''. * guix gc: (guix)Invoking guix gc. Reclaiming unused disk space. * guix pull: (guix)Invoking guix pull. Update the list of available packages. * guix system: (guix)Invoking guix system. Manage the operating system configuration. +* guix deploy: (guix)Invoking guix deploy. Manage operating system configurations for remote hosts. @end direntry @dircategory Software development @@ -269,6 +270,7 @@ System Configuration * Initial RAM Disk:: Linux-Libre bootstrapping. * Bootloader Configuration:: Configuring the boot loader. * Invoking guix system:: Instantiating a system configuration. +* Invoking guix deploy:: Deploying a system configuration to a remote host. * Running Guix in a VM:: How to run Guix System in a virtual machine. * Defining Services:: Adding new service definitions. @@ -10302,6 +10304,7 @@ instance to support new system services. * Initial RAM Disk:: Linux-Libre bootstrapping. * Bootloader Configuration:: Configuring the boot loader. * Invoking guix system:: Instantiating a system configuration. +* Invoking guix deploy:: Deploying a system configuration to a remote host. * Running Guix in a VM:: How to run Guix System in a virtual machine. * Defining Services:: Adding new service definitions. @end menu @@ -25335,6 +25338,104 @@ example graph. @end table +@node Invoking guix deploy +@section Invoking @code{guix deploy} + +In addition to managing a machine's configuration locally through operating +system declarations, Guix also provides the ability to managing multiple remote +hosts as a logical ``deployment''. This is done using @command{guix deploy}. + +@example +guix deploy @var{file} +@end example + +Such an invocation will deploy the machines that the code within @var{file} +evaluates to. As an example, @var{file} might contain a definition like this: + +@example +;; This is a Guix deployment of a "bare bones" setup, with +;; no X11 display server, to a machine with an SSH daemon +;; listening on localhost:2222. A configuration such as this +;; may be appropriate for virtual machine with ports +;; forwarded to the host's loopback interface. + +(use-service-modules networking ssh) +(use-package-modules bootloaders) + +(define %system + (operating-system + (host-name "gnu-deployed") + (timezone "Etc/UTC") + (bootloader (bootloader-configuration + (bootloader grub-bootloader) + (target "/dev/vda") + (terminal-outputs '(console)))) + (file-systems (cons (file-system + (mount-point "/") + (device "/dev/vda1") + (type "ext4")) + %base-file-systems)) + (services + (append (list (service dhcp-client-service-type) + (service openssh-service-type + (openssh-configuration + (permit-root-login #t) + (allow-empty-passwords? #t)))) + %base-services)))) + +(list (machine + (system %system) + (environment managed-host-environment-type) + (configuration (machine-ssh-configuration + (host-name "localhost") + (identity "./id_rsa") + (port 2222))))) +@end example + +The file should evaluate to a list of @var{machine} objects. This example, +upon being deployed, will create a new generation on the remote system +realizing the operating-system configuration @var{%system}. @var{environment} +and @var{configuration} specify how the machine should be provisioned--that +is, deployment and management of computing resources. The above example does +not provision any resources -- a @code{'managed-host} is a machine that is +already up and running the Guix system. A more complex deployment may involve +i.e. starting virtual machines through a VPS provider, however, in which case +a different @var{environment} types would be used. + +@deftp {Data Type} machine +This is the data type representing a single machine in a heterogeneous Guix +deployment. + +@table @asis +@item @code{system} +The object of the operating system configuration to deploy. + +@item @code{environment} +A symbol describing how the machine should be provisioned. At the moment, only +the only supported value is @code{'managed-host}. + +@item @code{configuration} (default: @code{#f}) +An object describing the configuration for the machine's @code{environment}. If +the @code{environment} has a default configuration, @code{#f} can be used. If +@code{#f} is used for an environment with no default configuration, however, an +error will be thrown. +@end table +@end deftp + +@deftp {Data Type} machine-ssh-configuration +This is the data type representing the SSH client parameters for connecting to a +@code{'managed-host}. + +@table @asis +@item @code{host-name} +@item @code{port} (default: @code{22}) +@item @code{user} (default: @code{"root"}) +@item @code{identity} (default: @code{#f}) +If specified, the path to the SSH private key to use to authenticate with the +remote host. +@end table +@end deftp + @node Running Guix in a VM @section Running Guix in a Virtual Machine -- 2.22.0 [-- Attachment #2: signature.asc --] [-- Type: application/pgp-signature, Size: 832 bytes --] ^ permalink raw reply related [flat|nested] 84+ messages in thread
[parent not found: <875zoldqah.fsf@kyleam.com>]
[parent not found: <87muhwtmfp.fsf@sdf.lonestar.org>]
[parent not found: <871rz874l2.fsf@kyleam.com>]
[parent not found: <877e90tj7l.fsf_-_@sdf.lonestar.org>]
* [bug#36404] [PATCH v4 1/4] ssh: Add 'identity' keyword to 'open-ssh-session'. [not found] ` <877e90tj7l.fsf_-_@sdf.lonestar.org> @ 2019-07-02 17:56 ` 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-05 1:23 ` [bug#36404] [PATCH v4 1/4] ssh: Add 'identity' keyword to 'open-ssh-session' Thompson, David 0 siblings, 2 replies; 84+ messages in thread From: Jakob L. Kreuze @ 2019-07-02 17:56 UTC (permalink / raw) To: Ludovic Courtès; +Cc: 36404 [-- Attachment #1: Type: text/plain, Size: 1252 bytes --] * guix/ssh.scm (open-ssh-session): Add 'identity' keyword argument. --- guix/ssh.scm | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/guix/ssh.scm b/guix/ssh.scm index 9b9baf54e..9bf10b9a0 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -57,12 +57,14 @@ (define %compression "zlib@openssh.com,zlib") -(define* (open-ssh-session host #:key user port +(define* (open-ssh-session host #:key user port identity (compression %compression)) - "Open an SSH session for HOST and return it. When USER and PORT are #f, use -default values or whatever '~/.ssh/config' specifies; otherwise use them. -Throw an error on failure." + "Open an SSH session for HOST and return it. IDENTITY specifies the path of +a private key to use for authenticating with the host. When USER, PORT, or +IDENTITY are #f, use default values or whatever '~/.ssh/config' specifies; +otherwise use them. Throw an error on failure." (let ((session (make-session #:user user + #:identity identity #:host host #:port port #:timeout 10 ;seconds -- 2.22.0 [-- Attachment #2: signature.asc --] [-- Type: application/pgp-signature, Size: 832 bytes --] ^ permalink raw reply related [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH v4 2/4] gnu: Add machine type for deployment specifications. 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 ` Jakob L. Kreuze 2019-07-02 17:57 ` [bug#36404] [PATCH v4 3/4] Add 'guix deploy' Jakob L. Kreuze ` (3 more replies) 2019-07-05 1:23 ` [bug#36404] [PATCH v4 1/4] ssh: Add 'identity' keyword to 'open-ssh-session' Thompson, David 1 sibling, 4 replies; 84+ messages in thread From: Jakob L. Kreuze @ 2019-07-02 17:56 UTC (permalink / raw) To: Ludovic Courtès; +Cc: 36404 [-- Attachment #1: Type: text/plain, Size: 22737 bytes --] * gnu/machine.scm: New file. * gnu/machine/ssh.scm: New file. * gnu/local.mk (GNU_SYSTEM_MODULES): Add it. --- Makefile.am | 3 +- gnu/local.mk | 5 +- gnu/machine.scm | 118 ++++++++++++++ gnu/machine/ssh.scm | 363 ++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 487 insertions(+), 2 deletions(-) create mode 100644 gnu/machine.scm create mode 100644 gnu/machine/ssh.scm diff --git a/Makefile.am b/Makefile.am index 42307abae..f10c000ea 100644 --- a/Makefile.am +++ b/Makefile.am @@ -425,7 +425,8 @@ SCM_TESTS = \ tests/import-utils.scm \ tests/store-database.scm \ tests/store-deduplication.scm \ - tests/store-roots.scm + tests/store-roots.scm \ + tests/machine.scm SH_TESTS = \ tests/guix-build.sh \ diff --git a/gnu/local.mk b/gnu/local.mk index 81de156cf..0e17af953 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -562,6 +562,9 @@ GNU_SYSTEM_MODULES = \ %D%/system/uuid.scm \ %D%/system/vm.scm \ \ + %D%/machine.scm \ + %D%/machine/ssh.scm \ + \ %D%/build/accounts.scm \ %D%/build/activation.scm \ %D%/build/bootloader.scm \ @@ -627,7 +630,7 @@ INSTALLER_MODULES = \ %D%/installer/newt/user.scm \ %D%/installer/newt/utils.scm \ %D%/installer/newt/welcome.scm \ - %D%/installer/newt/wifi.scm + %D%/installer/newt/wifi.scm # Always ship the installer modules but compile them only when # ENABLE_INSTALLER is true. diff --git a/gnu/machine.scm b/gnu/machine.scm new file mode 100644 index 000000000..3dfcab797 --- /dev/null +++ b/gnu/machine.scm @@ -0,0 +1,118 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 David Thompson <davet@gnu.org> +;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org> +;;; +;;; 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 <http://www.gnu.org/licenses/>. + +(define-module (gnu machine) + #:use-module (gnu system) + #:use-module (guix derivations) + #:use-module (guix monads) + #:use-module (guix records) + #:use-module (guix store) + #:use-module ((guix utils) #:select (source-properties->location)) + #:export (environment-type + environment-type? + environment-type-name + environment-type-description + environment-type-location + + machine + machine? + this-machine + + machine-system + machine-environment + machine-configuration + machine-display-name + + build-machine + deploy-machine + machine-remote-eval)) + +;;; Commentary: +;;; +;;; This module provides the types used to declare individual machines in a +;;; heterogeneous Guix deployment. The interface allows users of specify system +;;; configurations and the means by which resources should be provisioned on a +;;; per-host basis. +;;; +;;; Code: + +\f +;;; +;;; Declarations for resources that can be provisioned. +;;; + +(define-record-type* <environment-type> environment-type + make-environment-type + environment-type? + + ;; Interface to the environment type's deployment code. Each procedure + ;; should take the same arguments as the top-level procedure of this file + ;; that shares the same name. For example, 'machine-remote-eval' should be + ;; of the form '(machine-remote-eval machine exp)'. + (machine-remote-eval environment-type-machine-remote-eval) ; procedure + (deploy-machine environment-type-deploy-machine) ; procedure + + ;; Metadata. + (name environment-type-name) ; symbol + (description environment-type-description ; string + (default #f)) + (location environment-type-location ; <location> + (default (and=> (current-source-location) + source-properties->location)) + (innate))) + +\f +;;; +;;; Declarations for machines in a deployment. +;;; + +(define-record-type* <machine> machine + make-machine + machine? + this-machine + (system machine-system) ; <operating-system> + (environment machine-environment) ; symbol + (configuration machine-configuration ; configuration object + (default #f))) ; specific to environment + +(define (machine-display-name machine) + "Return the host-name identifying MACHINE." + (operating-system-host-name (machine-system machine))) + +(define (build-machine machine) + "Monadic procedure that builds the system derivation for MACHINE and returning +a list containing the path of the derivation file and the path of the derivation +output." + (let ((os (machine-system machine))) + (mlet* %store-monad ((osdrv (operating-system-derivation os)) + (_ ((store-lift build-derivations) (list osdrv)))) + (return (list (derivation-file-name osdrv) + (derivation->output-path osdrv)))))) + +(define (machine-remote-eval machine exp) + "Evaluate EXP, a gexp, on MACHINE. Ensure that all the elements EXP refers to +are built and deployed to MACHINE beforehand." + (let ((environment (machine-environment machine))) + ((environment-type-machine-remote-eval environment) machine exp))) + +(define (deploy-machine machine) + "Monadic procedure transferring the new system's OS closure to the remote +MACHINE, activating it on MACHINE and switching MACHINE to the new generation." + (let ((environment (machine-environment machine))) + ((environment-type-deploy-machine environment) machine))) diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm new file mode 100644 index 000000000..6ce106bb2 --- /dev/null +++ b/gnu/machine/ssh.scm @@ -0,0 +1,363 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org> +;;; +;;; 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 <http://www.gnu.org/licenses/>. + +(define-module (gnu machine ssh) + #:use-module (gnu bootloader) + #:use-module (gnu machine) + #:autoload (gnu packages gnupg) (guile-gcrypt) + #:use-module (gnu services) + #:use-module (gnu services shepherd) + #:use-module (gnu system) + #: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 ssh) + #:use-module (guix store) + #:use-module (ice-9 match) + #:use-module (srfi srfi-19) + #:export (managed-host-environment-type + + machine-ssh-configuration + machine-ssh-configuration? + machine-ssh-configuration + + machine-ssh-configuration-host-name + machine-ssh-configuration-port + machine-ssh-configuration-user + machine-ssh-configuration-session)) + +;;; Commentary: +;;; +;;; This module implements remote evaluation and system deployment for +;;; machines that are accessable over SSH and have a known host-name. In the +;;; sense of the broader "machine" interface, we describe the environment for +;;; such machines as 'managed-host. +;;; +;;; Code: + +\f +;;; +;;; Parameters for the SSH client. +;;; + +(define-record-type* <machine-ssh-configuration> machine-ssh-configuration + make-machine-ssh-configuration + machine-ssh-configuration? + this-machine-ssh-configuration + (host-name machine-ssh-configuration-host-name) ; string + (port machine-ssh-configuration-port ; integer + (default 22)) + (user machine-ssh-configuration-user ; string + (default "root")) + (identity machine-ssh-configuration-identity ; path to a private key + (default #f)) + (session machine-ssh-configuration-session ; session + (default #f))) + +(define (machine-ssh-session machine) + "Return the SSH session that was given in MACHINE's configuration, or create +one from the configuration's parameters if one was not provided." + (let ((config (machine-configuration machine))) + (if (machine-ssh-configuration? config) + (or (machine-ssh-configuration-session config) + (let ((host-name (machine-ssh-configuration-host-name config)) + (user (machine-ssh-configuration-user config)) + (port (machine-ssh-configuration-port config)) + (identity (machine-ssh-configuration-identity config))) + (open-ssh-session host-name + #:user user + #:port port + #:identity identity))) + (error "unsupported configuration type")))) + +\f +;;; +;;; Remote evaluation. +;;; + +(define (managed-host-remote-eval machine exp) + "Internal implementation of 'machine-remote-eval' for MACHINE instances with +an environment type of 'managed-host." + (maybe-raise-missing-configuration-error machine) + (remote-eval exp (machine-ssh-session machine))) + +\f +;;; +;;; 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 #$(derivation->output-path 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." + (define bootable-kernel-arguments + (@@ (gnu system) bootable-kernel-arguments)) + + (define remote-exp + (with-extensions (list guile-gcrypt) + (with-imported-modules (source-module-closure '((guix config) + (guix profiles))) + #~(begin + (use-modules (guix config) + (guix profiles) + (ice-9 textual-ports)) + + (define %system-profile + (string-append %state-directory "/profiles/system")) + + (define (read-file path) + (call-with-input-file path + (lambda (port) + (get-string-all port)))) + + (map (lambda (generation) + (let* ((system-path (generation-file-name %system-profile + generation)) + (boot-parameters-path (string-append system-path + "/parameters")) + (time (stat:mtime (lstat system-path)))) + (list generation + system-path + time + (read-file boot-parameters-path)))) + (reverse (generation-numbers %system-profile))))))) + + (mlet* %store-monad ((generations (machine-remote-eval machine remote-exp))) + (return + (map (lambda (generation) + (match generation + ((generation system-path time serialized-params) + (let* ((params (call-with-input-string serialized-params + read-boot-parameters)) + (root (boot-parameters-root-device params)) + (label (boot-parameters-label params))) + (boot-parameters + (inherit params) + (label + (string-append label " (#" + (number->string generation) ", " + (let ((time (make-time time-utc 0 time))) + (date->string (time-utc->date time) + "~Y-~m-~d ~H:~M")) + ")")) + (kernel-arguments + (append (bootable-kernel-arguments system-path root) + (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-missing-configuration-error machine) + (mbegin %store-monad + (switch-to-system machine) + (upgrade-shepherd-services machine) + (install-bootloader machine))) + +\f +;;; +;;; Environment type. +;;; + +(define managed-host-environment-type + (environment-type + (machine-remote-eval managed-host-remote-eval) + (deploy-machine deploy-managed-host) + (name 'managed-host-environment-type) + (description "Provisioning for machines that are accessable over SSH +and have a known host-name. This entails little more than maintaining an SSH +connection to the host."))) + +(define (maybe-raise-missing-configuration-error machine) + "Raise an error if MACHINE's configuration is #f." + (let ((environment (machine-environment machine))) + (unless (machine-configuration machine) + (error (format #f (G_ "no configuration specified for environment '~a'") + (symbol->string (environment-type-name environment))))))) -- 2.22.0 [-- Attachment #2: signature.asc --] [-- Type: application/pgp-signature, Size: 832 bytes --] ^ permalink raw reply related [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH v4 3/4] Add 'guix deploy'. 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 ` Jakob L. Kreuze 2019-07-02 17:58 ` [bug#36404] [PATCH v4 4/4] doc: Add section for " Jakob L. Kreuze ` (2 more replies) 2019-07-04 9:19 ` [bug#36404] [PATCH v4 2/4] gnu: Add machine type for deployment specifications Ludovic Courtès ` (2 subsequent siblings) 3 siblings, 3 replies; 84+ messages in thread From: Jakob L. Kreuze @ 2019-07-02 17:57 UTC (permalink / raw) To: Ludovic Courtès; +Cc: 36404 [-- Attachment #1: Type: text/plain, Size: 4125 bytes --] * guix/scripts/deploy.scm: New file. * Makefile.am (MODULES): Add it. --- Makefile.am | 1 + guix/scripts/deploy.scm | 90 +++++++++++++++++++++++++++++++++++++++++ 2 files changed, 91 insertions(+) create mode 100644 guix/scripts/deploy.scm diff --git a/Makefile.am b/Makefile.am index f10c000ea..4d3024e58 100644 --- a/Makefile.am +++ b/Makefile.am @@ -267,6 +267,7 @@ MODULES = \ guix/scripts/weather.scm \ guix/scripts/container.scm \ guix/scripts/container/exec.scm \ + guix/scripts/deploy.scm \ guix.scm \ $(GNU_SYSTEM_MODULES) diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm new file mode 100644 index 000000000..4fb1babe8 --- /dev/null +++ b/guix/scripts/deploy.scm @@ -0,0 +1,90 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 David Thompson <davet@gnu.org> +;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org> +;;; +;;; 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 <http://www.gnu.org/licenses/>. + +(define-module (guix scripts deploy) + #:use-module (gnu machine) + #:use-module (guix scripts) + #:use-module (guix scripts build) + #:use-module (guix store) + #:use-module (guix ui) + #:use-module (ice-9 format) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-37) + #:export (guix-deploy)) + +;;; Commentary: +;;; +;;; This program provides a command-line interface to (gnu machine), allowing +;;; users to perform remote deployments through specification files. +;;; +;;; Code: + +\f + +(define (show-help) + (display (G_ "Usage: guix deploy [OPTION] FILE... +Perform the deployment specified by FILE.\n")) + (show-build-options-help) + (newline) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + (cons* (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + %standard-build-options)) + +(define %default-options + '((system . ,(%current-system)) + (substitutes? . #t) + (build-hook? . #t) + (graft? . #t) + (debug . 0) + (verbosity . 2))) + +(define (load-source-file file) + "Load FILE as a user module." + (let ((module (make-user-module '((gnu) (gnu machine) (gnu machine ssh))))) + (load* file module))) + +(define (guix-deploy . args) + (define (handle-argument arg result) + (alist-cons 'file arg result)) + (let* ((opts (parse-command-line args %options (list %default-options) + #:argument-handler handle-argument)) + (file (assq-ref opts 'file)) + (machines (or (and file (load-source-file file)) '()))) + (with-store store + (set-build-options-from-command-line store opts) + (for-each (lambda (machine) + (format #t "building ~a... " (machine-display-name machine)) + (run-with-store store (build-machine machine)) + (display "done\n")) + machines) + (for-each (lambda (machine) + (format #t "deploying to ~a... " (machine-display-name machine)) + (run-with-store store (deploy-machine machine)) + (display "done\n")) + machines)))) -- 2.22.0 [-- Attachment #2: signature.asc --] [-- Type: application/pgp-signature, Size: 832 bytes --] ^ permalink raw reply related [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH v4 4/4] doc: Add section for 'guix deploy'. 2019-07-02 17:57 ` [bug#36404] [PATCH v4 3/4] Add 'guix deploy' Jakob L. Kreuze @ 2019-07-02 17:58 ` Jakob L. Kreuze 2019-07-03 23:07 ` Christopher Lemmer Webber ` (2 more replies) 2019-07-05 1:35 ` [bug#36404] [PATCH v4 3/4] Add " Thompson, David 2019-07-05 8:17 ` Ludovic Courtès 2 siblings, 3 replies; 84+ messages in thread From: Jakob L. Kreuze @ 2019-07-02 17:58 UTC (permalink / raw) To: Ludovic Courtès; +Cc: 36404 [-- Attachment #1: Type: text/plain, Size: 6103 bytes --] * doc/guix.texi: Add section "Invoking guix deploy". --- doc/guix.texi | 107 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 107 insertions(+) diff --git a/doc/guix.texi b/doc/guix.texi index 9dc1d2a9c..0827a2bde 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -81,6 +81,7 @@ Documentation License''. * guix gc: (guix)Invoking guix gc. Reclaiming unused disk space. * guix pull: (guix)Invoking guix pull. Update the list of available packages. * guix system: (guix)Invoking guix system. Manage the operating system configuration. +* guix deploy: (guix)Invoking guix deploy. Manage operating system configurations for remote hosts. @end direntry @dircategory Software development @@ -269,6 +270,7 @@ System Configuration * Initial RAM Disk:: Linux-Libre bootstrapping. * Bootloader Configuration:: Configuring the boot loader. * Invoking guix system:: Instantiating a system configuration. +* Invoking guix deploy:: Deploying a system configuration to a remote host. * Running Guix in a VM:: How to run Guix System in a virtual machine. * Defining Services:: Adding new service definitions. @@ -10302,6 +10304,7 @@ instance to support new system services. * Initial RAM Disk:: Linux-Libre bootstrapping. * Bootloader Configuration:: Configuring the boot loader. * Invoking guix system:: Instantiating a system configuration. +* Invoking guix deploy:: Deploying a system configuration to a remote host. * Running Guix in a VM:: How to run Guix System in a virtual machine. * Defining Services:: Adding new service definitions. @end menu @@ -25335,6 +25338,110 @@ example graph. @end table +@node Invoking guix deploy +@section Invoking @code{guix deploy} + +We've already seen @code{operating-system} declarations used to manage a +machine's configuration locally. Suppose you need to configure multiple +machines, though---perhaps you're managing a service on the web that's +comprised of several servers. @command{guix deploy} enables you to use those +same @code{operating-system} declarations to manage multiple remote hosts at +once as a logical ``deployment''. + +@example +guix deploy @var{file} +@end example + +Such an invocation will deploy the machines that the code within @var{file} +evaluates to. As an example, @var{file} might contain a definition like this: + +@example +;; This is a Guix deployment of a "bare bones" setup, with +;; no X11 display server, to a machine with an SSH daemon +;; listening on localhost:2222. A configuration such as this +;; may be appropriate for virtual machine with ports +;; forwarded to the host's loopback interface. + +(use-service-modules networking ssh) +(use-package-modules bootloaders) + +(define %system + (operating-system + (host-name "gnu-deployed") + (timezone "Etc/UTC") + (bootloader (bootloader-configuration + (bootloader grub-bootloader) + (target "/dev/vda") + (terminal-outputs '(console)))) + (file-systems (cons (file-system + (mount-point "/") + (device "/dev/vda1") + (type "ext4")) + %base-file-systems)) + (services + (append (list (service dhcp-client-service-type) + (service openssh-service-type + (openssh-configuration + (permit-root-login #t) + (allow-empty-passwords? #t)))) + %base-services)))) + +(list (machine + (system %system) + (environment managed-host-environment-type) + (configuration (machine-ssh-configuration + (host-name "localhost") + (identity "./id_rsa") + (port 2222))))) +@end example + +The file should evaluate to a list of @var{machine} objects. This example, +upon being deployed, will create a new generation on the remote system +realizing the @code{operating-system} declaration @var{%system}. +@var{environment} and @var{configuration} specify how the machine should be +provisioned---that is, how the computing resources should be created and +managed. The above example does not create any resources, as a +@code{'managed-host} is a machine that is already running the Guix system and +available over the network. This is a particularly simple case; a more +complex deployment may involve, for example, starting virtual machines through +a VPS provider. In such a case, a different @var{environment} type would be +used. + +@deftp {Data Type} machine +This is the data type representing a single machine in a heterogeneous Guix +deployment. + +@table @asis +@item @code{system} +The object of the operating system configuration to deploy. + +@item @code{environment} +An @code{environment-type} describing how the machine should be provisioned. +At the moment, the only supported value is +@code{managed-host-environment-type}. + +@item @code{configuration} (default: @code{#f}) +An object describing the configuration for the machine's @code{environment}. +If the @code{environment} has a default configuration, @code{#f} maybe used. +If @code{#f} is used for an environment with no default configuration, +however, an error will be thrown. +@end table +@end deftp + +@deftp {Data Type} machine-ssh-configuration +This is the data type representing the SSH client parameters for a machine +with an @code{environment} of @code{managed-host-environment-type}. + +@table @asis +@item @code{host-name} +@item @code{port} (default: @code{22}) +@item @code{user} (default: @code{"root"}) +@item @code{identity} (default: @code{#f}) +If specified, the path to the SSH private key to use to authenticate with the +remote host. +@end table +@end deftp + @node Running Guix in a VM @section Running Guix in a Virtual Machine -- 2.22.0 [-- Attachment #2: signature.asc --] [-- Type: application/pgp-signature, Size: 832 bytes --] ^ permalink raw reply related [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH v4 4/4] doc: Add section for 'guix deploy'. 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 2 siblings, 1 reply; 84+ messages in thread From: Christopher Lemmer Webber @ 2019-07-03 23:07 UTC (permalink / raw) To: Jakob L. Kreuze; +Cc: 36404 Jakob L. Kreuze writes: > * doc/guix.texi: Add section "Invoking guix deploy". > --- > doc/guix.texi | 107 ++++++++++++++++++++++++++++++++++++++++++++++++++ > 1 file changed, 107 insertions(+) > > diff --git a/doc/guix.texi b/doc/guix.texi > index 9dc1d2a9c..0827a2bde 100644 > --- a/doc/guix.texi > +++ b/doc/guix.texi > @@ -81,6 +81,7 @@ Documentation License''. > * guix gc: (guix)Invoking guix gc. Reclaiming unused disk space. > * guix pull: (guix)Invoking guix pull. Update the list of available packages. > * guix system: (guix)Invoking guix system. Manage the operating system configuration. > +* guix deploy: (guix)Invoking guix deploy. Manage operating system configurations for remote hosts. > @end direntry > > @dircategory Software development > @@ -269,6 +270,7 @@ System Configuration > * Initial RAM Disk:: Linux-Libre bootstrapping. > * Bootloader Configuration:: Configuring the boot loader. > * Invoking guix system:: Instantiating a system configuration. > +* Invoking guix deploy:: Deploying a system configuration to a remote host. > * Running Guix in a VM:: How to run Guix System in a virtual machine. > * Defining Services:: Adding new service definitions. > > @@ -10302,6 +10304,7 @@ instance to support new system services. > * Initial RAM Disk:: Linux-Libre bootstrapping. > * Bootloader Configuration:: Configuring the boot loader. > * Invoking guix system:: Instantiating a system configuration. > +* Invoking guix deploy:: Deploying a system configuration to a remote host. > * Running Guix in a VM:: How to run Guix System in a virtual machine. > * Defining Services:: Adding new service definitions. > @end menu > @@ -25335,6 +25338,110 @@ example graph. > > @end table > > +@node Invoking guix deploy > +@section Invoking @code{guix deploy} > + > +We've already seen @code{operating-system} declarations used to manage a > +machine's configuration locally. Suppose you need to configure multiple > +machines, though---perhaps you're managing a service on the web that's > +comprised of several servers. @command{guix deploy} enables you to use those > +same @code{operating-system} declarations to manage multiple remote hosts at > +once as a logical ``deployment''. > + > +@example > +guix deploy @var{file} > +@end example > + > +Such an invocation will deploy the machines that the code within @var{file} > +evaluates to. As an example, @var{file} might contain a definition like this: > + > +@example > +;; This is a Guix deployment of a "bare bones" setup, with > +;; no X11 display server, to a machine with an SSH daemon > +;; listening on localhost:2222. A configuration such as this > +;; may be appropriate for virtual machine with ports > +;; forwarded to the host's loopback interface. > + > +(use-service-modules networking ssh) > +(use-package-modules bootloaders) > + > +(define %system > + (operating-system > + (host-name "gnu-deployed") > + (timezone "Etc/UTC") > + (bootloader (bootloader-configuration > + (bootloader grub-bootloader) > + (target "/dev/vda") > + (terminal-outputs '(console)))) > + (file-systems (cons (file-system > + (mount-point "/") > + (device "/dev/vda1") > + (type "ext4")) > + %base-file-systems)) > + (services > + (append (list (service dhcp-client-service-type) > + (service openssh-service-type > + (openssh-configuration > + (permit-root-login #t) > + (allow-empty-passwords? #t)))) > + %base-services)))) > + > +(list (machine > + (system %system) > + (environment managed-host-environment-type) > + (configuration (machine-ssh-configuration > + (host-name "localhost") > + (identity "./id_rsa") > + (port 2222))))) > +@end example > + > +The file should evaluate to a list of @var{machine} objects. This example, > +upon being deployed, will create a new generation on the remote system > +realizing the @code{operating-system} declaration @var{%system}. > +@var{environment} and @var{configuration} specify how the machine should be > +provisioned---that is, how the computing resources should be created and > +managed. The above example does not create any resources, as a > +@code{'managed-host} is a machine that is already running the Guix system and > +available over the network. This is a particularly simple case; a more > +complex deployment may involve, for example, starting virtual machines through > +a VPS provider. In such a case, a different @var{environment} type would be > +used. > + > +@deftp {Data Type} machine > +This is the data type representing a single machine in a heterogeneous Guix > +deployment. > + > +@table @asis > +@item @code{system} > +The object of the operating system configuration to deploy. > + > +@item @code{environment} > +An @code{environment-type} describing how the machine should be provisioned. > +At the moment, the only supported value is > +@code{managed-host-environment-type}. > + > +@item @code{configuration} (default: @code{#f}) > +An object describing the configuration for the machine's @code{environment}. > +If the @code{environment} has a default configuration, @code{#f} maybe used. > +If @code{#f} is used for an environment with no default configuration, > +however, an error will be thrown. > +@end table > +@end deftp > + > +@deftp {Data Type} machine-ssh-configuration > +This is the data type representing the SSH client parameters for a machine > +with an @code{environment} of @code{managed-host-environment-type}. > + > +@table @asis > +@item @code{host-name} > +@item @code{port} (default: @code{22}) > +@item @code{user} (default: @code{"root"}) > +@item @code{identity} (default: @code{#f}) > +If specified, the path to the SSH private key to use to authenticate with the > +remote host. > +@end table > +@end deftp > + > @node Running Guix in a VM > @section Running Guix in a Virtual Machine All looks good to me. From my perspective, this is ready to merge. Which means that we need to merge Ludo's remote-eval too. Of course others may catch things, but I'd say let's not take too long... we should get this in and let people start playing with it. :) ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH v4 4/4] doc: Add section for 'guix deploy'. 2019-07-03 23:07 ` Christopher Lemmer Webber @ 2019-07-04 9:20 ` Ludovic Courtès 0 siblings, 0 replies; 84+ messages in thread From: Ludovic Courtès @ 2019-07-04 9:20 UTC (permalink / raw) To: Christopher Lemmer Webber; +Cc: 36404 Hi, Christopher Lemmer Webber <cwebber@dustycloud.org> skribis: > From my perspective, this is ready to merge. Which means that we need > to merge Ludo's remote-eval too. Yes, sorry for the delay on this. I started wondering about details of the ‘lower-gexp’ API; I’ll try to get to it today… Thanks, Ludo’. ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH v4 4/4] doc: Add section for 'guix deploy'. 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-05 1:39 ` Thompson, David 2019-07-05 8:29 ` Ludovic Courtès 2 siblings, 0 replies; 84+ messages in thread From: Thompson, David @ 2019-07-05 1:39 UTC (permalink / raw) To: Jakob L. Kreuze; +Cc: 36404 On Tue, Jul 2, 2019 at 1:58 PM Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org> wrote: > > * doc/guix.texi: Add section "Invoking guix deploy". Looks good to me. Congratulations in advance for getting 'guix deploy' to master! - Dave ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH v4 4/4] doc: Add section for 'guix deploy'. 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-05 1:39 ` Thompson, David @ 2019-07-05 8:29 ` Ludovic Courtès 2 siblings, 0 replies; 84+ messages in thread From: Ludovic Courtès @ 2019-07-05 8:29 UTC (permalink / raw) To: Jakob L. Kreuze; +Cc: 36404 zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) skribis: > * doc/guix.texi: Add section "Invoking guix deploy". Yay! You can add a copyright line for you at the top of guix.texi. > +@section Invoking @code{guix deploy} > + > +We've already seen @code{operating-system} declarations used to manage a > +machine's configuration locally. Suppose you need to configure multiple > +machines, though---perhaps you're managing a service on the web that's > +comprised of several servers. @command{guix deploy} enables you to use those > +same @code{operating-system} declarations to manage multiple remote hosts at > +once as a logical ``deployment''. Perhaps add something like: @quotation Note The functionality described in this section is still under development and is subject to change. Get in touch with us on @email{guix-devel@@gnu.org}! @end quotation That way, if we make a Guix release before this is all stabilized, we make sure people have appropriate expectations. :-) > +complex deployment may involve, for example, starting virtual machines through > +a VPS provider. In such a case, a different @var{environment} type would be ^^^ I would write “Virtual Private Server (VPS)”. I hope the nitpicking level is acceptable, let me know. I’m really excited to see this land in master! Ludo’. ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH v4 3/4] Add 'guix deploy'. 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-05 1:35 ` Thompson, David 2019-07-05 8:17 ` Ludovic Courtès 2 siblings, 0 replies; 84+ messages in thread From: Thompson, David @ 2019-07-05 1:35 UTC (permalink / raw) To: Jakob L. Kreuze; +Cc: 36404 On Tue, Jul 2, 2019 at 1:57 PM Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org> wrote: > > * guix/scripts/deploy.scm: New file. > * Makefile.am (MODULES): Add it. Looks good to me! - Dave ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH v4 3/4] Add 'guix deploy'. 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-05 1:35 ` [bug#36404] [PATCH v4 3/4] Add " Thompson, David @ 2019-07-05 8:17 ` Ludovic Courtès 2 siblings, 0 replies; 84+ messages in thread From: Ludovic Courtès @ 2019-07-05 8:17 UTC (permalink / raw) To: Jakob L. Kreuze; +Cc: 36404 zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) skribis: > * guix/scripts/deploy.scm: New file. > * Makefile.am (MODULES): Add it. Overall LGTM, just a couple of minor points: > +++ b/guix/scripts/deploy.scm Please add this file to po/guix/POTFILES.in so it can be subject to localization. > +(define %default-options > + '((system . ,(%current-system)) > + (substitutes? . #t) > + (build-hook? . #t) > + (graft? . #t) > + (debug . 0) > + (verbosity . 2))) ‘verbosity’ should probably be 1 (only ‘guix build’ and ‘guix system build’ default to 2.) > + (for-each (lambda (machine) > + (format #t "building ~a... " (machine-display-name machine)) > + (run-with-store store (build-machine machine)) > + (display "done\n")) > + machines) > + (for-each (lambda (machine) > + (format #t "deploying to ~a... " (machine-display-name machine)) > + (run-with-store store (deploy-machine machine)) > + (display "done\n")) > + machines)))) For i18n purposes and also to get consistent output, please avoid ‘format #t’ and instead write: (info (G_ "deploying ~a…~%") (machine-display-name machine)) I think you can omit the “done” message. As a matter of style, it’s clearer IMO to have only one ‘run-with-store’ call in the whole program. Also, the separate ‘build-machine’ phase is not needed—more on that in another message. Thanks, Ludo’. ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH v4 2/4] gnu: Add machine type for deployment specifications. 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-04 9:19 ` Ludovic Courtès 2019-07-04 15:59 ` Jakob L. Kreuze 2019-07-05 1:32 ` Thompson, David 2019-07-05 8:24 ` Ludovic Courtès 3 siblings, 1 reply; 84+ messages in thread From: Ludovic Courtès @ 2019-07-04 9:19 UTC (permalink / raw) To: Jakob L. Kreuze; +Cc: 36404 Hi Jakob and all! Apologies for not moving as fast as you do! :-) zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) skribis: > +(define (switch-to-system machine) > + "Monadic procedure creating a new generation on MACHINE and execute the > +activation script for the new system configuration." [...] > +(define (upgrade-shepherd-services machine) > + "Monadic procedure unloading and starting services on the remote as needed > +to realize the MACHINE's system configuration." [...] > +(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." [...] > +(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." To me the end goal was to move these “effectful” bits into a script, such that both ‘guix system reconfigure’ and ‘guix deploy’ would only have to run that script, locally or remotely. That would avoid duplicating these somewhat tricky procedures. Now, perhaps we can start like this, and leave factorization for later? I just want to make sure we don’t forget about that and let it evolve into something we have a hard time maintaining. WDYT? Thanks, Ludo’. ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH v4 2/4] gnu: Add machine type for deployment specifications. 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 0 siblings, 0 replies; 84+ messages in thread From: Jakob L. Kreuze @ 2019-07-04 15:59 UTC (permalink / raw) To: Ludovic Courtès; +Cc: 36404 [-- Attachment #1: Type: text/plain, Size: 1035 bytes --] Hi Ludovic, Ludovic Courtès <ludo@gnu.org> writes: > To me the end goal was to move these “effectful” bits into a script, > such that both ‘guix system reconfigure’ and ‘guix deploy’ would only > have to run that script, locally or remotely. That would avoid > duplicating these somewhat tricky procedures. Ah, that's starting to ring a bell now. I believe you mentioned that when 'guix deploy' was initially being proposed, but at the time I didn't quite register that we'd be extracting the behavior in that way. > Now, perhaps we can start like this, and leave factorization for > later? I just want to make sure we don’t forget about that and let it > evolve into something we have a hard time maintaining. > > WDYT? I agree. I'm getting the impression that people don't want this to sit in review limbo for too long, and in terms of "commit history hygiene," I think it would be better to recognize refactoring out the common behavior as a distinct change. Thanks! Regards, Jakob [-- Attachment #2: signature.asc --] [-- Type: application/pgp-signature, Size: 832 bytes --] ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH v4 2/4] gnu: Add machine type for deployment specifications. 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-04 9:19 ` [bug#36404] [PATCH v4 2/4] gnu: Add machine type for deployment specifications Ludovic Courtès @ 2019-07-05 1:32 ` Thompson, David 2019-07-05 8:10 ` Ludovic Courtès 2019-07-05 8:24 ` Ludovic Courtès 3 siblings, 1 reply; 84+ messages in thread From: Thompson, David @ 2019-07-05 1:32 UTC (permalink / raw) To: Jakob L. Kreuze; +Cc: 36404 On Tue, Jul 2, 2019 at 1:57 PM Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org> wrote: > > * gnu/machine.scm: New file. > * gnu/machine/ssh.scm: New file. > * gnu/local.mk (GNU_SYSTEM_MODULES): Add it. I'm OK with refactoring the reconfigure code in a future patch set. This patch looks good to me! - Dave ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH v4 2/4] gnu: Add machine type for deployment specifications. 2019-07-05 1:32 ` Thompson, David @ 2019-07-05 8:10 ` Ludovic Courtès 0 siblings, 0 replies; 84+ messages in thread From: Ludovic Courtès @ 2019-07-05 8:10 UTC (permalink / raw) To: Thompson, David; +Cc: 36404 Hi, "Thompson, David" <dthompson2@worcester.edu> skribis: > On Tue, Jul 2, 2019 at 1:57 PM Jakob L. Kreuze > <zerodaysfordays@sdf.lonestar.org> wrote: >> >> * gnu/machine.scm: New file. >> * gnu/machine/ssh.scm: New file. >> * gnu/local.mk (GNU_SYSTEM_MODULES): Add it. > > I'm OK with refactoring the reconfigure code in a future patch set. OK, sounds good to me! Thanks for your feedback, Ludo’. ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH v4 2/4] gnu: Add machine type for deployment specifications. 2019-07-02 17:56 ` [bug#36404] [PATCH v4 2/4] gnu: Add machine type for deployment specifications Jakob L. Kreuze ` (2 preceding siblings ...) 2019-07-05 1:32 ` Thompson, David @ 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 3 siblings, 1 reply; 84+ messages in thread From: Ludovic Courtès @ 2019-07-05 8:24 UTC (permalink / raw) To: Jakob L. Kreuze; +Cc: 36404 zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) skribis: > +(define (build-machine machine) > + "Monadic procedure that builds the system derivation for MACHINE and returning > +a list containing the path of the derivation file and the path of the derivation > +output." > + (let ((os (machine-system machine))) > + (mlet* %store-monad ((osdrv (operating-system-derivation os)) > + (_ ((store-lift build-derivations) (list osdrv)))) > + (return (list (derivation-file-name osdrv) > + (derivation->output-path osdrv)))))) > + > +(define (machine-remote-eval machine exp) > + "Evaluate EXP, a gexp, on MACHINE. Ensure that all the elements EXP refers to > +are built and deployed to MACHINE beforehand." > + (let ((environment (machine-environment machine))) > + ((environment-type-machine-remote-eval environment) machine exp))) > + > +(define (deploy-machine machine) > + "Monadic procedure transferring the new system's OS closure to the remote > +MACHINE, activating it on MACHINE and switching MACHINE to the new generation." > + (let ((environment (machine-environment machine))) > + ((environment-type-deploy-machine environment) machine))) In the SSH case, ‘deploy-machine’ should roughly translate to: (remote-eval #~(switch-to-system #$os) machine) Thus, ‘build-machine’ is unnecessary: the actual build of OS is automatically triggered by ‘remote-eval’, either locally or remotely, depending on #:build-locally?. So I believe you can remove ‘build-machine’ altogether. > + (error "unsupported configuration type")))) It’s a bit verbose, but I’d suggest using SRFI-34/35 instead, like so: (raise (condition (&message (message "unsupported machine configuration type")))) That way, if you also add the file to po/guix/POTFILES.in, i18n will do its magic. :-) Otherwise it looks great to me! Ludo’. ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH v5 0/4] Add 'guix deploy'. 2019-07-05 8:24 ` Ludovic Courtès @ 2019-07-05 18:53 ` 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 0 siblings, 1 reply; 84+ messages in thread From: Jakob L. Kreuze @ 2019-07-05 18:53 UTC (permalink / raw) To: Ludovic Courtès; +Cc: 36404 [-- Attachment #1: Type: text/plain, Size: 5276 bytes --] "Thompson, David" <dthompson2@worcester.edu> writes: > Replace "path" with "file name". Lots of people use them > interchangeably, but GNU makes a clear distinction between the two > terms. Ah, good to know. Updated. Ludovic Courtès <ludo@gnu.org> writes: > Please add this file to po/guix/POTFILES.in so it can be subject to > localization. > >> +(define %default-options >> + '((system . ,(%current-system)) >> + (substitutes? . #t) >> + (build-hook? . #t) >> + (graft? . #t) >> + (debug . 0) >> + (verbosity . 2))) > > ‘verbosity’ should probably be 1 (only ‘guix build’ and ‘guix system > build’ default to 2.) > >> + (for-each (lambda (machine) >> + (format #t "building ~a... " (machine-display-name machine)) >> + (run-with-store store (build-machine machine)) >> + (display "done\n")) >> + machines) >> + (for-each (lambda (machine) >> + (format #t "deploying to ~a... " (machine-display-name machine)) >> + (run-with-store store (deploy-machine machine)) >> + (display "done\n")) >> + machines)))) > > For i18n purposes and also to get consistent output, please avoid > ‘format #t’ and instead write: > > (info (G_ "deploying ~a…~%") (machine-display-name machine)) > > I think you can omit the “done” message. > > As a matter of style, it’s clearer IMO to have only one ‘run-with-store’ > call in the whole program. As in, create a monadic expression with 'mapm' to evaluate the multiple calls to '(deploy-machine machine)' in sequence, and then pass that to 'run-with-store'? > In the SSH case, ‘deploy-machine’ should roughly translate to: > > (remote-eval #~(switch-to-system #$os) machine) > > Thus, ‘build-machine’ is unnecessary: the actual build of OS is > automatically triggered by ‘remote-eval’, either locally or remotely, > depending on #:build-locally?. > > So I believe you can remove ‘build-machine’ altogether. Thanks for pointing that out; I meant to ask about that since it's kinda vestigial at this point, but wasn't sure if it would be better to have it for the UI. But I went ahead and removed it, since we already have code for showing what derivations are going to be built, etc. > It’s a bit verbose, but I’d suggest using SRFI-34/35 instead, like so: > > (raise (condition > (&message (message "unsupported machine configuration type")))) > > That way, if you also add the file to po/guix/POTFILES.in, i18n will do > its magic. :-) In the end, I generalized the various configuration-related error messages into a 'maybe-raise-unsupported-configuration-error' that uses SRFI-35. Hopefully that's alright -- I believe the manual specifies the behavior enough that one more detailed message is better than two. > Yay! > > You can add a copyright line for you at the top of guix.texi. > >> +@section Invoking @code{guix deploy} >> + >> +We've already seen @code{operating-system} declarations used to manage a >> +machine's configuration locally. Suppose you need to configure multiple >> +machines, though---perhaps you're managing a service on the web that's >> +comprised of several servers. @command{guix deploy} enables you to use those >> +same @code{operating-system} declarations to manage multiple remote hosts at >> +once as a logical ``deployment''. > > Perhaps add something like: > > @quotation Note > The functionality described in this section is still under development > and is subject to change. Get in touch with us on > @email{guix-devel@@gnu.org}! > @end quotation > > That way, if we make a Guix release before this is all stabilized, > we make sure people have appropriate expectations. :-) I like it! >> +complex deployment may involve, for example, starting virtual machines through >> +a VPS provider. In such a case, a different @var{environment} type would be > ^^^ > I would write “Virtual Private Server (VPS)”. > > I hope the nitpicking level is acceptable, let me know. I’m really > excited to see this land in master! Oh, I appreciate this level of attention to detail. The hardest part of technical writing for me is having my writing fit in with the writing around it when contributing to an existing document, so these kinds of comments from someone more familiar with the manual are great. Jakob L. Kreuze (4): ssh: Add 'identity' keyword to 'open-ssh-session'. gnu: Add machine type for deployment specifications. Add 'guix deploy'. doc: Add section for 'guix deploy'. Makefile.am | 4 +- doc/guix.texi | 114 +++++++++++++ gnu/local.mk | 5 +- gnu/machine.scm | 107 ++++++++++++ gnu/machine/ssh.scm | 369 ++++++++++++++++++++++++++++++++++++++++ guix/scripts/deploy.scm | 84 +++++++++ guix/ssh.scm | 10 +- po/guix/POTFILES.in | 2 + 8 files changed, 689 insertions(+), 6 deletions(-) create mode 100644 gnu/machine.scm create mode 100644 gnu/machine/ssh.scm create mode 100644 guix/scripts/deploy.scm -- 2.22.0 [-- Attachment #2: signature.asc --] [-- Type: application/pgp-signature, Size: 832 bytes --] ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH v5 1/4] ssh: Add 'identity' keyword to 'open-ssh-session'. 2019-07-05 18:53 ` [bug#36404] [PATCH v5 0/4] Add 'guix deploy' Jakob L. Kreuze @ 2019-07-05 18:54 ` Jakob L. Kreuze 2019-07-05 18:55 ` [bug#36404] [PATCH v5 2/4] gnu: Add machine type for deployment specifications Jakob L. Kreuze 0 siblings, 1 reply; 84+ messages in thread From: Jakob L. Kreuze @ 2019-07-05 18:54 UTC (permalink / raw) To: Ludovic Courtès; +Cc: 36404 [-- Attachment #1: Type: text/plain, Size: 1259 bytes --] * guix/ssh.scm (open-ssh-session): Add 'identity' keyword argument. --- guix/ssh.scm | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/guix/ssh.scm b/guix/ssh.scm index 9b9baf54e..ede00133c 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -57,12 +57,14 @@ (define %compression "zlib@openssh.com,zlib") -(define* (open-ssh-session host #:key user port +(define* (open-ssh-session host #:key user port identity (compression %compression)) - "Open an SSH session for HOST and return it. When USER and PORT are #f, use -default values or whatever '~/.ssh/config' specifies; otherwise use them. -Throw an error on failure." + "Open an SSH session for HOST and return it. IDENTITY specifies the file +name of a private key to use for authenticating with the host. When USER, +PORT, or IDENTITY are #f, use default values or whatever '~/.ssh/config' +specifies; otherwise use them. Throw an error on failure." (let ((session (make-session #:user user + #:identity identity #:host host #:port port #:timeout 10 ;seconds -- 2.22.0 [-- Attachment #2: signature.asc --] [-- Type: application/pgp-signature, Size: 832 bytes --] ^ permalink raw reply related [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH v5 2/4] gnu: Add machine type for deployment specifications. 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 ` Jakob L. Kreuze 2019-07-05 18:56 ` [bug#36404] [PATCH v5 3/4] Add 'guix deploy' Jakob L. Kreuze 0 siblings, 1 reply; 84+ messages in thread From: Jakob L. Kreuze @ 2019-07-05 18:55 UTC (permalink / raw) To: Ludovic Courtès; +Cc: 36404 [-- Attachment #1: Type: text/plain, Size: 22763 bytes --] * gnu/machine.scm: New file. * gnu/machine/ssh.scm: New file. * gnu/local.mk (GNU_SYSTEM_MODULES): Add it. --- Makefile.am | 3 +- gnu/local.mk | 5 +- gnu/machine.scm | 107 +++++++++++++ gnu/machine/ssh.scm | 369 ++++++++++++++++++++++++++++++++++++++++++++ po/guix/POTFILES.in | 1 + 5 files changed, 483 insertions(+), 2 deletions(-) create mode 100644 gnu/machine.scm create mode 100644 gnu/machine/ssh.scm diff --git a/Makefile.am b/Makefile.am index 42307abae..f10c000ea 100644 --- a/Makefile.am +++ b/Makefile.am @@ -425,7 +425,8 @@ SCM_TESTS = \ tests/import-utils.scm \ tests/store-database.scm \ tests/store-deduplication.scm \ - tests/store-roots.scm + tests/store-roots.scm \ + tests/machine.scm SH_TESTS = \ tests/guix-build.sh \ diff --git a/gnu/local.mk b/gnu/local.mk index 81de156cf..0e17af953 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -562,6 +562,9 @@ GNU_SYSTEM_MODULES = \ %D%/system/uuid.scm \ %D%/system/vm.scm \ \ + %D%/machine.scm \ + %D%/machine/ssh.scm \ + \ %D%/build/accounts.scm \ %D%/build/activation.scm \ %D%/build/bootloader.scm \ @@ -627,7 +630,7 @@ INSTALLER_MODULES = \ %D%/installer/newt/user.scm \ %D%/installer/newt/utils.scm \ %D%/installer/newt/welcome.scm \ - %D%/installer/newt/wifi.scm + %D%/installer/newt/wifi.scm # Always ship the installer modules but compile them only when # ENABLE_INSTALLER is true. diff --git a/gnu/machine.scm b/gnu/machine.scm new file mode 100644 index 000000000..0b79402b0 --- /dev/null +++ b/gnu/machine.scm @@ -0,0 +1,107 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 David Thompson <davet@gnu.org> +;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org> +;;; +;;; 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 <http://www.gnu.org/licenses/>. + +(define-module (gnu machine) + #:use-module (gnu system) + #:use-module (guix derivations) + #:use-module (guix monads) + #:use-module (guix records) + #:use-module (guix store) + #:use-module ((guix utils) #:select (source-properties->location)) + #:export (environment-type + environment-type? + environment-type-name + environment-type-description + environment-type-location + + machine + machine? + this-machine + + machine-system + machine-environment + machine-configuration + machine-display-name + + deploy-machine + machine-remote-eval)) + +;;; Commentary: +;;; +;;; This module provides the types used to declare individual machines in a +;;; heterogeneous Guix deployment. The interface allows users of specify system +;;; configurations and the means by which resources should be provisioned on a +;;; per-host basis. +;;; +;;; Code: + +\f +;;; +;;; Declarations for resources that can be provisioned. +;;; + +(define-record-type* <environment-type> environment-type + make-environment-type + environment-type? + + ;; Interface to the environment type's deployment code. Each procedure + ;; should take the same arguments as the top-level procedure of this file + ;; that shares the same name. For example, 'machine-remote-eval' should be + ;; of the form '(machine-remote-eval machine exp)'. + (machine-remote-eval environment-type-machine-remote-eval) ; procedure + (deploy-machine environment-type-deploy-machine) ; procedure + + ;; Metadata. + (name environment-type-name) ; symbol + (description environment-type-description ; string + (default #f)) + (location environment-type-location ; <location> + (default (and=> (current-source-location) + source-properties->location)) + (innate))) + +\f +;;; +;;; Declarations for machines in a deployment. +;;; + +(define-record-type* <machine> machine + make-machine + machine? + this-machine + (system machine-system) ; <operating-system> + (environment machine-environment) ; symbol + (configuration machine-configuration ; configuration object + (default #f))) ; specific to environment + +(define (machine-display-name machine) + "Return the host-name identifying MACHINE." + (operating-system-host-name (machine-system machine))) + +(define (machine-remote-eval machine exp) + "Evaluate EXP, a gexp, on MACHINE. Ensure that all the elements EXP refers to +are built and deployed to MACHINE beforehand." + (let ((environment (machine-environment machine))) + ((environment-type-machine-remote-eval environment) machine exp))) + +(define (deploy-machine machine) + "Monadic procedure transferring the new system's OS closure to the remote +MACHINE, activating it on MACHINE and switching MACHINE to the new generation." + (let ((environment (machine-environment machine))) + ((environment-type-deploy-machine environment) machine))) diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm new file mode 100644 index 000000000..a7d1a967a --- /dev/null +++ b/gnu/machine/ssh.scm @@ -0,0 +1,369 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org> +;;; +;;; 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 <http://www.gnu.org/licenses/>. + +(define-module (gnu machine ssh) + #:use-module (gnu bootloader) + #:use-module (gnu machine) + #:autoload (gnu packages gnupg) (guile-gcrypt) + #:use-module (gnu services) + #:use-module (gnu services shepherd) + #:use-module (gnu system) + #: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 ssh) + #:use-module (guix store) + #:use-module (ice-9 match) + #:use-module (srfi srfi-19) + #:use-module (srfi srfi-35) + #:export (managed-host-environment-type + + machine-ssh-configuration + machine-ssh-configuration? + machine-ssh-configuration + + machine-ssh-configuration-host-name + machine-ssh-configuration-port + machine-ssh-configuration-user + machine-ssh-configuration-session)) + +;;; Commentary: +;;; +;;; This module implements remote evaluation and system deployment for +;;; machines that are accessable over SSH and have a known host-name. In the +;;; sense of the broader "machine" interface, we describe the environment for +;;; such machines as 'managed-host. +;;; +;;; Code: + +\f +;;; +;;; Parameters for the SSH client. +;;; + +(define-record-type* <machine-ssh-configuration> machine-ssh-configuration + make-machine-ssh-configuration + machine-ssh-configuration? + this-machine-ssh-configuration + (host-name machine-ssh-configuration-host-name) ; string + (port machine-ssh-configuration-port ; integer + (default 22)) + (user machine-ssh-configuration-user ; string + (default "root")) + (identity machine-ssh-configuration-identity ; path to a private key + (default #f)) + (session machine-ssh-configuration-session ; session + (default #f))) + +(define (machine-ssh-session machine) + "Return the SSH session that was given in MACHINE's configuration, or create +one from the configuration's parameters if one was not provided." + (maybe-raise-unsupported-configuration-error machine) + (let ((config (machine-configuration machine))) + (or (machine-ssh-configuration-session config) + (let ((host-name (machine-ssh-configuration-host-name config)) + (user (machine-ssh-configuration-user config)) + (port (machine-ssh-configuration-port config)) + (identity (machine-ssh-configuration-identity config))) + (open-ssh-session host-name + #:user user + #:port port + #:identity identity))))) + +\f +;;; +;;; Remote evaluation. +;;; + +(define (managed-host-remote-eval machine exp) + "Internal implementation of 'machine-remote-eval' for MACHINE instances with +an environment type of 'managed-host." + (maybe-raise-unsupported-configuration-error machine) + (remote-eval exp (machine-ssh-session machine))) + +\f +;;; +;;; 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." + (define bootable-kernel-arguments + (@@ (gnu system) bootable-kernel-arguments)) + + (define remote-exp + (with-extensions (list guile-gcrypt) + (with-imported-modules (source-module-closure '((guix config) + (guix profiles))) + #~(begin + (use-modules (guix config) + (guix profiles) + (ice-9 textual-ports)) + + (define %system-profile + (string-append %state-directory "/profiles/system")) + + (define (read-file path) + (call-with-input-file path + (lambda (port) + (get-string-all port)))) + + (map (lambda (generation) + (let* ((system-path (generation-file-name %system-profile + generation)) + (boot-parameters-path (string-append system-path + "/parameters")) + (time (stat:mtime (lstat system-path)))) + (list generation + system-path + time + (read-file boot-parameters-path)))) + (reverse (generation-numbers %system-profile))))))) + + (mlet* %store-monad ((generations (machine-remote-eval machine remote-exp))) + (return + (map (lambda (generation) + (match generation + ((generation system-path time serialized-params) + (let* ((params (call-with-input-string serialized-params + read-boot-parameters)) + (root (boot-parameters-root-device params)) + (label (boot-parameters-label params))) + (boot-parameters + (inherit params) + (label + (string-append label " (#" + (number->string generation) ", " + (let ((time (make-time time-utc 0 time))) + (date->string (time-utc->date time) + "~Y-~m-~d ~H:~M")) + ")")) + (kernel-arguments + (append (bootable-kernel-arguments system-path root) + (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))) + +\f +;;; +;;; Environment type. +;;; + +(define managed-host-environment-type + (environment-type + (machine-remote-eval managed-host-remote-eval) + (deploy-machine deploy-managed-host) + (name 'managed-host-environment-type) + (description "Provisioning for machines that are accessable over SSH +and have a known host-name. This entails little more than maintaining an SSH +connection to the host."))) + +(define (maybe-raise-unsupported-configuration-error machine) + "Raise an error if MACHINE's configuration is not an instance of +<machine-ssh-configuration>." + (let ((config (machine-configuration machine)) + (environment (environment-type-name (machine-environment machine)))) + (unless (and config (machine-ssh-configuration? config)) + (raise (condition + (&message + (message (format #f (G_ "unsupported machine configuration '~a' +for environment of type '~a'") + config + environment)))))))) diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in index ceee589b2..bcd6f7637 100644 --- a/po/guix/POTFILES.in +++ b/po/guix/POTFILES.in @@ -36,6 +36,7 @@ gnu/installer/steps.scm gnu/installer/timezone.scm gnu/installer/user.scm gnu/installer/utils.scm +gnu/machine/ssh.scm guix/scripts.scm guix/scripts/build.scm guix/discovery.scm -- 2.22.0 [-- Attachment #2: signature.asc --] [-- Type: application/pgp-signature, Size: 832 bytes --] ^ permalink raw reply related [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH v5 3/4] Add 'guix deploy'. 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 ` Jakob L. Kreuze 2019-07-05 18:57 ` [bug#36404] [PATCH v5 4/4] doc: Add section for " Jakob L. Kreuze 0 siblings, 1 reply; 84+ messages in thread From: Jakob L. Kreuze @ 2019-07-05 18:56 UTC (permalink / raw) To: Ludovic Courtès; +Cc: 36404 [-- Attachment #1: Type: text/plain, Size: 4252 bytes --] * guix/scripts/deploy.scm: New file. * Makefile.am (MODULES): Add it. --- Makefile.am | 1 + guix/scripts/deploy.scm | 84 +++++++++++++++++++++++++++++++++++++++++ po/guix/POTFILES.in | 1 + 3 files changed, 86 insertions(+) create mode 100644 guix/scripts/deploy.scm diff --git a/Makefile.am b/Makefile.am index f10c000ea..4d3024e58 100644 --- a/Makefile.am +++ b/Makefile.am @@ -267,6 +267,7 @@ MODULES = \ guix/scripts/weather.scm \ guix/scripts/container.scm \ guix/scripts/container/exec.scm \ + guix/scripts/deploy.scm \ guix.scm \ $(GNU_SYSTEM_MODULES) diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm new file mode 100644 index 000000000..978cfb2a8 --- /dev/null +++ b/guix/scripts/deploy.scm @@ -0,0 +1,84 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 David Thompson <davet@gnu.org> +;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org> +;;; +;;; 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 <http://www.gnu.org/licenses/>. + +(define-module (guix scripts deploy) + #:use-module (gnu machine) + #:use-module (guix scripts) + #:use-module (guix scripts build) + #:use-module (guix store) + #:use-module (guix ui) + #:use-module (ice-9 format) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-37) + #:export (guix-deploy)) + +;;; Commentary: +;;; +;;; This program provides a command-line interface to (gnu machine), allowing +;;; users to perform remote deployments through specification files. +;;; +;;; Code: + +\f + +(define (show-help) + (display (G_ "Usage: guix deploy [OPTION] FILE... +Perform the deployment specified by FILE.\n")) + (show-build-options-help) + (newline) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + (cons* (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + %standard-build-options)) + +(define %default-options + '((system . ,(%current-system)) + (substitutes? . #t) + (build-hook? . #t) + (graft? . #t) + (debug . 0) + (verbosity . 1))) + +(define (load-source-file file) + "Load FILE as a user module." + (let ((module (make-user-module '((gnu) (gnu machine) (gnu machine ssh))))) + (load* file module))) + +(define (guix-deploy . args) + (define (handle-argument arg result) + (alist-cons 'file arg result)) + (let* ((opts (parse-command-line args %options (list %default-options) + #:argument-handler handle-argument)) + (file (assq-ref opts 'file)) + (machines (or (and file (load-source-file file)) '()))) + (with-store store + (set-build-options-from-command-line store opts) + (for-each (lambda (machine) + (info (G_ "deploying to ~a...") (machine-display-name machine)) + (run-with-store store (deploy-machine machine))) + machines)))) diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in index bcd6f7637..f5fc4956b 100644 --- a/po/guix/POTFILES.in +++ b/po/guix/POTFILES.in @@ -67,6 +67,7 @@ guix/scripts/pack.scm guix/scripts/weather.scm guix/scripts/describe.scm guix/scripts/processes.scm +guix/scripts/deploy.scm guix/gnu-maintenance.scm guix/scripts/container.scm guix/scripts/container/exec.scm -- 2.22.0 [-- Attachment #2: signature.asc --] [-- Type: application/pgp-signature, Size: 832 bytes --] ^ permalink raw reply related [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH v5 4/4] doc: Add section for 'guix deploy'. 2019-07-05 18:56 ` [bug#36404] [PATCH v5 3/4] Add 'guix deploy' Jakob L. Kreuze @ 2019-07-05 18:57 ` Jakob L. Kreuze 2019-07-06 6:14 ` bug#36404: " Christopher Lemmer Webber 0 siblings, 1 reply; 84+ messages in thread From: Jakob L. Kreuze @ 2019-07-05 18:57 UTC (permalink / raw) To: Ludovic Courtès; +Cc: 36404 [-- Attachment #1: Type: text/plain, Size: 6719 bytes --] * doc/guix.texi: Add section "Invoking guix deploy". --- doc/guix.texi | 114 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 114 insertions(+) diff --git a/doc/guix.texi b/doc/guix.texi index 9dc1d2a9c..8d9b7c575 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -65,6 +65,7 @@ Copyright @copyright{} 2018 Alex Vong@* Copyright @copyright{} 2019 Josh Holland@* Copyright @copyright{} 2019 Diego Nicola Barbato@* Copyright @copyright{} 2019 Ivan Petkov@* +Copyright @copyright{} 2019 Jakob L. Kreuze@* Permission is granted to copy, distribute and/or modify this document under the terms of the GNU Free Documentation License, Version 1.3 or @@ -81,6 +82,7 @@ Documentation License''. * guix gc: (guix)Invoking guix gc. Reclaiming unused disk space. * guix pull: (guix)Invoking guix pull. Update the list of available packages. * guix system: (guix)Invoking guix system. Manage the operating system configuration. +* guix deploy: (guix)Invoking guix deploy. Manage operating system configurations for remote hosts. @end direntry @dircategory Software development @@ -269,6 +271,7 @@ System Configuration * Initial RAM Disk:: Linux-Libre bootstrapping. * Bootloader Configuration:: Configuring the boot loader. * Invoking guix system:: Instantiating a system configuration. +* Invoking guix deploy:: Deploying a system configuration to a remote host. * Running Guix in a VM:: How to run Guix System in a virtual machine. * Defining Services:: Adding new service definitions. @@ -10302,6 +10305,7 @@ instance to support new system services. * Initial RAM Disk:: Linux-Libre bootstrapping. * Bootloader Configuration:: Configuring the boot loader. * Invoking guix system:: Instantiating a system configuration. +* Invoking guix deploy:: Deploying a system configuration to a remote host. * Running Guix in a VM:: How to run Guix System in a virtual machine. * Defining Services:: Adding new service definitions. @end menu @@ -25335,6 +25339,116 @@ example graph. @end table +@node Invoking guix deploy +@section Invoking @code{guix deploy} + +We've already seen @code{operating-system} declarations used to manage a +machine's configuration locally. Suppose you need to configure multiple +machines, though---perhaps you're managing a service on the web that's +comprised of several servers. @command{guix deploy} enables you to use those +same @code{operating-system} declarations to manage multiple remote hosts at +once as a logical ``deployment''. + +@quotation Note +The functionality described in this section is still under development +and is subject to change. Get in touch with us on +@email{guix-devel@@gnu.org}! +@end quotation + +@example +guix deploy @var{file} +@end example + +Such an invocation will deploy the machines that the code within @var{file} +evaluates to. As an example, @var{file} might contain a definition like this: + +@example +;; This is a Guix deployment of a "bare bones" setup, with +;; no X11 display server, to a machine with an SSH daemon +;; listening on localhost:2222. A configuration such as this +;; may be appropriate for virtual machine with ports +;; forwarded to the host's loopback interface. + +(use-service-modules networking ssh) +(use-package-modules bootloaders) + +(define %system + (operating-system + (host-name "gnu-deployed") + (timezone "Etc/UTC") + (bootloader (bootloader-configuration + (bootloader grub-bootloader) + (target "/dev/vda") + (terminal-outputs '(console)))) + (file-systems (cons (file-system + (mount-point "/") + (device "/dev/vda1") + (type "ext4")) + %base-file-systems)) + (services + (append (list (service dhcp-client-service-type) + (service openssh-service-type + (openssh-configuration + (permit-root-login #t) + (allow-empty-passwords? #t)))) + %base-services)))) + +(list (machine + (system %system) + (environment managed-host-environment-type) + (configuration (machine-ssh-configuration + (host-name "localhost") + (identity "./id_rsa") + (port 2222))))) +@end example + +The file should evaluate to a list of @var{machine} objects. This example, +upon being deployed, will create a new generation on the remote system +realizing the @code{operating-system} declaration @var{%system}. +@var{environment} and @var{configuration} specify how the machine should be +provisioned---that is, how the computing resources should be created and +managed. The above example does not create any resources, as a +@code{'managed-host} is a machine that is already running the Guix system and +available over the network. This is a particularly simple case; a more +complex deployment may involve, for example, starting virtual machines through +a Virtual Private Server (VPS) provider. In such a case, a different +@var{environment} type would be used. + +@deftp {Data Type} machine +This is the data type representing a single machine in a heterogeneous Guix +deployment. + +@table @asis +@item @code{system} +The object of the operating system configuration to deploy. + +@item @code{environment} +An @code{environment-type} describing how the machine should be provisioned. +At the moment, the only supported value is +@code{managed-host-environment-type}. + +@item @code{configuration} (default: @code{#f}) +An object describing the configuration for the machine's @code{environment}. +If the @code{environment} has a default configuration, @code{#f} maybe used. +If @code{#f} is used for an environment with no default configuration, +however, an error will be thrown. +@end table +@end deftp + +@deftp {Data Type} machine-ssh-configuration +This is the data type representing the SSH client parameters for a machine +with an @code{environment} of @code{managed-host-environment-type}. + +@table @asis +@item @code{host-name} +@item @code{port} (default: @code{22}) +@item @code{user} (default: @code{"root"}) +@item @code{identity} (default: @code{#f}) +If specified, the path to the SSH private key to use to authenticate with the +remote host. +@end table +@end deftp + @node Running Guix in a VM @section Running Guix in a Virtual Machine -- 2.22.0 [-- Attachment #2: signature.asc --] [-- Type: application/pgp-signature, Size: 832 bytes --] ^ permalink raw reply related [flat|nested] 84+ messages in thread
* bug#36404: [PATCH v5 4/4] doc: Add section for 'guix deploy'. 2019-07-05 18:57 ` [bug#36404] [PATCH v5 4/4] doc: Add section for " Jakob L. Kreuze @ 2019-07-06 6:14 ` Christopher Lemmer Webber 2019-07-05 23:25 ` [bug#36404] " Jakob L. Kreuze 2019-07-06 21:50 ` Ludovic Courtès 0 siblings, 2 replies; 84+ messages in thread From: Christopher Lemmer Webber @ 2019-07-06 6:14 UTC (permalink / raw) To: Jakob L. Kreuze; +Cc: 36404-done Since those changes seemed to reflect everyone's requests, I've pushed it to git master. Huge congrats to Jakob! I'm stoked about it. Now who can race to the finish line to be the first one using these tools for their server deployment? :) ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH v5 4/4] doc: Add section for 'guix deploy'. 2019-07-06 6:14 ` bug#36404: " Christopher Lemmer Webber @ 2019-07-05 23:25 ` Jakob L. Kreuze 2019-07-06 21:50 ` Ludovic Courtès 1 sibling, 0 replies; 84+ messages in thread From: Jakob L. Kreuze @ 2019-07-05 23:25 UTC (permalink / raw) To: Christopher Lemmer Webber; +Cc: 36404-done [-- Attachment #1: Type: text/plain, Size: 379 bytes --] Christopher Lemmer Webber <cwebber@dustycloud.org> writes: > Since those changes seemed to reflect everyone's requests, I've pushed > it to git master. > > Huge congrats to Jakob! I'm stoked about it. > > Now who can race to the finish line to be the first one using these > tools for their server deployment? :) Thanks for committing the patch series, this is very exciting! [-- Attachment #2: signature.asc --] [-- Type: application/pgp-signature, Size: 832 bytes --] ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH v5 4/4] doc: Add section for 'guix deploy'. 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 1 sibling, 0 replies; 84+ messages in thread From: Ludovic Courtès @ 2019-07-06 21:50 UTC (permalink / raw) To: Christopher Lemmer Webber; +Cc: 36404-done Hi! Christopher Lemmer Webber <cwebber@dustycloud.org> skribis: > Since those changes seemed to reflect everyone's requests, I've pushed > it to git master. Thank you. > Huge congrats to Jakob! I'm stoked about it. Seconded! > Now who can race to the finish line to be the first one using these > tools for their server deployment? :) Heheh, we could put them to good use on the build farm… Cheers, Ludo’. ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH v4 1/4] ssh: Add 'identity' keyword to 'open-ssh-session'. 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-05 1:23 ` Thompson, David 1 sibling, 0 replies; 84+ messages in thread From: Thompson, David @ 2019-07-05 1:23 UTC (permalink / raw) To: Jakob L. Kreuze; +Cc: 36404 On Tue, Jul 2, 2019 at 1:56 PM Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org> wrote: > > * guix/ssh.scm (open-ssh-session): Add 'identity' keyword argument. > --- > guix/ssh.scm | 10 ++++++---- > 1 file changed, 6 insertions(+), 4 deletions(-) > > diff --git a/guix/ssh.scm b/guix/ssh.scm > index 9b9baf54e..9bf10b9a0 100644 > --- a/guix/ssh.scm > +++ b/guix/ssh.scm > @@ -57,12 +57,14 @@ > (define %compression > "zlib@openssh.com,zlib") > > -(define* (open-ssh-session host #:key user port > +(define* (open-ssh-session host #:key user port identity > (compression %compression)) > - "Open an SSH session for HOST and return it. When USER and PORT are #f, use > -default values or whatever '~/.ssh/config' specifies; otherwise use them. > -Throw an error on failure." > + "Open an SSH session for HOST and return it. IDENTITY specifies the path of Replace "path" with "file name". Lots of people use them interchangeably, but GNU makes a clear distinction between the two terms. > +a private key to use for authenticating with the host. When USER, PORT, or > +IDENTITY are #f, use default values or whatever '~/.ssh/config' specifies; > +otherwise use them. Throw an error on failure." > (let ((session (make-session #:user user > + #:identity identity > #:host host > #:port port > #:timeout 10 ;seconds > -- > 2.22.0 ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH 0/6] Add 'guix deploy'. 2019-06-27 18:35 [bug#36404] [PATCH 0/6] Add 'guix deploy' Jakob L. Kreuze ` (2 preceding siblings ...) 2019-06-29 14:37 ` [bug#36404] [PATCH 0/6] Add 'guix deploy' Christopher Lemmer Webber @ 2019-07-01 12:48 ` Ludovic Courtès 2019-07-05 10:32 ` [bug#36404] [PATCH v4 2/4] gnu: Add machine type for deployment specifications Christopher Lemmer Webber 4 siblings, 0 replies; 84+ messages in thread From: Ludovic Courtès @ 2019-07-01 12:48 UTC (permalink / raw) To: Jakob L. Kreuze; +Cc: 36404 Hello Jakob & all! zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) skribis: > This patch provides the basis for 'guix deploy', implementing what I've > referred to as the "simple case" in my progress reports: in-place > updates to machines (physical or virtual) whose name and IP address we > know well. Do note that these commits depend on Ludovic's implementation > of 'remote-eval'.[1] Woohoo! > There's certainly more to be done with this -- the GSoC period is far > from over, and I'm hoping to use that time to implement more complex > use-cases such as automatically provisioning virtual machines in the > cloud. I'm submitting a patch series now per the recommendation of my > mentors to break the project into a few chunks to submit over the > duration of the summer. That’s an impressive achievement! I’m all for integrating patches piecemeal, and it’s great that you’ve managed to have sizable chunks already. > Quite a bit has changed since my last email about this.[2] For one, > GOOPS is no longer used. Machine declarations now look just like any > other sort of declaration in Guix. Neat. I prefer it this way, at least for consistency. If for some reason this turns out to make extensibility more cumbersome, like Chris wrote, we can rediscuss it. My feeling is that we can make do without GOOPS _and_ without reimplementing GOOPS mechanisms in a poor way, but if that’s not the case, we can adjust. > (list (machine > (system %system) > (environment 'managed-host) > (configuration (machine-ssh-configuration > (host-name "localhost") > (identity "./id_rsa") > (port 2222))))) > #+END_SRC scheme > > There are a number of other differences here as well. For one, the SSH > configuration now has an 'identity' field for specifying a private key > to use when authenticating with the host. Any key management scheme you > might have set up in '~/.ssh/config' will also work if the 'identity' > field is omitted. > > The 'environment' field is where we declare how machines should be > provisioned. In this case, the only type of provisioning that's been > implemented is 'managed-host' -- the "simple case" of in-place updates > to a machine that's already running GuixSD. The parameters for > provisioning are given in the form of an environment-specific > configuration type. In the example, this is 'machine-ssh-configuration', > which describes how 'guix deploy' should make an SSH connection to the > machine. I'm sure you can imagine something along the lines of a > 'machine-digitalocean-configuration', describing some parameters for a > droplet. Nice. I’ll take a closer look and to comment on the other issues you raise, but so far this looks very nice! Thanks, Ludo’. ^ permalink raw reply [flat|nested] 84+ messages in thread
* [bug#36404] [PATCH v4 2/4] gnu: Add machine type for deployment specifications. 2019-06-27 18:35 [bug#36404] [PATCH 0/6] Add 'guix deploy' Jakob L. Kreuze ` (3 preceding siblings ...) 2019-07-01 12:48 ` [bug#36404] [PATCH 0/6] Add 'guix deploy' Ludovic Courtès @ 2019-07-05 10:32 ` Christopher Lemmer Webber 4 siblings, 0 replies; 84+ messages in thread From: Christopher Lemmer Webber @ 2019-07-05 10:32 UTC (permalink / raw) To: Jakob L. Kreuze; +Cc: 36404 References: <87o92ianbj.fsf@sdf.lonestar.org> <87o92glap5.fsf@dustycloud.org> <878sthoqzi.fsf@gnu.org> <87imsl9tsx.fsf_-_@sdf.lonestar.org> <87ef399tpu.fsf_-_@sdf.lonestar.org> <87a7dx9tog.fsf_-_@sdf.lonestar.org> <875zol9tn2.fsf_-_@sdf.lonestar.org> <871rz99tl9.fsf_-_@sdf.lonestar.org> <875zoldqah.fsf@kyleam.com> <87muhwtmfp.fsf@sdf.lonestar.org> <871rz874l2.fsf@kyleam.com> <877e90tj7l.fsf_-_@sdf.lonestar.org> <8736jotj5v.fsf_-_@sdf.lonestar.org> <87y31gs4k5.fsf_-_@sdf.lonestar.org> User-agent: mu4e 1.2.0; emacs 26.2 In-reply-to: <87y31gs4k5.fsf_-_@sdf.lonestar.org> Jakob L. Kreuze writes: > +(define-record-type* <environment-type> environment-type > + make-environment-type > + environment-type? > + > + ;; Interface to the environment type's deployment code. Each procedure > + ;; should take the same arguments as the top-level procedure of this file > + ;; that shares the same name. For example, 'machine-remote-eval' should be > + ;; of the form '(machine-remote-eval machine exp)'. > + (machine-remote-eval environment-type-machine-remote-eval) ; procedure > + (deploy-machine environment-type-deploy-machine) ; procedure > + > + ;; Metadata. > + (name environment-type-name) ; symbol > + (description environment-type-description ; string > + (default #f)) > + (location environment-type-location ; <location> > + (default (and=> (current-source-location) > + source-properties->location)) > + (innate))) Yeah! I think this is much nicer. :) > + > +\f > +;;; > +;;; Declarations for machines in a deployment. > +;;; > + > +(define-record-type* <machine> machine > + make-machine > + machine? > + this-machine > + (system machine-system) ; <operating-system> > + (environment machine-environment) ; symbol > + (configuration machine-configuration ; configuration object > + (default #f))) ; specific to environment > + > +(define (machine-display-name machine) > + "Return the host-name identifying MACHINE." > + (operating-system-host-name (machine-system machine))) > + > +(define (build-machine machine) > + "Monadic procedure that builds the system derivation for MACHINE and returning > +a list containing the path of the derivation file and the path of the derivation > +output." > + (let ((os (machine-system machine))) > + (mlet* %store-monad ((osdrv (operating-system-derivation os)) > + (_ ((store-lift build-derivations) (list osdrv)))) > + (return (list (derivation-file-name osdrv) > + (derivation->output-path osdrv)))))) > + > +(define (machine-remote-eval machine exp) > + "Evaluate EXP, a gexp, on MACHINE. Ensure that all the elements EXP refers to > +are built and deployed to MACHINE beforehand." > + (let ((environment (machine-environment machine))) > + ((environment-type-machine-remote-eval environment) machine exp))) > + > +(define (deploy-machine machine) > + "Monadic procedure transferring the new system's OS closure to the remote > +MACHINE, activating it on MACHINE and switching MACHINE to the new generation." > + (let ((environment (machine-environment machine))) > + ((environment-type-deploy-machine environment) machine))) Oooooh so much cleaner. Nice nice nice! I like this. > diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm > new file mode 100644 > index 000000000..6ce106bb2 > --- /dev/null > +++ b/gnu/machine/ssh.scm > @@ -0,0 +1,363 @@ > +;;; GNU Guix --- Functional package management for GNU > +;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org> > +;;; > +;;; 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 <http://www.gnu.org/licenses/>. > + > +(define-module (gnu machine ssh) > + #:use-module (gnu bootloader) > + #:use-module (gnu machine) > + #:autoload (gnu packages gnupg) (guile-gcrypt) > + #:use-module (gnu services) > + #:use-module (gnu services shepherd) > + #:use-module (gnu system) > + #: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 ssh) > + #:use-module (guix store) > + #:use-module (ice-9 match) > + #:use-module (srfi srfi-19) > + #:export (managed-host-environment-type > + > + machine-ssh-configuration > + machine-ssh-configuration? > + machine-ssh-configuration > + > + machine-ssh-configuration-host-name > + machine-ssh-configuration-port > + machine-ssh-configuration-user > + machine-ssh-configuration-session)) > + > +;;; Commentary: > +;;; > +;;; This module implements remote evaluation and system deployment for > +;;; machines that are accessable over SSH and have a known host-name. In the > +;;; sense of the broader "machine" interface, we describe the environment for > +;;; such machines as 'managed-host. > +;;; > +;;; Code: > + > +\f > +;;; > +;;; Parameters for the SSH client. > +;;; > + > +(define-record-type* <machine-ssh-configuration> machine-ssh-configuration > + make-machine-ssh-configuration > + machine-ssh-configuration? > + this-machine-ssh-configuration > + (host-name machine-ssh-configuration-host-name) ; string > + (port machine-ssh-configuration-port ; integer > + (default 22)) > + (user machine-ssh-configuration-user ; string > + (default "root")) > + (identity machine-ssh-configuration-identity ; path to a private key > + (default #f)) > + (session machine-ssh-configuration-session ; session > + (default #f))) > + > +(define (machine-ssh-session machine) > + "Return the SSH session that was given in MACHINE's configuration, or create > +one from the configuration's parameters if one was not provided." > + (let ((config (machine-configuration machine))) > + (if (machine-ssh-configuration? config) > + (or (machine-ssh-configuration-session config) > + (let ((host-name (machine-ssh-configuration-host-name config)) > + (user (machine-ssh-configuration-user config)) > + (port (machine-ssh-configuration-port config)) > + (identity (machine-ssh-configuration-identity config))) > + (open-ssh-session host-name > + #:user user > + #:port port > + #:identity identity))) > + (error "unsupported configuration type")))) > + > +\f > +;;; > +;;; Remote evaluation. > +;;; > + > +(define (managed-host-remote-eval machine exp) > + "Internal implementation of 'machine-remote-eval' for MACHINE instances with > +an environment type of 'managed-host." > + (maybe-raise-missing-configuration-error machine) > + (remote-eval exp (machine-ssh-session machine))) > + > +\f > +;;; > +;;; 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 #$(derivation->output-path 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." > + (define bootable-kernel-arguments > + (@@ (gnu system) bootable-kernel-arguments)) > + > + (define remote-exp > + (with-extensions (list guile-gcrypt) > + (with-imported-modules (source-module-closure '((guix config) > + (guix profiles))) > + #~(begin > + (use-modules (guix config) > + (guix profiles) > + (ice-9 textual-ports)) > + > + (define %system-profile > + (string-append %state-directory "/profiles/system")) > + > + (define (read-file path) > + (call-with-input-file path > + (lambda (port) > + (get-string-all port)))) > + > + (map (lambda (generation) > + (let* ((system-path (generation-file-name %system-profile > + generation)) > + (boot-parameters-path (string-append system-path > + "/parameters")) > + (time (stat:mtime (lstat system-path)))) > + (list generation > + system-path > + time > + (read-file boot-parameters-path)))) > + (reverse (generation-numbers %system-profile))))))) > + > + (mlet* %store-monad ((generations (machine-remote-eval machine remote-exp))) > + (return > + (map (lambda (generation) > + (match generation > + ((generation system-path time serialized-params) > + (let* ((params (call-with-input-string serialized-params > + read-boot-parameters)) > + (root (boot-parameters-root-device params)) > + (label (boot-parameters-label params))) > + (boot-parameters > + (inherit params) > + (label > + (string-append label " (#" > + (number->string generation) ", " > + (let ((time (make-time time-utc 0 time))) > + (date->string (time-utc->date time) > + "~Y-~m-~d ~H:~M")) > + ")")) > + (kernel-arguments > + (append (bootable-kernel-arguments system-path root) > + (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-missing-configuration-error machine) > + (mbegin %store-monad > + (switch-to-system machine) > + (upgrade-shepherd-services machine) > + (install-bootloader machine))) > + > +\f > +;;; > +;;; Environment type. > +;;; > + > +(define managed-host-environment-type > + (environment-type > + (machine-remote-eval managed-host-remote-eval) > + (deploy-machine deploy-managed-host) > + (name 'managed-host-environment-type) > + (description "Provisioning for machines that are accessable over SSH > +and have a known host-name. This entails little more than maintaining an SSH > +connection to the host."))) > + > +(define (maybe-raise-missing-configuration-error machine) > + "Raise an error if MACHINE's configuration is #f." > + (let ((environment (machine-environment machine))) > + (unless (machine-configuration machine) > + (error (format #f (G_ "no configuration specified for environment '~a'") > + (symbol->string (environment-type-name environment))))))) Yeah ok! This looks good to me. I think my issues are all addressed here. ^ permalink raw reply [flat|nested] 84+ messages in thread
end of thread, other threads:[~2019-07-08 19:23 UTC | newest]
Thread overview: 84+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
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 ` [bug#36404] [PATCH 2/3] machine: Reimplement 'managed-host-environment-type' deployment Jakob L. Kreuze
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
Code repositories for project(s) associated with this public inbox https://git.savannah.gnu.org/cgit/guix.git This is a public inbox, see mirroring instructions for how to clone and mirror all data and code used for this inbox; as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).