[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[bug#36404] [PATCH 2/5] gnu: Add machine type for deployment specificati
From: |
Christopher Lemmer Webber |
Subject: |
[bug#36404] [PATCH 2/5] gnu: Add machine type for deployment specifications. |
Date: |
Sat, 29 Jun 2019 17:36:31 -0400 |
User-agent: |
mu4e 1.2.0; emacs 26.2 |
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 <address@hidden>
> +;;; Copyright © 2019 Jakob L. Kreuze <address@hidden>
> +;;;
> +;;; 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 <address@hidden>
> +;;;
> +;;; 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:
> +
> +
> +;;;
> +;;; 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"))))
>
> +
> +;;;
> +;;; 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?
> +
> +
> +;;;
> +;;; 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 <address@hidden>
> +;;;
> +;;; 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...
> +
> +;;;
> +;;; 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)))))))))))
> +
> +
> +;;;
> +;;; 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)))))))))
> +
> +
> +;;;
> +;;; 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))))
> +
> +
> +(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.
- [bug#36404] [PATCH 4/6] Export the (gnu machine) interface., (continued)
[bug#36404] [PATCH 0/6] Add 'guix deploy'., Thompson, David, 2019/06/27
- [bug#36404] [PATCH 0/5] Add 'guix deploy'., Jakob L. Kreuze, 2019/06/28
- [bug#36404] [PATCH 1/5] ssh: Add 'identity' keyword to 'open-ssh-session'., Jakob L. Kreuze, 2019/06/28
- [bug#36404] [PATCH 2/5] gnu: Add machine type for deployment specifications., Jakob L. Kreuze, 2019/06/28
- [bug#36404] [PATCH 3/5] Add 'guix deploy'., Jakob L. Kreuze, 2019/06/28
- [bug#36404] [PATCH 4/5] Export the (gnu machine) interface., Jakob L. Kreuze, 2019/06/28
- [bug#36404] [PATCH 5/5] doc: Add section for 'guix deploy'., Jakob L. Kreuze, 2019/06/28
[bug#36404] [PATCH 2/5] gnu: Add machine type for deployment specifications.,
Christopher Lemmer Webber <=
[bug#36404] [PATCH 2/5] gnu: Add machine type for deployment specifications., Jakob L. Kreuze, 2019/06/29
[bug#36404] [PATCH 2/5] gnu: Add machine type for deployment specifications., Carlo Zancanaro, 2019/06/30
[bug#36404] [PATCH 2/5] gnu: Add machine type for deployment specifications., Christopher Lemmer Webber, 2019/06/30
[bug#36404] [PATCH 2/5] gnu: Add machine type for deployment specifications., Christopher Lemmer Webber, 2019/06/30
[bug#36404] [PATCH 1/5] ssh: Add 'identity' keyword to 'open-ssh-session'., Christopher Lemmer Webber, 2019/06/29
[bug#36404] [PATCH 1/5] ssh: Add 'identity' keyword to 'open-ssh-session'., Jakob L. Kreuze, 2019/06/29
[bug#36404] [PATCH 0/6] Add 'guix deploy'., Christopher Lemmer Webber, 2019/06/29