Package: guix-patches;
Reported by: zerodaysfordays <at> sdf.lonestar.org (Jakob L. Kreuze)
Date: Thu, 27 Jun 2019 18:38:02 UTC
Severity: normal
Tags: patch
Done: Christopher Lemmer Webber <cwebber <at> dustycloud.org>
Bug is archived. No further changes may be made.
View this message in rfc822 format
From: Christopher Lemmer Webber <cwebber <at> dustycloud.org> To: 36404 <at> debbugs.gnu.org Cc: dthompson2 <at> worcester.edu Subject: [bug#36404] [PATCH 2/5] gnu: Add machine type for deployment specifications. Date: Sat, 29 Jun 2019 17:36:31 -0400
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 <at> gnu.org>
> +;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays <at> 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 <at> 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:
> +
> +
> +;;;
> +;;; 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 <zerodaysfordays <at> 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...
> +
> +;;;
> +;;; 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.
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.