[bug#36404,2/5] 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.
* 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

Jakob L. Kreuze writes:

> * gnu/machine.scm: New file.
> * gnu/machine/ssh.scm: New file.
> * gnu/local.mk (GNU_SYSTEM_MODULES): Add it.
> * tests/machine.scm: New file.
> * Makefile.am (SCM_TESTS): Add it.
> ---
>  Makefile.am         |   3 +-
>  gnu/local.mk        |   5 +-
>  gnu/machine.scm     |  89 +++++++++
>  gnu/machine/ssh.scm | 355 ++++++++++++++++++++++++++++++++++
>  tests/machine.scm   | 450 ++++++++++++++++++++++++++++++++++++++++++++
>  5 files changed, 900 insertions(+), 2 deletions(-)
>  create mode 100644 gnu/machine.scm
>  create mode 100644 gnu/machine/ssh.scm
>  create mode 100644 tests/machine.scm
>
> diff --git a/Makefile.am b/Makefile.am
> index 80be73e4bf..9156554635 100644
> --- a/Makefile.am
> +++ b/Makefile.am
> @@ -423,7 +423,8 @@ SCM_TESTS =					\
>    tests/import-utils.scm			\
>    tests/store-database.scm			\
>    tests/store-deduplication.scm			\
> -  tests/store-roots.scm
> +  tests/store-roots.scm				\
> +  tests/machine.scm
>
>  SH_TESTS =					\
>    tests/guix-build.sh				\
> diff --git a/gnu/local.mk b/gnu/local.mk
> index f5d53b49b8..ad87de5ea7 100644
> --- a/gnu/local.mk
> +++ b/gnu/local.mk
> @@ -564,6 +564,9 @@ GNU_SYSTEM_MODULES =				\
>    %D%/system/uuid.scm				\
>    %D%/system/vm.scm				\
>  						\
> +  %D%/machine.scm				\
> +  %D%/machine/ssh.scm				\
> +						\
>    %D%/build/accounts.scm			\
>    %D%/build/activation.scm			\
>    %D%/build/bootloader.scm			\
> @@ -629,7 +632,7 @@ INSTALLER_MODULES =                             \
>    %D%/installer/newt/user.scm			\
>    %D%/installer/newt/utils.scm			\
>    %D%/installer/newt/welcome.scm		\
> -  %D%/installer/newt/wifi.scm
> +  %D%/installer/newt/wifi.scm
>
>  # Always ship the installer modules but compile them only when
>  # ENABLE_INSTALLER is true.
> diff --git a/gnu/machine.scm b/gnu/machine.scm
> new file mode 100644
> index 0000000000..900a2020dc
> --- /dev/null
> +++ b/gnu/machine.scm
> @@ -0,0 +1,89 @@
> +;;; GNU Guix --- Functional package management for GNU
> +;;; Copyright © 2019 David Thompson <davet@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)
> +  #:export (machine
> +            machine?
> +            this-machine
> +
> +            machine-system
> +            machine-environment
> +            machine-configuration
> +            machine-display-name
> +
> +            build-machine
> +            deploy-machine
> +            remote-eval))

Maybe it would make sense to call it machine-remote-eval to distinguish
it?  I dunno.

