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

[Jakob L. Kreuze]

2019-06-26  Jakob L. Kreuze  <address@hidden>

* tests/machine.scm: New file.
* Makefile.am (SCM_TESTS): Add it.
* gnu/machine/ssh.scm: New file.
* gnu/local.mk (GNU_SYSTEM_MODULES): Add it.
* gnu/machine.scm (machine, sshable-machine): Delete.
* gnu/machine.scm: (machine): New record type.
* gnu/machine.scm: (display-name, build-os, deploy-os, host-name)
(ssh-port, ssh-user): Delete.
* gnu/machine.scm: (remote-eval): Rewrite procedure.
* gnu/machine.scm: (machine-display-name, build-machine)
(deploy-machine): New procedures.
All callers changed.
---
 Makefile.am             |   3 +-
 gnu/local.mk            |   4 +-
 gnu/machine.scm         | 140 ++++++++-----
 gnu/machine/ssh.scm     | 355 +++++++++++++++++++++++++++++++
 guix/scripts/deploy.scm |   8 +-
 tests/machine.scm       | 450 ++++++++++++++++++++++++++++++++++++++++
 6 files changed, 899 insertions(+), 61 deletions(-)
 create mode 100644 gnu/machine/ssh.scm
 create mode 100644 tests/machine.scm

diff --git a/Makefile.am b/Makefile.am
index ba01264a4b..8dbc220489 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -424,7 +424,8 @@ SCM_TESTS =                                 \
   tests/import-utils.scm                       \
   tests/store-database.scm                     \
   tests/store-deduplication.scm                        \
-  tests/store-roots.scm
+  tests/store-roots.scm                                \
+  tests/machine.scm
 
 SH_TESTS =                                     \
   tests/guix-build.sh                          \
diff --git a/gnu/local.mk b/gnu/local.mk
index f973a8d804..ad87de5ea7 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -563,7 +563,9 @@ GNU_SYSTEM_MODULES =                                \
   %D%/system/shadow.scm                                \
   %D%/system/uuid.scm                          \
   %D%/system/vm.scm                            \
-  %D%/machine.scm                      \
+                                               \
+  %D%/machine.scm                              \
+  %D%/machine/ssh.scm                          \
                                                \
   %D%/build/accounts.scm                       \
   %D%/build/activation.scm                     \
diff --git a/gnu/machine.scm b/gnu/machine.scm
index 4fde7d5c01..900a2020dc 100644
--- a/gnu/machine.scm
+++ b/gnu/machine.scm
@@ -1,59 +1,89 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 David Thompson <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 packages package-management) #:select (guix))
   #:use-module (gnu system)
   #:use-module (guix derivations)
-  #:use-module (guix inferior)
-  #:use-module (guix packages)
-  #:use-module (guix ssh)
+  #:use-module (guix monads)
+  #:use-module (guix records)
   #:use-module (guix store)
