From mboxrd@z Thu Jan 1 00:00:00 1970 Received: from eggs.gnu.org ([2001:470:142:3::10]:47399) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hhL1w-0003ff-Qe for guix-patches@gnu.org; Sat, 29 Jun 2019 17:37:16 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1hhL1s-0005Sv-Db for guix-patches@gnu.org; Sat, 29 Jun 2019 17:37:08 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:59673) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1hhL1r-0005Rc-NC for guix-patches@gnu.org; Sat, 29 Jun 2019 17:37:04 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1hhL1r-000585-Hw for guix-patches@gnu.org; Sat, 29 Jun 2019 17:37:03 -0400 Subject: [bug#36404] [PATCH 2/5] gnu: Add machine type for deployment specifications. Resent-Message-ID: References: <87o92ianbj.fsf@sdf.lonestar.org> <87imspj0ks.fsf_-_@sdf.lonestar.org> <87ef3dj0j9.fsf_-_@sdf.lonestar.org> <87a7e1j0hy.fsf_-_@sdf.lonestar.org> From: Christopher Lemmer Webber In-reply-to: <87a7e1j0hy.fsf_-_@sdf.lonestar.org> Date: Sat, 29 Jun 2019 17:36:31 -0400 Message-ID: <87k1d4kra8.fsf@dustycloud.org> MIME-Version: 1.0 Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+kyle=kyleam.com@gnu.org Sender: "Guix-patches" To: 36404@debbugs.gnu.org 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 =3D \ > 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 =3D \ > 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 =3D \ > %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 =3D \ > %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 =C2=A9 2019 David Thompson > +;;; Copyright =C2=A9 2019 Jakob L. Kreuze > +;;; > +;;; 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 . > + > +(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 i= n a > +;;; heterogeneous Guix deployment. The interface allows users of specify= system > +;;; configurations and the means by which resources should be provisione= d on a > +;;; per-host basis. > +;;; > +;;; Code: > + > +(define-record-type* machine > + make-machine > + machine? > + this-machine > + (system machine-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 r= eturning > +a list containing the path of the derivation file and the path of the de= rivation > +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 re= fers 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 rem= ote > +MACHINE, activating it on MACHINE and switching MACHINE to the new gener= ation." > + (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 refer= s 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 generati= on." (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 =C2=A9 2019 Jakob L. Kreuze > +;;; > +;;; 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 . > + > +(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 environmen= t for > +;;; such machines as 'managed-host. > +;;; > +;;; Code: > + > + > +;;; > +;;; SSH client parameter configuration. > +;;; > + > +(define-record-type* machine-ssh-configurati= on > + 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 env= ironment '~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 num= ber)) > + (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 '%loa= d-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 thi= s 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 ne= eded > +to realize the MACHINE's system configuration." > + (define target-services > + ;; Monadic expression evaluating to a list of (name output-path) pai= rs 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 mac= hine)) > + #: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 unloa= ded > + ;; 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 serv= ice)) > + 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 servi= ce)) > + (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 sur= e. > + #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 gener= ations > +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-pro= file > + generation)) > + (boot-parameters-path (string-append system-pa= th > + "/paramet= ers")) > + (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, a= nd > +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 "/boo= tcfg")) > + (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 std= out, > + ;; which confuses 'remote-eval' when it att= empts to > + ;; read a result from the remote REPL. We w= ork > + ;; around this by forcing the output to a s= tring. > + (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-parameter= s)) > + (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 wit= h an > +environment type of 'managed-host." > + (unless (machine-configuration machine) > + (error (format #f (G_ "no configuration specified for machine of env= ironment '~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 =C2=A9 2019 Jakob L. Kreuze > +;;; > +;;; 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 . > + > +(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 record derived from OS that is appropria= te 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=3D? 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 proc= edure > +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=3D" #$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, who= se > +first argument is the path to a writable disk image. Additional argument= s are > +passed as-is to qemu." > + (define kernel-arguments > + #~(list "console=3DttyS0" > + #+@(operating-system-kernel-arguments os "/dev/sda1"))) > + > + (define qemu-exec > + #~(begin > + (list (string-append #$qemu-minimal "/bin/" #$(qemu-command (%cu= rrent-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=3Dvirtio" > + "-object" "rng-random,filename=3D/dev/urandom,id=3Dguixsd-= vm-rng" > + "-device" "virtio-rng-pci,rng=3Dguixsd-vm-rng" > + "-vga" "std" > + "-m" "256" > + "-net" "user,hostfwd=3Dtcp::2222-:22"))) > + > + (define builder > + #~(call-with-output-file #$output > + (lambda (port) > + (format port "#!~a~% exec ~a -drive \"file=3D$@\"~%" > + #$(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 a= nd > +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' fa= ils 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 q= uirks > + ;; 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 cha= nce > + ;; 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 thi= s 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 no= t have > + ;; an "old configurations" submenu. Deployment, then, would resul= t in > + ;; this submenu being created, meaning an additional two 'menuent= ry' > + ;; fields rather than just one. > + (if (=3D 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.