gnu: Add machine type for deployment specifications.

* gnu/machine.scm: New file.
* gnu/machine/ssh.scm: New file.
* gnu/local.mk (GNU_SYSTEM_MODULES): Add it.

5 files changed, 483 insertions, 2 deletions

diff --git a/Makefile.am b/Makefile.am
index 31430545cb..beb60097a4 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -425,7 +425,8 @@ SCM_TESTS =					\
   tests/import-utils.scm			\
   tests/store-database.scm			\
   tests/store-deduplication.scm			\
-  tests/store-roots.scm
+  tests/store-roots.scm				\
+  tests/machine.scm
 
 SH_TESTS =					\
   tests/guix-build.sh				\
diff --git a/gnu/local.mk b/gnu/local.mk
index 8d7760cf46..68a43330c4 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -565,6 +565,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			\
@@ -630,7 +633,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..0b79402b0a
--- /dev/null
+++ b/gnu/machine.scm
@@ -0,0 +1,107 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 David Thompson <davet@gnu.org>
+;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu machine)
+  #:use-module (gnu system)
+  #:use-module (guix derivations)
+  #:use-module (guix monads)
+  #:use-module (guix records)
+  #:use-module (guix store)
+  #:use-module ((guix utils) #:select (source-properties->location))
+  #:export (environment-type
+            environment-type?
+            environment-type-name
+            environment-type-description
+            environment-type-location
+
+            machine
+            machine?
+            this-machine
+
+            machine-system
+            machine-environment
+            machine-configuration
+            machine-display-name
+
+            deploy-machine
+            machine-remote-eval))
+
+;;; Commentary:
+;;;
+;;; This module provides the types used to declare individual machines in a
+;;; heterogeneous Guix deployment. The interface allows users of specify system
+;;; configurations and the means by which resources should be provisioned on a
+;;; per-host basis.
+;;;
+;;; Code:
+
+
+;;;
+;;; Declarations for resources that can be provisioned.
+;;;
+
+(define-record-type* <environment-type> environment-type
+  make-environment-type
+  environment-type?
+
+  ;; Interface to the environment type's deployment code. Each procedure
+  ;; should take the same arguments as the top-level procedure of this file
+  ;; that shares the same name. For example, 'machine-remote-eval' should be
+  ;; of the form '(machine-remote-eval machine exp)'.
+  (machine-remote-eval environment-type-machine-remote-eval) ; procedure
+  (deploy-machine      environment-type-deploy-machine)      ; procedure
+
+  ;; Metadata.
+  (name        environment-type-name)       ; symbol
+  (description environment-type-description ; string
+               (default #f))
+  (location    environment-type-location    ; <location>
+               (default (and=> (current-source-location)
+                               source-properties->location))
+               (innate)))
+
+
+;;;
+;;; Declarations for machines in a deployment.
+;;;
+
+(define-record-type* <machine> machine
+  make-machine
+  machine?
+  this-machine
+  (system        machine-system)       ; <operating-system>
+  (environment   machine-environment)  ; symbol
+  (configuration machine-configuration ; configuration object
+                 (default #f)))        ; specific to environment
+
+(define (machine-display-name machine)
+  "Return the host-name identifying MACHINE."
+  (operating-system-host-name (machine-system machine)))
+
+(define (machine-remote-eval machine exp)
+  "Evaluate EXP, a gexp, on MACHINE. Ensure that all the elements EXP refers to
+are built and deployed to MACHINE beforehand."
+  (let ((environment (machine-environment machine)))
+    ((environment-type-machine-remote-eval environment) machine exp)))
+
+(define (deploy-machine machine)
+  "Monadic procedure transferring the new system's OS closure to the remote
+MACHINE, activating it on MACHINE and switching MACHINE to the new generation."
+  (let ((environment (machine-environment machine)))
+    ((environment-type-deploy-machine environment) machine)))
diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm
new file mode 100644
index 0000000000..a7d1a967ae
--- /dev/null
+++ b/gnu/machine/ssh.scm
@@ -0,0 +1,369 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu machine ssh)
+  #:use-module (gnu bootloader)
+  #:use-module (gnu machine)
+  #:autoload   (gnu packages gnupg) (guile-gcrypt)
+  #:use-module (gnu services)
+  #:use-module (gnu services shepherd)
+  #:use-module (gnu system)
+  #:use-module (guix derivations)
+  #:use-module (guix gexp)
+  #:use-module (guix i18n)
+  #:use-module (guix modules)
+  #:use-module (guix monads)
+  #:use-module (guix records)
+  #:use-module (guix remote)
+  #:use-module (guix ssh)
+  #:use-module (guix store)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-19)
+  #:use-module (srfi srfi-35)
+  #:export (managed-host-environment-type
+
+            machine-ssh-configuration
+            machine-ssh-configuration?
+            machine-ssh-configuration
+
+            machine-ssh-configuration-host-name
+            machine-ssh-configuration-port
+            machine-ssh-configuration-user
+            machine-ssh-configuration-session))
+
+;;; Commentary:
+;;;
+;;; This module implements remote evaluation and system deployment for
+;;; machines that are accessable over SSH and have a known host-name. In the
+;;; sense of the broader "machine" interface, we describe the environment for
+;;; such machines as 'managed-host.
+;;;
+;;; Code:
+
+
+;;;
+;;; Parameters for the SSH client.
+;;;
+
+(define-record-type* <machine-ssh-configuration> machine-ssh-configuration
+  make-machine-ssh-configuration
+  machine-ssh-configuration?
+  this-machine-ssh-configuration
+  (host-name machine-ssh-configuration-host-name) ; string
+  (port      machine-ssh-configuration-port       ; integer
+             (default 22))
+  (user      machine-ssh-configuration-user       ; string
+             (default "root"))
+  (identity  machine-ssh-configuration-identity   ; path to a private key
+             (default #f))
+  (session   machine-ssh-configuration-session    ; session
+             (default #f)))
+
+(define (machine-ssh-session machine)
+  "Return the SSH session that was given in MACHINE's configuration, or create
+one from the configuration's parameters if one was not provided."
+  (maybe-raise-unsupported-configuration-error machine)
+  (let ((config (machine-configuration machine)))
+    (or (machine-ssh-configuration-session config)
+        (let ((host-name (machine-ssh-configuration-host-name config))
+              (user (machine-ssh-configuration-user config))
+              (port (machine-ssh-configuration-port config))
+              (identity (machine-ssh-configuration-identity config)))
+          (open-ssh-session host-name
+                            #:user user
+                            #:port port
+                            #:identity identity)))))
+
+
+;;;
+;;; Remote evaluation.
+;;;
+
+(define (managed-host-remote-eval machine exp)
+  "Internal implementation of 'machine-remote-eval' for MACHINE instances with
+an environment type of 'managed-host."
+  (maybe-raise-unsupported-configuration-error machine)
+  (remote-eval exp (machine-ssh-session machine)))
+
+
+;;;
+;;; System deployment.
+;;;
+
+(define (switch-to-system machine)
+  "Monadic procedure creating a new generation on MACHINE and execute the
+activation script for the new system configuration."
+  (define (remote-exp drv script)
+    (with-extensions (list guile-gcrypt)
+      (with-imported-modules (source-module-closure '((guix config)
+                                                      (guix profiles)
+                                                      (guix utils)))
+        #~(begin
+            (use-modules (guix config)
+                         (guix profiles)
+                         (guix utils))
+
+            (define %system-profile
+              (string-append %state-directory "/profiles/system"))
+
+            (let* ((system #$drv)
+                   (number (1+ (generation-number %system-profile)))
+                   (generation (generation-file-name %system-profile number)))
+              (switch-symlinks generation system)
+              (switch-symlinks %system-profile generation)
+              ;; The implementation of 'guix system reconfigure' saves the
+              ;; load path and environment here. This is unnecessary here
+              ;; because each invocation of 'remote-eval' runs in a distinct
+              ;; Guile REPL.
+              (setenv "GUIX_NEW_SYSTEM" system)
+              ;; The activation script may write to stdout, which confuses
+              ;; 'remote-eval' when it attempts to read a result from the
+              ;; remote REPL. We work around this by forcing the output to a
+              ;; string.
+              (with-output-to-string
+                (lambda ()
+                  (primitive-load #$script))))))))
+
+  (let* ((os (machine-system machine))
+         (script (operating-system-activation-script os)))
+    (mlet* %store-monad ((drv (operating-system-derivation os)))
+      (machine-remote-eval machine (remote-exp drv script)))))
+
+;; XXX: Currently, this does NOT attempt to restart running services. This is
+;; also the case with 'guix system reconfigure'.
+;;
+;; See <https://issues.guix.info/issue/33508>.
+(define (upgrade-shepherd-services machine)
+  "Monadic procedure unloading and starting services on the remote as needed
+to realize the MACHINE's system configuration."
+  (define target-services
+    ;; Monadic expression evaluating to a list of (name output-path) pairs for
+    ;; all of MACHINE's services.
+    (mapm %store-monad
+          (lambda (service)
+            (mlet %store-monad ((file ((compose lower-object
+                                                shepherd-service-file)
+                                       service)))
+              (return (list (shepherd-service-canonical-name service)
+                            (derivation->output-path file)))))
+          (service-value
+           (fold-services (operating-system-services (machine-system machine))
+                          #:target-type shepherd-root-service-type))))
+
+  (define (remote-exp target-services)
+    (with-imported-modules '((gnu services herd))
+      #~(begin
+          (use-modules (gnu services herd)
+                       (srfi srfi-1))
+
+          (define running
+            (filter live-service-running (current-services)))
+
+          (define (essential? service)
+            ;; Return #t if SERVICE is essential and should not be unloaded
+            ;; under any circumstance.
+            (memq (first (live-service-provision service))
+                  '(root shepherd)))
+
+          (define (obsolete? service)
+            ;; Return #t if SERVICE can be safely unloaded.
+            (and (not (essential? service))
+                 (every (lambda (requirements)
+                          (not (memq (first (live-service-provision service))
+                                     requirements)))
+                        (map live-service-requirement running))))
+
+          (define to-unload
+            (filter obsolete?
+                    (remove (lambda (service)
+                              (memq (first (live-service-provision service))
+                                    (map first '#$target-services)))
+                            running)))
+
+          (define to-start
+            (remove (lambda (service-pair)
+                      (memq (first service-pair)
+                            (map (compose first live-service-provision)
+                                 running)))
+                    '#$target-services))
+
+          ;; Unload obsolete services.
+          (for-each (lambda (service)
+                      (false-if-exception
+                       (unload-service service)))
+                    to-unload)
+
+          ;; Load the service files for any new services and start them.
+          (load-services/safe (map second to-start))
+          (for-each start-service (map first to-start))
+
+          #t)))
+
+  (mlet %store-monad ((target-services target-services))
+    (machine-remote-eval machine (remote-exp target-services))))
+
+(define (machine-boot-parameters machine)
+  "Monadic procedure returning a list of 'boot-parameters' for the generations
+of MACHINE's system profile, ordered from most recent to oldest."
+  (define bootable-kernel-arguments
+    (@@ (gnu system) bootable-kernel-arguments))
+
+  (define remote-exp
+    (with-extensions (list guile-gcrypt)
+      (with-imported-modules (source-module-closure '((guix config)
+                                                      (guix profiles)))
+        #~(begin
+            (use-modules (guix config)
+                         (guix profiles)
+                         (ice-9 textual-ports))
+
+            (define %system-profile
+              (string-append %state-directory "/profiles/system"))
+
+            (define (read-file path)
+              (call-with-input-file path
+                (lambda (port)
+                  (get-string-all port))))
+
+            (map (lambda (generation)
+                   (let* ((system-path (generation-file-name %system-profile
+                                                             generation))
+                          (boot-parameters-path (string-append system-path
+                                                               "/parameters"))
+                          (time (stat:mtime (lstat system-path))))
+                     (list generation
+                           system-path
+                           time
+                           (read-file boot-parameters-path))))
+                 (reverse (generation-numbers %system-profile)))))))
+
+  (mlet* %store-monad ((generations (machine-remote-eval machine remote-exp)))
+    (return
+     (map (lambda (generation)
+            (match generation
+              ((generation system-path time serialized-params)
+               (let* ((params (call-with-input-string serialized-params
+                                read-boot-parameters))
+                      (root (boot-parameters-root-device params))
+                      (label (boot-parameters-label params)))
+                 (boot-parameters
+                  (inherit params)
+                  (label
+                   (string-append label " (#"
+                                  (number->string generation) ", "
+                                  (let ((time (make-time time-utc 0 time)))
+                                    (date->string (time-utc->date time)
+                                                  "~Y-~m-~d ~H:~M"))
+                                  ")"))
+                  (kernel-arguments
+                   (append (bootable-kernel-arguments system-path root)
+                           (boot-parameters-kernel-arguments params))))))))
+          generations))))
+
+(define (install-bootloader machine)
+  "Create a bootloader entry for the new system generation on MACHINE, and
+configure the bootloader to boot that generation by default."
+  (define bootloader-installer-script
+    (@@ (guix scripts system) bootloader-installer-script))
+
+  (define (remote-exp installer bootcfg bootcfg-file)
+    (with-extensions (list guile-gcrypt)
+      (with-imported-modules (source-module-closure '((gnu build install)
+                                                      (guix store)
+                                                      (guix utils)))
+        #~(begin
+            (use-modules (gnu build install)
+                         (guix store)
+                         (guix utils))
+            (let* ((gc-root (string-append "/" %gc-roots-directory "/bootcfg"))
+                   (temp-gc-root (string-append gc-root ".new")))
+
+              (switch-symlinks temp-gc-root gc-root)
+
+              (unless (false-if-exception
+                       (begin
+                         ;; The implementation of 'guix system reconfigure'
+                         ;; saves the load path here. This is unnecessary here
+                         ;; because each invocation of 'remote-eval' runs in a
+                         ;; distinct Guile REPL.
+                         (install-boot-config #$bootcfg #$bootcfg-file "/")
+                         ;; The installation script may write to stdout, which
+                         ;; confuses 'remote-eval' when it attempts to read a
+                         ;; result from the remote REPL. We work around this
+                         ;; by forcing the output to a string.
+                         (with-output-to-string
+                           (lambda ()
+                             (primitive-load #$installer)))))
+                (delete-file temp-gc-root)
+                (error "failed to install bootloader"))
+
+              (rename-file temp-gc-root gc-root)
+              #t)))))
+
+  (mlet* %store-monad ((boot-parameters (machine-boot-parameters machine)))
+    (let* ((os (machine-system machine))
+           (bootloader ((compose bootloader-configuration-bootloader
+                                 operating-system-bootloader)
+                        os))
+           (bootloader-target (bootloader-configuration-target
+                               (operating-system-bootloader os)))
+           (installer (bootloader-installer-script
+                       (bootloader-installer bootloader)
+                       (bootloader-package bootloader)
+                       bootloader-target
+                       "/"))
+           (menu-entries (map boot-parameters->menu-entry boot-parameters))
+           (bootcfg (operating-system-bootcfg os menu-entries))
+           (bootcfg-file (bootloader-configuration-file bootloader)))
+      (machine-remote-eval machine (remote-exp installer bootcfg bootcfg-file)))))
+
+(define (deploy-managed-host machine)
+  "Internal implementation of 'deploy-machine' for MACHINE instances with an
+environment type of 'managed-host."
+  (maybe-raise-unsupported-configuration-error machine)
+  (mbegin %store-monad
+    (switch-to-system machine)
+    (upgrade-shepherd-services machine)
+    (install-bootloader machine)))
+
+
+;;;
+;;; Environment type.
+;;;
+
+(define managed-host-environment-type
+  (environment-type
+   (machine-remote-eval managed-host-remote-eval)
+   (deploy-machine      deploy-managed-host)
+   (name                'managed-host-environment-type)
+   (description         "Provisioning for machines that are accessable over SSH
+and have a known host-name. This entails little more than maintaining an SSH
+connection to the host.")))
+
+(define (maybe-raise-unsupported-configuration-error machine)
+  "Raise an error if MACHINE's configuration is not an instance of
+<machine-ssh-configuration>."
+  (let ((config (machine-configuration machine))
+        (environment (environment-type-name (machine-environment machine))))
+    (unless (and config (machine-ssh-configuration? config))
+      (raise (condition
+              (&message
+               (message (format #f (G_ "unsupported machine configuration '~a'
+for environment of type '~a'")
+                                config
+                                environment))))))))
diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in
index ceee589b2e..bcd6f76371 100644
--- a/po/guix/POTFILES.in
+++ b/po/guix/POTFILES.in
@@ -36,6 +36,7 @@ gnu/installer/steps.scm
 gnu/installer/timezone.scm
 gnu/installer/user.scm
 gnu/installer/utils.scm
+gnu/machine/ssh.scm
 guix/scripts.scm
 guix/scripts/build.scm
 guix/discovery.scm