[bug#36404] [PATCH 2/5] gnu: Add machine type for deployment specifications.

[Christopher Lemmer Webber]

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.