-  #:use-module (oop goops)
-  #:use-module (ssh session)
-  #:export (<machine>
-            system
-            display-name
-            build-os
-            deploy-os
-            remote-eval
-
-            <sshable-machine>
-            host-name
-            ssh-port
-            ssh-user))
-
-(define-class <machine> ()
-  (system #:getter system #:init-keyword #:system))
-
-(define-method (display-name (machine <machine>))
-  (operating-system-host-name (system machine)))
-
-(define-method (build-os (machine <machine>) store)
-  (let* ((guixdrv (run-with-store store (package->derivation guix)))
-         (guixdir (and (build-derivations store (list guixdrv))
-                       (derivation->output-path guixdrv)))
-         (osdrv (run-with-store store (operating-system-derivation
-                                       (system machine)))))
-    (and (build-derivations store (list osdrv))
-         (list (derivation-file-name osdrv)
-               (derivation->output-path osdrv)))))
-
-(define-method (deploy-os (machine <machine>) store osdrv)
-  (error "not implemented"))
-
-(define-method (remote-eval (machine <machine>) exp)
-  (error "not implemented"))
-
-(define-class <sshable-machine> (<machine>)
-  (host-name #:getter host-name #:init-keyword #:host-name)
-  (ssh-port #:getter ssh-port #:init-keyword #:ssh-port #:init-form 22)
-  (ssh-user #:getter ssh-user #:init-keyword #:ssh-user #:init-form "root")
-  ;; ??? - SSH key config?
-  )
-
-(define-method (deploy-os (machine <sshable-machine>) store osdrvs)
-  (let ((session (open-ssh-session (host-name machine)
-                                   #:user (ssh-user machine)
-                                   #:port (ssh-port machine))))
-    (with-store store (send-files store osdrvs
-                                  (connect-to-remote-daemon session)
-                                  #:recursive? #t))
-    #t))
+  #:export (machine
+            machine?
+            this-machine
+
+            machine-system
+            machine-environment
+            machine-configuration
+            machine-display-name
+
+            build-machine
+            deploy-machine
+            remote-eval))
+
+;;; Commentary:
+;;;
+;;; This module provides the types used to declare individual machines in a
+;;; heterogeneous Guix deployment. The interface allows users of specify system
+;;; configurations and the means by which resources should be provisioned on a
+;;; per-host basis.
+;;;
+;;; Code:
+
+(define-record-type* <machine> machine
+  make-machine
+  machine?
+  this-machine
+  (system        machine-system)       ; <operating-system>
+  (environment   machine-environment)  ; symbol
+  (configuration machine-configuration ; configuration object
+                 (default #f)))        ; specific to environment
+
+(define (machine-display-name machine)
+  "Return the host-name identifying MACHINE."
+  (operating-system-host-name (machine-system machine)))
+
+(define (build-machine machine)
+  "Monadic procedure that builds the system derivation for MACHINE and 
returning
+a list containing the path of the derivation file and the path of the 
derivation
+output."
+  (let ((os (machine-system machine)))
+    (mlet* %store-monad ((osdrv (operating-system-derivation os))
+                         (_ ((store-lift build-derivations) (list osdrv))))
+      (return (list (derivation-file-name osdrv)
+                    (derivation->output-path osdrv))))))
+
+(define (remote-eval machine exp)
+  "Evaluate EXP, a gexp, on MACHINE. Ensure that all the elements EXP refers to
+are built and deployed to MACHINE beforehand."
+  (case (machine-environment machine)
+    ((managed-host)
+     ((@@ (gnu machine ssh) remote-eval) machine exp))
+    (else
+     (let ((type (machine-environment machine)))
+       (error "unsupported environment type" type)))))
+
+(define (deploy-machine machine)
+  "Monadic procedure transferring the new system's OS closure to the remote
+MACHINE, activating it on MACHINE and switching MACHINE to the new generation."
+  (case (machine-environment machine)
+    ((managed-host)
+     ((@@ (gnu machine ssh) deploy-machine) machine))
+    (else
+     (let ((type (machine-environment machine)))
+       (error "unsupported environment type" type)))))
diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm
new file mode 100644
index 0000000000..a8f946e19f
--- /dev/null
+++ b/gnu/machine/ssh.scm
@@ -0,0 +1,355 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 Jakob L. Kreuze <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)
+        (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)))
+
+
+;;;
+;;; System deployment.
+;;;
+
+(define (switch-to-system machine)
+  "Monadic procedure creating a new generation on MACHINE and execute the
+activation script for the new system configuration."
+  (define (remote-exp drv script)
+    (with-extensions (list guile-gcrypt)
+      (with-imported-modules (source-module-closure '((guix config)
+                                                      (guix profiles)
+                                                      (guix utils)))
+        #~(begin
+            (use-modules (guix config)
+                         (guix profiles)
+                         (guix utils))
+
+            (define %system-profile
+              (string-append %state-directory "/profiles/system"))
+
+            (let* ((system #$(derivation->output-path drv))
+                   (number (1+ (generation-number %system-profile)))
+                   (generation (generation-file-name %system-profile number))
+                   (old-env (environ))
+                   (old-path %load-path)
+                   (old-cpath %load-compiled-path))
+              (switch-symlinks generation system)
+              (switch-symlinks %system-profile generation)
+              ;; Guard against the activation script modifying $PATH.
+              (dynamic-wind
+                (const #t)
+                (lambda ()
+                  (setenv "GUIX_NEW_SYSTEM" system)
+                  ;; Guard against the activation script modifying 
'%load-path'.
+                  (dynamic-wind
+                    (const #t)
+                    (lambda ()
+                      ;; The activation script may write to stdout, which
+                      ;; confuses 'remote-eval' when it attempts to read a
+                      ;; result from the remote REPL. We work around this by
+                      ;; forcing the output to a string.
+                      (with-output-to-string
+                        (lambda ()
+                          (primitive-load #$script))))
+                    (lambda ()
+                      (set! %load-path old-path)
+                      (set! %load-compiled-path old-cpath))))
+                (lambda ()
+                  (environ old-env))))))))
+
+  (let* ((os (machine-system machine))
+         (script (operating-system-activation-script os)))
+    (mlet* %store-monad ((drv (operating-system-derivation os)))
+      (remote-eval machine (remote-exp drv script)))))
+
+(define (upgrade-shepherd-services machine)
+  "Monadic procedure unloading and starting services on the remote as needed
+to realize the MACHINE's system configuration."
+  (define target-services
+    ;; Monadic expression evaluating to a list of (name output-path) pairs for
+    ;; all of MACHINE's services.
+    (mapm %store-monad
+          (lambda (service)
+            (mlet %store-monad ((file ((compose lower-object
+                                                shepherd-service-file)
+                                       service)))
+              (return (list (shepherd-service-canonical-name service)
+                            (derivation->output-path file)))))
+          (service-value
+           (fold-services (operating-system-services (machine-system machine))
+                          #:target-type shepherd-root-service-type))))
+
+  (define (remote-exp target-services)
+    (with-imported-modules '((gnu services herd))
+      #~(begin
+          (use-modules (gnu services herd)
+                       (srfi srfi-1))
+
+          (define running
+            (filter live-service-running (current-services)))
+
+          (define (essential? service)
+            ;; Return #t if SERVICE is essential and should not be unloaded
+            ;; under any circumstance.
+            (memq (first (live-service-provision service))
+                  '(root shepherd)))
+
+          (define (obsolete? service)
+            ;; Return #t if SERVICE can be safely unloaded.
+            (and (not (essential? service))
+                 (every (lambda (requirements)
+                          (not (memq (first (live-service-provision service))
+                                     requirements)))
+                        (map live-service-requirement running))))
+
+          (define to-unload
+            (filter obsolete?
+                    (remove (lambda (service)
+                              (memq (first (live-service-provision service))
+                                    (map first '#$target-services)))
+                            running)))
+
+          (define to-start
+            (remove (lambda (service-pair)
+                      (memq (first service-pair)
+                            (map (compose first live-service-provision)
+                                 running)))
+                    '#$target-services))
+
+          ;; Unload obsolete services.
+          (for-each (lambda (service)
+                      (false-if-exception
+                       (unload-service service)))
+                    to-unload)
+
+          ;; Load the service files for any new services and start them.
+          (load-services/safe (map second to-start))
+          (for-each start-service (map first to-start))
+
+          #t)))
+
+  (mlet %store-monad ((target-services target-services))
+    (remote-eval machine (remote-exp target-services))))
+
+(define (machine-boot-parameters machine)
+  "Monadic procedure returning a list of 'boot-parameters' for the generations
+of MACHINE's system profile, ordered from most recent to oldest."
+  (define bootable-kernel-arguments
+    (@@ (gnu system) bootable-kernel-arguments))
+
+  (define remote-exp
+    (with-extensions (list guile-gcrypt)
+      (with-imported-modules (source-module-closure '((guix config)
+                                                      (guix profiles)))
+        #~(begin
+            (use-modules (guix config)
+                         (guix profiles)
+                         (ice-9 textual-ports))
+
+            (define %system-profile
+              (string-append %state-directory "/profiles/system"))
+
+            (define (read-file path)
+              (call-with-input-file path
+                (lambda (port)
+                  (get-string-all port))))
+
+            (map (lambda (generation)
+                   (let* ((system-path (generation-file-name %system-profile
+                                                             generation))
+                          (boot-parameters-path (string-append system-path
+                                                               "/parameters"))
+                          (time (stat:mtime (lstat system-path))))
+                     (list generation
+                           system-path
+                           time
+                           (read-file boot-parameters-path))))
+                 (reverse (generation-numbers %system-profile)))))))
+
+  (mlet* %store-monad ((generations (remote-eval machine remote-exp)))
+    (return
+     (map (lambda (generation)
+            (match generation
+              ((generation system-path time serialized-params)
+               (let* ((params (call-with-input-string serialized-params
+                                read-boot-parameters))
+                      (root (boot-parameters-root-device params))
+                      (label (boot-parameters-label params)))
+                 (boot-parameters
+                  (inherit params)
+                  (label
+                   (string-append label " (#"
+                                  (number->string generation) ", "
+                                  (let ((time (make-time time-utc 0 time)))
+                                    (date->string (time-utc->date time)
+                                                  "~Y-~m-~d ~H:~M"))
+                                  ")"))
+                  (kernel-arguments
+                   (append (bootable-kernel-arguments system-path root)
+                           (boot-parameters-kernel-arguments params))))))))
+          generations))))
+
+(define (install-bootloader machine)
+  "Create a bootloader entry for the new system generation on MACHINE, and
+configure the bootloader to boot that generation by default."
+  (define bootloader-installer-script
+    (@@ (guix scripts system) bootloader-installer-script))
+
+  (define (remote-exp installer bootcfg bootcfg-file)
+    (with-extensions (list guile-gcrypt)
+      (with-imported-modules (source-module-closure '((gnu build install)
+                                                      (guix store)
+                                                      (guix utils)))
+        #~(begin
+            (use-modules (gnu build install)
+                         (guix store)
+                         (guix utils))
+            (let* ((gc-root (string-append "/" %gc-roots-directory "/bootcfg"))
+                   (temp-gc-root (string-append gc-root ".new"))
+                   (old-path %load-path)
+                   (old-cpath %load-compiled-path))
+              (switch-symlinks temp-gc-root gc-root)
+
+              (unless (false-if-exception
+                       (begin
+                         (install-boot-config #$bootcfg #$bootcfg-file "/")
+                         ;; Guard against the activation script modifying
+                         ;; '%load-path'.
+                         (dynamic-wind
+                           (const #t)
+                           (lambda ()
+                             ;; The installation script may write to stdout,
+                             ;; which confuses 'remote-eval' when it attempts 
to
+                             ;; read a result from the remote REPL. We work
+                             ;; around this by forcing the output to a string.
+                             (with-output-to-string
+                               (lambda ()
+                                 (primitive-load #$installer))))
+                           (lambda ()
+                             (set! %load-path old-path)
+                             (set! %load-compiled-path old-cpath)))))
+                (delete-file temp-gc-root)
+                (error "failed to install bootloader"))
+
+              (rename-file temp-gc-root gc-root)
+              #t)))))
+
+  (mlet* %store-monad ((boot-parameters (machine-boot-parameters machine)))
+    (let* ((os (machine-system machine))
+           (bootloader ((compose bootloader-configuration-bootloader
+                                 operating-system-bootloader)
+                        os))
+           (bootloader-target (bootloader-configuration-target
+                               (operating-system-bootloader os)))
+           (installer (bootloader-installer-script
+                       (bootloader-installer bootloader)
+                       (bootloader-package bootloader)
+                       bootloader-target
+                       "/"))
+           (menu-entries (map boot-parameters->menu-entry boot-parameters))
+           (bootcfg (operating-system-bootcfg os menu-entries))
+           (bootcfg-file (bootloader-configuration-file bootloader)))
+      (remote-eval machine (remote-exp installer bootcfg bootcfg-file)))))
+
+(define (deploy-machine machine)
+  "Internal implementation of 'deploy-machine' for MACHINE instances with an
+environment type of 'managed-host."
+  (unless (machine-configuration machine)
+    (error (format #f (G_ "no configuration specified for machine of 
environment '~a'")
+                   (symbol->string (machine-environment machine)))))
+  (mbegin %store-monad
+    (switch-to-system machine)
+    (upgrade-shepherd-services machine)
+    (install-bootloader machine)))
diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm
index bcb3a2ea4c..0be279642b 100644
--- a/guix/scripts/deploy.scm
+++ b/guix/scripts/deploy.scm
@@ -64,13 +64,13 @@
       ;; Build all the OSes and create a mapping from machine to OS derivation
       ;; for use in the deploy step.
       (let ((osdrvs (map (lambda (machine)
-                           (format #t "building ~a... " (display-name machine))
-                           (let ((osdrv (build-os machine store)))
+                           (format #t "building ~a... " (machine-display-name 
machine))
+                           (let ((osdrv (run-with-store store (build-machine 
machine))))
                              (display "done\n")
                              (cons machine osdrv)))
                          machines)))
         (for-each (lambda (machine)
-                    (format #t "deploying to ~a... " (display-name machine))
-                    (deploy-os machine store (assq-ref osdrvs machine))
+                    (format #t "deploying to ~a... " (machine-display-name 
machine))
+                    (run-with-store store (deploy-machine machine))
                     (display "done\n"))
                   machines)))))
diff --git a/tests/machine.scm b/tests/machine.scm
new file mode 100644
index 0000000000..390c0189bb
--- /dev/null
+++ b/tests/machine.scm
@@ -0,0 +1,450 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 Jakob L. Kreuze <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))
+
+
+;;;
+;;; 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")
-- 
2.22.0