> +
> +;;; Commentary:
> +;;;
> +;;; This module provides the types used to declare individual machines in a
> +;;; heterogeneous Guix deployment. The interface allows users of specify system
> +;;; configurations and the means by which resources should be provisioned on a
> +;;; per-host basis.
> +;;;
> +;;; Code:
> +
> +(define-record-type* <machine> machine
> +  make-machine
> +  machine?
> +  this-machine
> +  (system        machine-system)       ; <operating-system>
> +  (environment   machine-environment)  ; symbol
> +  (configuration machine-configuration ; configuration object
> +                 (default #f)))        ; specific to environment
> +
> +(define (machine-display-name machine)
> +  "Return the host-name identifying MACHINE."
> +  (operating-system-host-name (machine-system machine)))
> +
> +(define (build-machine machine)
> +  "Monadic procedure that builds the system derivation for MACHINE and returning
> +a list containing the path of the derivation file and the path of the derivation
> +output."
> +  (let ((os (machine-system machine)))
> +    (mlet* %store-monad ((osdrv (operating-system-derivation os))
> +                         (_ ((store-lift build-derivations) (list osdrv))))
> +      (return (list (derivation-file-name osdrv)
> +                    (derivation->output-path osdrv))))))
> +
> +(define (remote-eval machine exp)
> +  "Evaluate EXP, a gexp, on MACHINE. Ensure that all the elements EXP refers to
> +are built and deployed to MACHINE beforehand."
> +  (case (machine-environment machine)
> +    ((managed-host)
> +     ((@@ (gnu machine ssh) remote-eval) machine exp))

@@ is a (sometimes useful) antipattern.  But in general, if something is
importing something with @@, it's a good indication that we should just
be exporting it.  What do you think?

> +    (else
> +     (let ((type (machine-environment machine)))
> +       (error "unsupported environment type" type)))))
> +
> +(define (deploy-machine machine)
> +  "Monadic procedure transferring the new system's OS closure to the remote
> +MACHINE, activating it on MACHINE and switching MACHINE to the new generation."
> +  (case (machine-environment machine)
> +    ((managed-host)
> +     ((@@ (gnu machine ssh) deploy-machine) machine))
> +    (else
> +     (let ((type (machine-environment machine)))
> +       (error "unsupported environment type" type)))))

So I guess here's where we'd switch out the environment from being a
symbol to being a struct or procedure (or struct containing a
procedure).

Maybe it wouldn't be so hard to do?

In fact, now that I look at it, we could solve both problems at once:
there's no need to export deploy-machine and remote-eval if they're
wrapped in another structure.  Instead, maybe this code could look like:

#+BEGIN_SRC scheme
(define (remote-eval machine exp)

  "Evaluate EXP, a gexp, on MACHINE. Ensure that all the elements EXP refers to
are built and deployed to MACHINE beforehand."
  (let* ((environment (machine-environment machine))
         (remote-eval (environment-remote-eval environment)))
    (remote-eval machine exp)))

(define (deploy-machine machine)
  "Monadic procedure transferring the new system's OS closure to the remote
MACHINE, activating it on MACHINE and switching MACHINE to the new generation."
  (let* ((environment (machine-environment machine))
         (deploy-machine (environment-deploy-machine environment)))
    (deploy-machine machine)))
#+END_SRC

Thoughts?

> diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm
> new file mode 100644
> index 0000000000..a8f946e19f
> --- /dev/null
> +++ b/gnu/machine/ssh.scm
> @@ -0,0 +1,355 @@
> +;;; GNU Guix --- Functional package management for GNU
> +;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org>
> +;;;
> +;;; This file is part of GNU Guix.
> +;;;
> +;;; GNU Guix is free software; you can redistribute it and/or modify it
> +;;; under the terms of the GNU General Public License as published by
> +;;; the Free Software Foundation; either version 3 of the License, or (at
> +;;; your option) any later version.
> +;;;
> +;;; GNU Guix is distributed in the hope that it will be useful, but
> +;;; WITHOUT ANY WARRANTY; without even the implied warranty of
> +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
> +;;; GNU General Public License for more details.
> +;;;
> +;;; You should have received a copy of the GNU General Public License
> +;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
> +
> +(define-module (gnu machine ssh)
> +  #:use-module (gnu bootloader)
> +  #:use-module (gnu machine)
> +  #:autoload   (gnu packages gnupg) (guile-gcrypt)
> +  #:use-module (gnu services)
> +  #:use-module (gnu services shepherd)
> +  #:use-module (gnu system)
> +  #:use-module (guix derivations)
> +  #:use-module (guix gexp)
> +  #:use-module (guix modules)
> +  #:use-module (guix monads)
> +  #:use-module (guix records)
> +  #:use-module (guix ssh)
> +  #:use-module (guix store)
> +  #:use-module (ice-9 match)
> +  #:use-module (srfi srfi-19)
> +  #:export (machine-ssh-configuration
> +            machine-ssh-configuration?
> +            machine-ssh-configuration
> +
> +            machine-ssh-configuration-host-name
> +            machine-ssh-configuration-port
> +            machine-ssh-configuration-user
> +            machine-ssh-configuration-session))
> +
> +;;; Commentary:
> +;;;
> +;;; This module implements remote evaluation and system deployment for
> +;;; machines that are accessable over SSH and have a known host-name. In the
> +;;; sense of the broader "machine" interface, we describe the environment for
> +;;; such machines as 'managed-host.
> +;;;
> +;;; Code:
> +
> +
> +;;;
> +;;; SSH client parameter configuration.
> +;;;
> +
> +(define-record-type* <machine-ssh-configuration> machine-ssh-configuration
> +  make-machine-ssh-configuration
> +  machine-ssh-configuration?
> +  this-machine-ssh-configuration
> +  (host-name machine-ssh-configuration-host-name) ; string
> +  (port      machine-ssh-configuration-port       ; integer
> +             (default 22))
> +  (user      machine-ssh-configuration-user       ; string
> +             (default "root"))
> +  (identity  machine-ssh-configuration-identity   ; path to a private key
> +             (default #f))
> +  (session   machine-ssh-configuration-session    ; session
> +             (default #f)))
> +
> +(define (machine-ssh-session machine)
> +  "Return the SSH session that was given in MACHINE's configuration, or create
> +one from the configuration's parameters if one was not provided."
> +  (let ((config (machine-configuration machine)))
> +    (if (machine-ssh-configuration? config)

Feels like better polymorphism than this is desirable, but I'm not sure
I have advice on how to do it right now.  Probably services provide the
right form of inspiration.

At any rate, it's probably not a blocker to merging this first set,
but I'd love to see if we could get something more future-extensible.

> +        (or (machine-ssh-configuration-session config)
> +            (let ((host-name (machine-ssh-configuration-host-name config))
> +                  (user (machine-ssh-configuration-user config))
> +                  (port (machine-ssh-configuration-port config))
> +                  (identity (machine-ssh-configuration-identity config)))
> +              (open-ssh-session host-name
> +                                #:user user
> +                                #:port port
> +                                #:identity identity)))
> +        (error "unsupported configuration type"))))
>
> +
> +;;;
> +;;; Remote evaluation.
> +;;;
> +
> +(define (remote-eval machine exp)
> +  "Internal implementation of 'remote-eval' for MACHINE instances with an
> +environment type of 'managed-host."
> +  (unless (machine-configuration machine)
> +    (error (format #f (G_ "no configuration specified for machine of environment '~a'")
> +                   (symbol->string (machine-environment machine)))))
> +  ((@ (guix remote) remote-eval) exp (machine-ssh-session machine)))

Why not just import remote-eval in the define-module?

> +
> +
> +;;;
> +;;; System deployment.
> +;;;
> +
> +(define (switch-to-system machine)
> +  "Monadic procedure creating a new generation on MACHINE and execute the
> +activation script for the new system configuration."
> +  (define (remote-exp drv script)
> +    (with-extensions (list guile-gcrypt)

It's so cool that this works across machines.  Dang!

> +      (with-imported-modules (source-module-closure '((guix config)
> +                                                      (guix profiles)
> +                                                      (guix utils)))
> +        #~(begin
> +            (use-modules (guix config)
> +                         (guix profiles)
> +                         (guix utils))
> +
> +            (define %system-profile
> +              (string-append %state-directory "/profiles/system"))
> +
> +            (let* ((system #$(derivation->output-path drv))
> +                   (number (1+ (generation-number %system-profile)))
> +                   (generation (generation-file-name %system-profile number))
> +                   (old-env (environ))
> +                   (old-path %load-path)
> +                   (old-cpath %load-compiled-path))
> +              (switch-symlinks generation system)
> +              (switch-symlinks %system-profile generation)
> +              ;; Guard against the activation script modifying $PATH.

Yeah that sounds like it would be bad.  But I'm curious... could you
explain the specific bug it's preventing here?  I'd like to know.

> +              (dynamic-wind
> +                (const #t)
> +                (lambda ()
> +                  (setenv "GUIX_NEW_SYSTEM" system)
> +                  ;; Guard against the activation script modifying '%load-path'.
> +                  (dynamic-wind
> +                    (const #t)
> +                    (lambda ()
> +                      ;; The activation script may write to stdout, which
> +                      ;; confuses 'remote-eval' when it attempts to read a
> +                      ;; result from the remote REPL. We work around this by
> +                      ;; forcing the output to a string.
> +                      (with-output-to-string
> +                        (lambda ()
> +                          (primitive-load #$script))))
> +                    (lambda ()
> +                      (set! %load-path old-path)
> +                      (set! %load-compiled-path old-cpath))))
> +                (lambda ()
> +                  (environ old-env))))))))
> +
> +  (let* ((os (machine-system machine))
> +         (script (operating-system-activation-script os)))
> +    (mlet* %store-monad ((drv (operating-system-derivation os)))
> +      (remote-eval machine (remote-exp drv script)))))
> +
> +(define (upgrade-shepherd-services machine)
> +  "Monadic procedure unloading and starting services on the remote as needed
> +to realize the MACHINE's system configuration."
> +  (define target-services
> +    ;; Monadic expression evaluating to a list of (name output-path) pairs for
> +    ;; all of MACHINE's services.
> +    (mapm %store-monad
> +          (lambda (service)
> +            (mlet %store-monad ((file ((compose lower-object
> +                                                shepherd-service-file)
> +                                       service)))
> +              (return (list (shepherd-service-canonical-name service)
> +                            (derivation->output-path file)))))
> +          (service-value
> +           (fold-services (operating-system-services (machine-system machine))
> +                          #:target-type shepherd-root-service-type))))
> +
> +  (define (remote-exp target-services)
> +    (with-imported-modules '((gnu services herd))
> +      #~(begin
> +          (use-modules (gnu services herd)
> +                       (srfi srfi-1))
> +
> +          (define running
> +            (filter live-service-running (current-services)))
> +
> +          (define (essential? service)
> +            ;; Return #t if SERVICE is essential and should not be unloaded
> +            ;; under any circumstance.
> +            (memq (first (live-service-provision service))
> +                  '(root shepherd)))

This is a curious procedure, but I see why it exists.  I guess these
really are the only things?  Maybe it will change at some point
in the future, but seems to make sense for now.

> +          (define (obsolete? service)
> +            ;; Return #t if SERVICE can be safely unloaded.
> +            (and (not (essential? service))
> +                 (every (lambda (requirements)
> +                          (not (memq (first (live-service-provision service))
> +                                     requirements)))
> +                        (map live-service-requirement running))))

Just to see if I understand it... this is kind of so we can identify and
"garbage collect" services that don't apply to the new system?

> +          (define to-unload
> +            (filter obsolete?
> +                    (remove (lambda (service)
> +                              (memq (first (live-service-provision service))
> +                                    (map first '#$target-services)))
> +                            running)))
> +
> +          (define to-start
> +            (remove (lambda (service-pair)
> +                      (memq (first service-pair)
> +                            (map (compose first live-service-provision)
> +                                 running)))
> +                    '#$target-services))
> +
> +          ;; Unload obsolete services.
> +          (for-each (lambda (service)
> +                      (false-if-exception
> +                       (unload-service service)))
> +                    to-unload)
> +
> +          ;; Load the service files for any new services and start them.
> +          (load-services/safe (map second to-start))
> +          (for-each start-service (map first to-start))

I'm a bit unsure from the above code... I'm guessing one of two things
is happening:

 - Either it's starting services that haven't been started yet, but
   leaving alone services that are running but which aren't "new"
 - Or it's restarting services that are currently running

Which is it?  And mind adding a comment explaining it?

By the way, is there anything about the dependency order in which
services might need to be restarted to be considered?  I'm honestly not sure.

> +          #t)))
> +
> +  (mlet %store-monad ((target-services target-services))
> +    (remote-eval machine (remote-exp target-services))))
> +
> +(define (machine-boot-parameters machine)
> +  "Monadic procedure returning a list of 'boot-parameters' for the generations
> +of MACHINE's system profile, ordered from most recent to oldest."
> +  (define bootable-kernel-arguments
> +    (@@ (gnu system) bootable-kernel-arguments))
> +
> +  (define remote-exp
> +    (with-extensions (list guile-gcrypt)
> +      (with-imported-modules (source-module-closure '((guix config)
> +                                                      (guix profiles)))
> +        #~(begin
> +            (use-modules (guix config)
> +                         (guix profiles)
> +                         (ice-9 textual-ports))
> +
> +            (define %system-profile
> +              (string-append %state-directory "/profiles/system"))
> +
> +            (define (read-file path)
> +              (call-with-input-file path
> +                (lambda (port)
> +                  (get-string-all port))))
> +
> +            (map (lambda (generation)
> +                   (let* ((system-path (generation-file-name %system-profile
> +                                                             generation))
> +                          (boot-parameters-path (string-append system-path
> +                                                               "/parameters"))
> +                          (time (stat:mtime (lstat system-path))))
> +                     (list generation
> +                           system-path
> +                           time
> +                           (read-file boot-parameters-path))))
> +                 (reverse (generation-numbers %system-profile)))))))
> +
> +  (mlet* %store-monad ((generations (remote-eval machine remote-exp)))
> +    (return
> +     (map (lambda (generation)
> +            (match generation
> +              ((generation system-path time serialized-params)
> +               (let* ((params (call-with-input-string serialized-params
> +                                read-boot-parameters))
> +                      (root (boot-parameters-root-device params))
> +                      (label (boot-parameters-label params)))
> +                 (boot-parameters
> +                  (inherit params)
> +                  (label
> +                   (string-append label " (#"
> +                                  (number->string generation) ", "
> +                                  (let ((time (make-time time-utc 0 time)))
> +                                    (date->string (time-utc->date time)
> +                                                  "~Y-~m-~d ~H:~M"))
> +                                  ")"))
> +                  (kernel-arguments
> +                   (append (bootable-kernel-arguments system-path root)
> +                           (boot-parameters-kernel-arguments params))))))))
> +          generations))))

So I guess this is derivative of some of the stuff in
guix/scripts/system.scm.  That makes me feel like it would be nice if it
could be generalized, but I haven't spent enough time with the code to
figure out if it really can be.

I don't want to block the merge on that desire, though if you agree that
generalization between those sections of code is desirable, maybe add a
comment to that effect?

> +(define (install-bootloader machine)
> +  "Create a bootloader entry for the new system generation on MACHINE, and
> +configure the bootloader to boot that generation by default."
> +  (define bootloader-installer-script
> +    (@@ (guix scripts system) bootloader-installer-script))
> +
> +  (define (remote-exp installer bootcfg bootcfg-file)
> +    (with-extensions (list guile-gcrypt)
> +      (with-imported-modules (source-module-closure '((gnu build install)
> +                                                      (guix store)
> +                                                      (guix utils)))
> +        #~(begin
> +            (use-modules (gnu build install)
> +                         (guix store)
> +                         (guix utils))
> +            (let* ((gc-root (string-append "/" %gc-roots-directory "/bootcfg"))
> +                   (temp-gc-root (string-append gc-root ".new"))
> +                   (old-path %load-path)
> +                   (old-cpath %load-compiled-path))
> +              (switch-symlinks temp-gc-root gc-root)
> +
> +              (unless (false-if-exception
> +                       (begin
> +                         (install-boot-config #$bootcfg #$bootcfg-file "/")
> +                         ;; Guard against the activation script modifying
> +                         ;; '%load-path'.
> +                         (dynamic-wind
> +                           (const #t)
> +                           (lambda ()
> +                             ;; The installation script may write to stdout,
> +                             ;; which confuses 'remote-eval' when it attempts to
> +                             ;; read a result from the remote REPL. We work
> +                             ;; around this by forcing the output to a string.
> +                             (with-output-to-string
> +                               (lambda ()
> +                                 (primitive-load #$installer))))
> +                           (lambda ()
> +                             (set! %load-path old-path)
> +                             (set! %load-compiled-path old-cpath)))))
> +                (delete-file temp-gc-root)
> +                (error "failed to install bootloader"))
> +
> +              (rename-file temp-gc-root gc-root)
> +              #t)))))

This code also looks very similar, but I compared them and I can see
that they aren't quite the same, at least in that you had to install the
dynamic-wind.  But I get the feeling that it still might be possible to
generalize them, so could you leave a comment here as well?  Unless you
think it's really not possible to generalize them to share code for
reasons I'm not yet aware of.

> +  (mlet* %store-monad ((boot-parameters (machine-boot-parameters machine)))
> +    (let* ((os (machine-system machine))
> +           (bootloader ((compose bootloader-configuration-bootloader
> +                                 operating-system-bootloader)
> +                        os))
> +           (bootloader-target (bootloader-configuration-target
> +                               (operating-system-bootloader os)))
> +           (installer (bootloader-installer-script
> +                       (bootloader-installer bootloader)
> +                       (bootloader-package bootloader)
> +                       bootloader-target
> +                       "/"))
> +           (menu-entries (map boot-parameters->menu-entry boot-parameters))
> +           (bootcfg (operating-system-bootcfg os menu-entries))
> +           (bootcfg-file (bootloader-configuration-file bootloader)))
> +      (remote-eval machine (remote-exp installer bootcfg bootcfg-file)))))
> +
> +(define (deploy-machine machine)
> +  "Internal implementation of 'deploy-machine' for MACHINE instances with an
> +environment type of 'managed-host."
> +  (unless (machine-configuration machine)
> +    (error (format #f (G_ "no configuration specified for machine of environment '~a'")
> +                   (symbol->string (machine-environment machine)))))
> +  (mbegin %store-monad
> +    (switch-to-system machine)
> +    (upgrade-shepherd-services machine)
> +    (install-bootloader machine)))
> diff --git a/tests/machine.scm b/tests/machine.scm
> new file mode 100644
> index 0000000000..390c0189bb
> --- /dev/null
> +++ b/tests/machine.scm
> @@ -0,0 +1,450 @@
> +;;; GNU Guix --- Functional package management for GNU
> +;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org>
> +;;;
> +;;; This file is part of GNU Guix.
> +;;;
> +;;; GNU Guix is free software; you can redistribute it and/or modify it
> +;;; under the terms of the GNU General Public License as published by
> +;;; the Free Software Foundation; either version 3 of the License, or (at
> +;;; your option) any later version.
> +;;;
> +;;; GNU Guix is distributed in the hope that it will be useful, but
> +;;; WITHOUT ANY WARRANTY; without even the implied warranty of
> +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
> +;;; GNU General Public License for more details.
> +;;;
> +;;; You should have received a copy of the GNU General Public License
> +;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
> +
> +(define-module (gnu tests machine)
> +  #:use-module (gnu bootloader grub)
> +  #:use-module (gnu bootloader)
> +  #:use-module (gnu build marionette)
> +  #:use-module (gnu build vm)
> +  #:use-module (gnu machine)
> +  #:use-module (gnu machine ssh)
> +  #:use-module (gnu packages bash)
> +  #:use-module (gnu packages virtualization)
> +  #:use-module (gnu services base)
> +  #:use-module (gnu services networking)
> +  #:use-module (gnu services ssh)
> +  #:use-module (gnu services)
> +  #:use-module (gnu system file-systems)
> +  #:use-module (gnu system vm)
> +  #:use-module (gnu system)
> +  #:use-module (gnu tests)
> +  #:use-module (guix derivations)
> +  #:use-module (guix gexp)
> +  #:use-module (guix monads)
> +  #:use-module (guix pki)
> +  #:use-module (guix store)
> +  #:use-module (guix utils)
> +  #:use-module (ice-9 ftw)
> +  #:use-module (ice-9 match)
> +  #:use-module (ice-9 textual-ports)
> +  #:use-module (srfi srfi-1)
> +  #:use-module (srfi srfi-26)
> +  #:use-module (srfi srfi-64)
> +  #:use-module (ssh auth)
> +  #:use-module (ssh channel)
> +  #:use-module (ssh key)
> +  #:use-module (ssh session))

Hoo!  That's a lot of imports!  Makes sense I guess...

> +
> +;;;
> +;;; Virtual machine scaffolding.
> +;;;
> +
> +(define marionette-pid (@@ (gnu build marionette) marionette-pid))
> +
> +(define (call-with-marionette path command proc)
> +  "Invoke PROC with a marionette running COMMAND in PATH."
> +  (let* ((marionette (make-marionette command #:socket-directory path))
> +         (pid (marionette-pid marionette)))
> +    (dynamic-wind
> +      (lambda ()
> +        (unless marionette
> +          (error "could not start marionette")))
> +      (lambda () (proc marionette))
> +      (lambda ()
> +        (kill pid SIGTERM)))))
> +
> +(define (dir-join . components)
> +  "Join COMPONENTS with `file-name-separator-string'."
> +  (string-join components file-name-separator-string))
> +
> +(define (call-with-machine-test-directory proc)
> +  "Run PROC with the path to a temporary directory that will be cleaned up
> +when PROC returns. Only files that can be passed to 'delete-file' should be
> +created within the temporary directory; cleanup will not recurse into
> +subdirectories."
> +  (let ((path (tmpnam)))
> +    (dynamic-wind
> +      (lambda ()
> +        (unless (mkdir path)
> +          (error (format #f "could not create directory '~a'" path))))
> +      (lambda () (proc path))
> +      (lambda ()
> +        (let ((children (map first (cddr (file-system-tree path)))))
> +          (for-each (lambda (child)
> +                      (false-if-exception
> +                       (delete-file (dir-join path child))))
> +                    children)
> +          (rmdir path))))))
> +
> +(define (os-for-test os)
> +  "Return an <operating-system> record derived from OS that is appropriate for
> +use with 'qemu-image'."
> +  (define file-systems-to-keep
> +    ;; Keep only file systems other than root and not normally bound to real
> +    ;; devices.
> +    (remove (lambda (fs)
> +              (let ((target (file-system-mount-point fs))
> +                    (source (file-system-device fs)))
> +                (or (string=? target "/")
> +                    (string-prefix? "/dev/" source))))
> +            (operating-system-file-systems os)))
> +
> +  (define root-uuid
> +    ;; UUID of the root file system.
> +    ((@@ (gnu system vm) operating-system-uuid) os 'dce))
> +
> +
> +  (operating-system
> +    (inherit os)
> +    ;; Assume we have an initrd with the whole QEMU shebang.
> +
> +    ;; Force our own root file system.  Refer to it by UUID so that
> +    ;; it works regardless of how the image is used ("qemu -hda",
> +    ;; Xen, etc.).
> +    (file-systems (cons (file-system
> +                          (mount-point "/")
> +                          (device root-uuid)
> +                          (type "ext4"))
> +                        file-systems-to-keep))))
> +
> +(define (qemu-image-for-test os)
> +  "Return a derivation producing a QEMU disk image running OS. This procedure
> +is similar to 'system-qemu-image' in (gnu system vm), but makes use of
> +'os-for-test' so that callers may obtain the same system derivation that will
> +be booted by the image."
> +  (define root-uuid ((@@ (gnu system vm) operating-system-uuid) os 'dce))
> +  (let* ((os (os-for-test os))
> +         (bootcfg (operating-system-bootcfg os)))
> +    (qemu-image #:os os
> +                #:bootcfg-drv bootcfg
> +                #:bootloader (bootloader-configuration-bootloader
> +                              (operating-system-bootloader os))
> +                #:disk-image-size (* 9000 (expt 2 20))
> +                #:file-system-type "ext4"
> +                #:file-system-uuid root-uuid
> +                #:inputs `(("system" ,os)
> +                           ("bootcfg" ,bootcfg))
> +                #:copy-inputs? #t)))
> +
> +(define (make-writable-image image)
> +  "Return a derivation producing a script to create a writable disk image
> +overlay of IMAGE, writing the overlay to the the path given as a command-line
> +argument to the script."
> +  (define qemu-img-exec
> +    #~(list (string-append #$qemu-minimal "/bin/qemu-img")
> +            "create" "-f" "qcow2"
> +            "-o" (string-append "backing_file=" #$image)))
> +
> +  (define builder
> +    #~(call-with-output-file #$output
> +        (lambda (port)
> +          (format port "#!~a~% exec ~a \"$@\"~%"
> +                  #$(file-append bash "/bin/sh")
> +                  (string-join #$qemu-img-exec " "))
> +          (chmod port #o555))))
> +
> +  (gexp->derivation "make-writable-image.sh" builder))
> +
> +(define (run-os-for-test os)
> +  "Return a derivation producing a script to run OS as a qemu guest, whose
> +first argument is the path to a writable disk image. Additional arguments are
> +passed as-is to qemu."
> +  (define kernel-arguments
> +    #~(list "console=ttyS0"
> +            #+@(operating-system-kernel-arguments os "/dev/sda1")))
> +
> +  (define qemu-exec
> +    #~(begin
> +        (list (string-append #$qemu-minimal "/bin/" #$(qemu-command (%current-system)))
> +              "-kernel" #$(operating-system-kernel-file os)
> +              "-initrd" #$(file-append os "/initrd")
> +              (format #f "-append ~s"
> +                      (string-join #$kernel-arguments " "))
> +              #$@(if (file-exists? "/dev/kvm")
> +                     '("-enable-kvm")
> +                     '())
> +              "-no-reboot"
> +              "-net nic,model=virtio"
> +              "-object" "rng-random,filename=/dev/urandom,id=guixsd-vm-rng"
> +              "-device" "virtio-rng-pci,rng=guixsd-vm-rng"
> +              "-vga" "std"
> +              "-m" "256"
> +              "-net" "user,hostfwd=tcp::2222-:22")))
> +
> +  (define builder
> +    #~(call-with-output-file #$output
> +        (lambda (port)
> +          (format port "#!~a~% exec ~a -drive \"file=$@\"~%"
> +                  #$(file-append bash "/bin/sh")
> +                  (string-join #$qemu-exec " "))
> +          (chmod port #o555))))
> +
> +  (gexp->derivation "run-vm.sh" builder))
> +
> +(define (scripts-for-test os)
> +  "Build and return a list containing the paths of:
> +
> +- A script to make a writable disk image overlay of OS.
> +- A script to run that disk image overlay as a qemu guest."
> +  (let ((virtualized-os (os-for-test os)))
> +    (mlet* %store-monad ((osdrv (operating-system-derivation virtualized-os))
> +                         (imgdrv (qemu-image-for-test os))
> +
> +                         ;; Ungexping 'imgdrv' or 'osdrv' will result in an
> +                         ;; error if the derivations don't exist in the store,
> +                         ;; so we ensure they're built prior to invoking
> +                         ;; 'run-vm' or 'make-image'.
> +                         (_ ((store-lift build-derivations) (list imgdrv)))
> +
> +                         (run-vm (run-os-for-test virtualized-os))
> +                         (make-image
> +                          (make-writable-image (derivation->output-path imgdrv))))
> +      (mbegin %store-monad
> +        ((store-lift build-derivations) (list imgdrv make-image run-vm))
> +        (return (list (derivation->output-path make-image)
> +                      (derivation->output-path run-vm)))))))
> +
> +(define (call-with-marionette-and-session os proc)
> +  "Construct a marionette backed by OS in a temporary test environment and
> +invoke PROC with two arguments: the marionette object, and an SSH session
> +connected to the marionette."
> +  (call-with-machine-test-directory
> +   (lambda (path)
> +     (match (with-store store
> +              (run-with-store store
> +                (scripts-for-test %system)))
> +       ((make-image run-vm)
> +        (let ((image (dir-join path "image")))
> +          ;; Create the writable image overlay.
> +          (system (string-join (list make-image image) " "))
> +          (call-with-marionette
> +           path
> +           (list run-vm image)
> +           (lambda (marionette)
> +             ;; XXX: The guest clearly has (gcrypt pk-crypto) since this
> +             ;; works, but trying to import it from 'marionette-eval' fails as
> +             ;; the Marionette REPL does not have 'guile-gcrypt' in its
> +             ;; %load-path.
> +             (marionette-eval
> +              `(begin
> +                 (use-modules (ice-9 popen))
> +                 (let ((port (open-pipe* OPEN_WRITE "guix" "archive" "--authorize")))
> +                   (put-string port ,%signing-key)
> +                   (close port)))
> +              marionette)
> +             ;; XXX: This is an absolute hack to work around potential quirks
> +             ;; in the operating system. For one, we invoke 'herd' from the
> +             ;; command-line to ensure that the Shepherd socket file
> +             ;; exists. Second, we enable 'ssh-daemon', as there's a chance
> +             ;; the service will be disabled upon booting the image.
> +             (marionette-eval
> +              `(system "herd enable ssh-daemon")
> +              marionette)
> +             (marionette-eval
> +              '(begin
> +                 (use-modules (gnu services herd))
> +                 (start-service 'ssh-daemon))
> +              marionette)
> +             (call-with-connected-session/auth
> +              (lambda (session)
> +                (proc marionette session)))))))))))
> +
> +
> +;;;
> +;;; SSH session management. These are borrowed from (gnu tests ssh).
> +;;;
> +
> +(define (make-session-for-test)
> +  "Make a session with predefined parameters for a test."
> +  (make-session #:user "root"
> +                #:port 2222
> +                #:host "localhost"))
> +
> +(define (call-with-connected-session proc)
> +  "Call the one-argument procedure PROC with a freshly created and
> +connected SSH session object, return the result of the procedure call.  The
> +session is disconnected when the PROC is finished."
> +  (let ((session (make-session-for-test)))
> +    (dynamic-wind
> +      (lambda ()
> +        (let ((result (connect! session)))
> +          (unless (equal? result 'ok)
> +            (error "Could not connect to a server"
> +                   session result))))
> +      (lambda () (proc session))
> +      (lambda () (disconnect! session)))))
> +
> +(define (call-with-connected-session/auth proc)
> +  "Make an authenticated session.  We should be able to connect as
> +root with an empty password."
> +  (call-with-connected-session
> +   (lambda (session)
> +     ;; Try the simple authentication methods.  Dropbear requires
> +     ;; 'none' when there are no passwords, whereas OpenSSH accepts
> +     ;; 'password' with an empty password.
> +     (let loop ((methods (list (cut userauth-password! <> "")
> +                               (cut userauth-none! <>))))
> +       (match methods
> +         (()
> +          (error "all the authentication methods failed"))
> +         ((auth rest ...)
> +          (match (pk 'auth (auth session))
> +            ('success
> +             (proc session))
> +            ('denied
> +             (loop rest)))))))))
> +
> +
> +;;;
> +;;; Virtual machines for use in the test suite.
> +;;;
> +
> +(define %system
> +  ;; A "bare bones" operating system running both an OpenSSH daemon and the
> +  ;; "marionette" service.
> +  (marionette-operating-system
> +   (operating-system
> +     (host-name "gnu")
> +     (timezone "Etc/UTC")
> +     (bootloader (bootloader-configuration
> +                  (bootloader grub-bootloader)
> +                  (target "/dev/sda")
> +                  (terminal-outputs '(console))))
> +     (file-systems (cons (file-system
> +                           (mount-point "/")
> +                           (device "/dev/vda1")
> +                           (type "ext4"))
> +                         %base-file-systems))
> +     (services
> +      (append (list (service dhcp-client-service-type)
> +                    (service openssh-service-type
> +                             (openssh-configuration
> +                              (permit-root-login #t)
> +                              (allow-empty-passwords? #t))))
> +              %base-services)))
> +   #:imported-modules '((gnu services herd)
> +                        (guix combinators))))
> +
> +(define %signing-key
> +  ;; The host's signing key, encoded as a string. The "marionette" will reject
> +  ;; any files signed by an unauthorized host, so we'll need to send this key
> +  ;; over and authorize it.
> +  (call-with-input-file %public-key-file
> +    (lambda (port)
> +      (get-string-all port))))
> +
> +
> +(test-begin "machine")
> +
> +(define (system-generations marionette)
> +  (marionette-eval
> +   '(begin
> +      (use-modules (ice-9 ftw)
> +                   (srfi srfi-1))
> +      (let* ((profile-dir "/var/guix/profiles/")
> +             (entries (map first (cddr (file-system-tree profile-dir)))))
> +        (remove (lambda (entry)
> +                  (member entry '("per-user" "system")))
> +                entries)))
> +   marionette))
> +
> +(define (running-services marionette)
> +  (marionette-eval
> +   '(begin
> +      (use-modules (gnu services herd)
> +                   (srfi srfi-1))
> +      (map (compose first live-service-provision)
> +           (filter live-service-running (current-services))))
> +   marionette))
> +
> +(define (count-grub-cfg-entries marionette)
> +  (marionette-eval
> +   '(begin
> +      (define grub-cfg
> +        (call-with-input-file "/boot/grub/grub.cfg"
> +          (lambda (port)
> +            (get-string-all port))))
> +
> +        (let loop ((n 0)
> +                   (start 0))
> +          (let ((index (string-contains grub-cfg "menuentry" start)))
> +            (if index
> +                (loop (1+ n) (1+ index))
> +                n))))
> +   marionette))
> +
> +(define %target-system
> +  (marionette-operating-system
> +   (operating-system
> +     (host-name "gnu-deployed")
> +     (timezone "Etc/UTC")
> +     (bootloader (bootloader-configuration
> +                  (bootloader grub-bootloader)
> +                  (target "/dev/sda")
> +                  (terminal-outputs '(console))))
> +     (file-systems (cons (file-system
> +                           (mount-point "/")
> +                           (device "/dev/vda1")
> +                           (type "ext4"))
> +                         %base-file-systems))
> +     (services
> +      (append (list (service tor-service-type)
> +                    (service dhcp-client-service-type)
> +                    (service openssh-service-type
> +                             (openssh-configuration
> +                              (permit-root-login #t)
> +                              (allow-empty-passwords? #t))))
> +              %base-services)))
> +   #:imported-modules '((gnu services herd)
> +                        (guix combinators))))
> +
> +(call-with-marionette-and-session
> + (os-for-test %system)
> + (lambda (marionette session)
> +   (let ((generations-prior (system-generations marionette))
> +         (services-prior (running-services marionette))
> +         (grub-entry-count-prior (count-grub-cfg-entries marionette))
> +         (machine (machine
> +                   (system %target-system)
> +                   (environment 'managed-host)
> +                   (configuration (machine-ssh-configuration
> +                                   (host-name "localhost")
> +                                   (session session))))))
> +     (with-store store
> +       (run-with-store store
> +         (build-machine machine))
> +       (run-with-store store
> +         (deploy-machine machine)))
> +     (test-equal "deployment created new generation"
> +       (length (system-generations marionette))
> +       (1+ (length generations-prior)))
> +     (test-assert "deployment started new service"
> +       (and (not (memq 'tor services-prior))
> +            (memq 'tor (running-services marionette))))
> +     (test-equal "deployment created new menu entry"
> +       (count-grub-cfg-entries marionette)
> +       ;; A Grub configuration that contains a single menu entry does not have
> +       ;; an "old configurations" submenu. Deployment, then, would result in
> +       ;; this submenu being created, meaning an additional two 'menuentry'
> +       ;; fields rather than just one.
> +       (if (= grub-entry-count-prior 1)
> +           (+ 2 grub-entry-count-prior)
> +           (1+ grub-entry-count-prior))))))
> +
> +(test-end "machine")

Seems good from a quick scan, but I'll admit I didn't read these as
carefully as I did the rest of the code.

This patch looks great overall!  I know it was a lot of work to figure
out, and I'm impressed by how quickly you came up to speed on it.

Christopher Lemmer Webber <cwebber@dustycloud.org> writes:

> Maybe it would make sense to call it machine-remote-eval to
> distinguish it? I dunno.

Considering the naming used for everything else that '(gnu machine)'
exports, I think that makes more sense. And that way I'll be able to
just import '(gnu remote ssh)' without shadowing 'remote-eval'. I went
ahead and changed it.

> @@ 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?

My thinking was that, when we have more than one environment type, @@
could be used with module reflection to get a specific environment's
implementation of 'remote-eval'. But going back to your point in an
earlier email about implementing environments as distinct types rather
than symbols, it would be pretty easy to expose some sort of
'remote-eval' field on those environment types.

> 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?

Whoops, wrote the above paragraph before getting here. :]

> 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.

Are you talking about service extensions? I'm starting to see your point
regarding polymorphism, since SSH would be the backbone for a lot of
these environment types. Does anyone else have suggestions for
implementing that sort of polymorphism?

> Why not just import remote-eval in the define-module?

To avoid a Guile warning about shadowing symbols. This goes away with
the renaming of 'remote-eval' to 'machine-remote-eval', though.

> It's so cool that this works across machines.  Dang!

:)

> 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.

You've found something I've overlooked. There wasn't a bug, it's
something I put in since 'guix system' does it when loading the
activation script. But after looking through the 'guix system' code, I
noticed that there's a comment reading "[t]his is necessary to ensure
that 'upgrade-shepherd-services' gets to see the right modules when it
computes derivations with 'gexp->derivation'." Yet, I'm invoking my
version of 'upgrade-shepherd-services' outside of that excursion. I
haven't had any issues with it so far, but then again, I haven't done
much with trying to register new services with 'guix deploy'. I think
it's worth fixing.

> 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?

Yep.

>
> 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?

The former. I've intentionally avoided restarting services since 'guix
system' warns that "many essential services cannot be meaningfully
restarted." (which is why 'guix system reconfigure' spits out "To
complete the upgrade, run 'herd restart SERVICE' to stop, upgrade, and
restart each service that was not automatically restarted." (which AFAIK
is always none of them)).

> 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.

I'm not sure either. Would any Shepherd hackers out there care to chime
in?

> 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?

You're right, and I agree 100%. I think I can commit to refactoring out
the common code, albeit after this patch series is merged -- that's
something that deserves its own commit, and it would probably take me
some time to get right anyway.

> 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.

I think it can be generalized. In fact, 'guix system' does with
'save-load-path-excursion' and 'save-environment-excursion'. If I can't
generalize the code from '(gnu machine)' and 'guix system', I'll at
least see about exporting those excursions from 'guix system' (they're
unexported at the moment).

> 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.

I'm not sure it's really worth reading right now, this is the "me way"
of testing everything and I suspect some significant changes are going
to be made.

> 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.

Thank you :)

Hey Jakob/Chris,

I can't comment on much of the deploy code, but I can help out 
with some stuff about the Shepherd.

On Sun, Jun 30 2019, Jakob L. Kreuze wrote:
>> 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?
>
> The former. I've intentionally avoided restarting services since 
> 'guix
> system' warns that "many essential services cannot be 
> meaningfully
> restarted." (which is why 'guix system reconfigure' spits out 
> "To
> complete the upgrade, run 'herd restart SERVICE' to stop, 
> upgrade, and
> restart each service that was not automatically restarted." 
> (which AFAIK
> is always none of them)).

There was discussion earlier this year around restarting services 
that are already running during a reconfigure[1]. I wonder if this 
problem is more worth solving if we're deploying to remote 
systems. I have a few patches in that issue to implement service 
restarting, but I didn't follow them up enough to get them into 
Guix.

[1]: https://issues.guix.info/issue/33508

>> 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.
>
> I'm not sure either. Would any Shepherd hackers out there care 
> to chime
> in?

The Shepherd will start any necessary dependencies in an 
appropriate order.

Carlo

Jakob L. Kreuze writes:

> Christopher Lemmer Webber <cwebber@dustycloud.org> writes:
>
>> 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.
>
> Are you talking about service extensions? I'm starting to see your point
> regarding polymorphism, since SSH would be the backbone for a lot of
> these environment types. Does anyone else have suggestions for
> implementing that sort of polymorphism?

Right now it looks like you're hard-coding dispatch into the procedure
by doing a case analysis of what type it is, but this doesn't allow us
to extend it.

Here I'd look at how service-type works.  Check out gnu/services.scm
and then some examples of how services are defined in say,
gnu/services/admin.scm or something (eg rotlog-service-type).  I'm not
saying structure it in exactly this way, but that seems to be the right
general pattern to do extensibility in the guix'y way:

 - Have a common outer type (eg <service-type>) which actually
   sets up the structure of this service type
 - Then have the actual records that are specific to the service type
   represented as the service-value.

Section 8.16.2 "Serivce Types and Services" and 6.16.3 "Service
Reference" for details.

Note that I wish there was a way to generalize the ideas behind this
pattern rather than have it be reinvented for everything that needs
them.  This is part of why David and I turned to GOOPS in the initial
prototype implementation; it's a lot of work figuring out how to set up
extensibility in this way, at least for me.  You might want to write a
quick GOOPS version to understand what all the parameters are that are
needed, then convert it to the services way of doing a general structure
that wraps a specific structure.

I suspect you won't need as much composability as services currently
need, so the implementation of whatever this extensibility is is
probably not as complicated as it is for services.

As for how to share the ssh code, maybe just having the building-block
procedures is good enough?

Since all we support, so far, is this kind of ssh'ing, I don't want this
to block the patch though.  It could be that we file this as a bug and
add a TODO above the code for the moment saying "we know this isn't
right/ideal".  However, there is some risk that this could result in
people writing out machine configurations that later break... I dunno.

Thoughts?

>> Why not just import remote-eval in the define-module?
>
> To avoid a Guile warning about shadowing symbols. This goes away with
> the renaming of 'remote-eval' to 'machine-remote-eval', though.

Heh :)

>> 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.
>
> You've found something I've overlooked. There wasn't a bug, it's
> something I put in since 'guix system' does it when loading the
> activation script. But after looking through the 'guix system' code, I
> noticed that there's a comment reading "[t]his is necessary to ensure
> that 'upgrade-shepherd-services' gets to see the right modules when it
> computes derivations with 'gexp->derivation'." Yet, I'm invoking my
> version of 'upgrade-shepherd-services' outside of that excursion. I
> haven't had any issues with it so far, but then again, I haven't done
> much with trying to register new services with 'guix deploy'. I think
> it's worth fixing.

Cool.  Yay reviews!

If you remove it, please leave a comment noting the difference between
this and "guix system" and why you thought it was safe to remove.  If it
turns out to not be the case, there's a breadcrumb there to figure out
how to add it back.

>> 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?
>
> Yep.
>
>>
>> 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?
>
> The former. I've intentionally avoided restarting services since 'guix
> system' warns that "many essential services cannot be meaningfully
> restarted." (which is why 'guix system reconfigure' spits out "To
> complete the upgrade, run 'herd restart SERVICE' to stop, upgrade, and
> restart each service that was not automatically restarted." (which AFAIK
> is always none of them)).

Aha.  Thank you for explaining!  This make ssense.

>> 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.
>
> I'm not sure either. Would any Shepherd hackers out there care to chime
> in?

I guess if you aren't restarting the services, it's no longer a big deal.

>> 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?
>
> You're right, and I agree 100%. I think I can commit to refactoring out
> the common code, albeit after this patch series is merged -- that's
> something that deserves its own commit, and it would probably take me
> some time to get right anyway.

Great!

>> 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.
>
> I think it can be generalized. In fact, 'guix system' does with
> 'save-load-path-excursion' and 'save-environment-excursion'. If I can't
> generalize the code from '(gnu machine)' and 'guix system', I'll at
> least see about exporting those excursions from 'guix system' (they're
> unexported at the moment).

Okay, cool.

>> 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.
>
> I'm not sure it's really worth reading right now, this is the "me way"
> of testing everything and I suspect some significant changes are going
> to be made.

Kk.

>> 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.
>
> Thank you :)

Thank *you*!

Carlo Zancanaro writes:

> Hey Jakob/Chris,
>
> I can't comment on much of the deploy code, but I can help out with
> some stuff about the Shepherd.
>
> On Sun, Jun 30 2019, Jakob L. Kreuze wrote:
>>> 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?
>>
>> The former. I've intentionally avoided restarting services since
>> 'guix
>> system' warns that "many essential services cannot be meaningfully
>> restarted." (which is why 'guix system reconfigure' spits out "To
>> complete the upgrade, run 'herd restart SERVICE' to stop, upgrade,
>> and
>> restart each service that was not automatically restarted." (which
>> AFAIK
>> is always none of them)).
>
> There was discussion earlier this year around restarting services that
> are already running during a reconfigure[1]. I wonder if this problem
> is more worth solving if we're deploying to remote systems. I have a
> few patches in that issue to implement service restarting, but I
> didn't follow them up enough to get them into Guix.
>
> [1]: https://issues.guix.info/issue/33508

Wow!  This seems highly desireable, especially if, as you pointed out in
the issue, an update to nginx is pushed across the wire with a security
update... in that case, we'd want to restart that, too.

Jakob, do you mind checking out the issue above?  I think it shouldn't
block merging these patches but perhaps we should file an issue saying
that when the shepherd issue is merged, changes should be made to guix
deploy as well.  What do you think?

>>> 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.
>>
>> I'm not sure either. Would any Shepherd hackers out there care to
>> chime
>> in?
>
> The Shepherd will start any necessary dependencies in an appropriate
> order.
>
> Carlo

Ok, good to know!

Christopher Lemmer Webber <cwebber@dustycloud.org> writes:

> Jakob, do you mind checking out the issue above? I think it shouldn't
> block merging these patches but perhaps we should file an issue saying
> that when the shepherd issue is merged, changes should be made to guix
> deploy as well. What do you think?

I took a peek and added a comment about it to machine.scm, are you
suggesting that we track it on debbugs?

Christopher Lemmer Webber <cwebber@dustycloud.org> writes:

> Right now it looks like you're hard-coding dispatch into the procedure
> by doing a case analysis of what type it is, but this doesn't allow us
> to extend it.
>
> Here I'd look at how service-type works. Check out gnu/services.scm
> and then some examples of how services are defined in say,
> gnu/services/admin.scm or something (eg rotlog-service-type). I'm not
> saying structure it in exactly this way, but that seems to be the
> right general pattern to do extensibility in the guix'y way:
>
>  - Have a common outer type (eg <service-type>) which actually sets up
>    the structure of this service type
>  - Then have the actual records that are specific to the service type
>    represented as the service-value.
>
> Section 8.16.2 "Serivce Types and Services" and 6.16.3 "Service
> Reference" for details.
>
> Note that I wish there was a way to generalize the ideas behind this
> pattern rather than have it be reinvented for everything that needs
> them. This is part of why David and I turned to GOOPS in the initial
> prototype implementation; it's a lot of work figuring out how to set
> up extensibility in this way, at least for me. You might want to write
> a quick GOOPS version to understand what all the parameters are that
> are needed, then convert it to the services way of doing a general
> structure that wraps a specific structure.
>
> I suspect you won't need as much composability as services currently
> need, so the implementation of whatever this extensibility is is
> probably not as complicated as it is for services.
>
> As for how to share the ssh code, maybe just having the building-block
> procedures is good enough?
>
> Since all we support, so far, is this kind of ssh'ing, I don't want
> this to block the patch though. It could be that we file this as a bug
> and add a TODO above the code for the moment saying "we know this
> isn't right/ideal". However, there is some risk that this could result
> in people writing out machine configurations that later break... I
> dunno.
>
> Thoughts?

Ah, so you mean having the configuration as part of the environment type
rather than the machine type? I think that does make more sense... If
that is what you meant, let me know and I'll send another patch
implementing the change tomorrow. It should be an easy fix.

> If you remove it, please leave a comment noting the difference between
> this and "guix system" and why you thought it was safe to remove.  If it
> turns out to not be the case, there's a breadcrumb there to figure out
> how to add it back.

Added :]

Jakob L. Kreuze writes:

> Christopher Lemmer Webber <cwebber@dustycloud.org> writes:
>
>> Jakob, do you mind checking out the issue above? I think it shouldn't
>> block merging these patches but perhaps we should file an issue saying
>> that when the shepherd issue is merged, changes should be made to guix
>> deploy as well. What do you think?
>
> I took a peek and added a comment about it to machine.scm, are you
> suggesting that we track it on debbugs?

Yeha, it will help us be less likely to forget it as well as having a
nicer place to track it... I think? :)

Christopher Lemmer Webber <cwebber@dustycloud.org> writes:

> Yeha, it will help us be less likely to forget it as well as having a
> nicer place to track it... I think? :)

Sounds good to me. I'll file it as soon as this patch gets merged
upstream, since we have Carlo's ticket for tracking it in 'guix system
reconfigure'.