From patchwork Thu Jun 27 18:40:18 2019 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: "Jakob L. Kreuze" X-Patchwork-Id: 14407 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id EE25517178; Thu, 27 Jun 2019 19:43:58 +0100 (BST) X-Spam-Checker-Version: SpamAssassin 3.4.0 (2014-02-07) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-1.9 required=5.0 tests=BAYES_00,URIBL_BLOCKED autolearn=ham autolearn_force=no version=3.4.0 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTP id A0ECC17176 for ; Thu, 27 Jun 2019 19:43:57 +0100 (BST) Received: from localhost ([::1]:53626 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hgZNE-0002fj-B7 for patchwork@mira.cbaines.net; Thu, 27 Jun 2019 14:43:57 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:50585) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hgZMc-0002TR-QI for guix-patches@gnu.org; Thu, 27 Jun 2019 14:43:26 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1hgZMN-0000xC-1h for guix-patches@gnu.org; Thu, 27 Jun 2019 14:43:13 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:54352) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1hgZMM-0000wt-HL for guix-patches@gnu.org; Thu, 27 Jun 2019 14:43:02 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1hgZMM-00043B-D4 for guix-patches@gnu.org; Thu, 27 Jun 2019 14:43:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#36404] [PATCH 3/6] gnu: Add machine type for deployment specifications. Resent-From: zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Thu, 27 Jun 2019 18:43:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 36404 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 36404@debbugs.gnu.org Received: via spool by 36404-submit@debbugs.gnu.org id=B36404.156166092615463 (code B ref 36404); Thu, 27 Jun 2019 18:43:02 +0000 Received: (at 36404) by debbugs.gnu.org; 27 Jun 2019 18:42:06 +0000 Received: from localhost ([127.0.0.1]:39656 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hgZLL-00040o-MJ for submit@debbugs.gnu.org; Thu, 27 Jun 2019 14:42:06 -0400 Received: from mx.sdf.org ([205.166.94.20]:51486) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hgZLH-00040a-4D for 36404@debbugs.gnu.org; Thu, 27 Jun 2019 14:41:58 -0400 Received: from Epsilon (pool-173-76-53-40.bstnma.fios.verizon.net [173.76.53.40]) (authenticated (0 bits)) by mx.sdf.org (8.15.2/8.14.5) with ESMTPSA id x5RIfrbS019842 (using TLSv1.2 with cipher AES256-GCM-SHA384 (256 bits) verified NO) for <36404@debbugs.gnu.org>; Thu, 27 Jun 2019 18:41:54 GMT From: zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) References: <87o92ianbj.fsf@sdf.lonestar.org> <87imsqan66.fsf@sdf.lonestar.org> <87ef3ean4i.fsf_-_@sdf.lonestar.org> Date: Thu, 27 Jun 2019 14:40:18 -0400 In-Reply-To: <87ef3ean4i.fsf_-_@sdf.lonestar.org> (Jakob L. Kreuze's message of "Thu, 27 Jun 2019 14:39:41 -0400") Message-ID: <87a7e2an3h.fsf_-_@sdf.lonestar.org> User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/26.2 (gnu/linux) MIME-Version: 1.0 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 209.51.188.43 X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches 2019-06-26 Jakob L. Kreuze * tests/machine.scm: New file. * Makefile.am (SCM_TESTS): Add it. * gnu/machine/ssh.scm: New file. * gnu/local.mk (GNU_SYSTEM_MODULES): Add it. * gnu/machine.scm (machine, sshable-machine): Delete. * gnu/machine.scm: (machine): New record type. * gnu/machine.scm: (display-name, build-os, deploy-os, host-name) (ssh-port, ssh-user): Delete. * gnu/machine.scm: (remote-eval): Rewrite procedure. * gnu/machine.scm: (machine-display-name, build-machine) (deploy-machine): New procedures. All callers changed. --- Makefile.am | 3 +- gnu/local.mk | 4 +- gnu/machine.scm | 140 ++++++++----- gnu/machine/ssh.scm | 355 +++++++++++++++++++++++++++++++ guix/scripts/deploy.scm | 8 +- tests/machine.scm | 450 ++++++++++++++++++++++++++++++++++++++++ 6 files changed, 899 insertions(+), 61 deletions(-) create mode 100644 gnu/machine/ssh.scm create mode 100644 tests/machine.scm diff --git a/Makefile.am b/Makefile.am index ba01264a4b..8dbc220489 100644 --- a/Makefile.am +++ b/Makefile.am @@ -424,7 +424,8 @@ SCM_TESTS = \ tests/import-utils.scm \ tests/store-database.scm \ tests/store-deduplication.scm \ - tests/store-roots.scm + tests/store-roots.scm \ + tests/machine.scm SH_TESTS = \ tests/guix-build.sh \ diff --git a/gnu/local.mk b/gnu/local.mk index f973a8d804..ad87de5ea7 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -563,7 +563,9 @@ GNU_SYSTEM_MODULES = \ %D%/system/shadow.scm \ %D%/system/uuid.scm \ %D%/system/vm.scm \ - %D%/machine.scm \ + \ + %D%/machine.scm \ + %D%/machine/ssh.scm \ \ %D%/build/accounts.scm \ %D%/build/activation.scm \ diff --git a/gnu/machine.scm b/gnu/machine.scm index 4fde7d5c01..900a2020dc 100644 --- a/gnu/machine.scm +++ b/gnu/machine.scm @@ -1,59 +1,89 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 David Thompson +;;; Copyright © 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 packages package-management) #:select (guix)) #:use-module (gnu system) #:use-module (guix derivations) - #:use-module (guix inferior) - #:use-module (guix packages) - #:use-module (guix ssh) + #:use-module (guix monads) + #:use-module (guix records) #:use-module (guix store) - #:use-module (oop goops) - #:use-module (ssh session) - #:export ( - system - display-name - build-os - deploy-os - remote-eval - - - host-name - ssh-port - ssh-user)) - -(define-class () - (system #:getter system #:init-keyword #:system)) - -(define-method (display-name (machine )) - (operating-system-host-name (system machine))) - -(define-method (build-os (machine ) store) - (let* ((guixdrv (run-with-store store (package->derivation guix))) - (guixdir (and (build-derivations store (list guixdrv)) - (derivation->output-path guixdrv))) - (osdrv (run-with-store store (operating-system-derivation - (system machine))))) - (and (build-derivations store (list osdrv)) - (list (derivation-file-name osdrv) - (derivation->output-path osdrv))))) - -(define-method (deploy-os (machine ) store osdrv) - (error "not implemented")) - -(define-method (remote-eval (machine ) exp) - (error "not implemented")) - -(define-class () - (host-name #:getter host-name #:init-keyword #:host-name) - (ssh-port #:getter ssh-port #:init-keyword #:ssh-port #:init-form 22) - (ssh-user #:getter ssh-user #:init-keyword #:ssh-user #:init-form "root") - ;; ??? - SSH key config? - ) - -(define-method (deploy-os (machine ) store osdrvs) - (let ((session (open-ssh-session (host-name machine) - #:user (ssh-user machine) - #:port (ssh-port machine)))) - (with-store store (send-files store osdrvs - (connect-to-remote-daemon session) - #:recursive? #t)) - #t)) + #:export (machine + machine? + this-machine + + machine-system + machine-environment + machine-configuration + machine-display-name + + build-machine + deploy-machine + remote-eval)) + +;;; Commentary: +;;; +;;; This module provides the types used to declare individual machines in a +;;; heterogeneous Guix deployment. The interface allows users of specify system +;;; configurations and the means by which resources should be provisioned on a +;;; per-host basis. +;;; +;;; Code: + +(define-record-type* machine + 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 returning +a list containing the path of the derivation file and the path of the derivation +output." + (let ((os (machine-system machine))) + (mlet* %store-monad ((osdrv (operating-system-derivation os)) + (_ ((store-lift build-derivations) (list osdrv)))) + (return (list (derivation-file-name osdrv) + (derivation->output-path osdrv)))))) + +(define (remote-eval machine exp) + "Evaluate EXP, a gexp, on MACHINE. Ensure that all the elements EXP refers to +are built and deployed to MACHINE beforehand." + (case (machine-environment machine) + ((managed-host) + ((@@ (gnu machine ssh) remote-eval) machine exp)) + (else + (let ((type (machine-environment machine))) + (error "unsupported environment type" type))))) + +(define (deploy-machine machine) + "Monadic procedure transferring the new system's OS closure to the remote +MACHINE, activating it on MACHINE and switching MACHINE to the new generation." + (case (machine-environment machine) + ((managed-host) + ((@@ (gnu machine ssh) deploy-machine) machine)) + (else + (let ((type (machine-environment machine))) + (error "unsupported environment type" type))))) diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm new file mode 100644 index 0000000000..a8f946e19f --- /dev/null +++ b/gnu/machine/ssh.scm @@ -0,0 +1,355 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Jakob L. Kreuze +;;; +;;; 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 environment for +;;; such machines as 'managed-host. +;;; +;;; Code: + + +;;; +;;; SSH client parameter configuration. +;;; + +(define-record-type* machine-ssh-configuration + make-machine-ssh-configuration + machine-ssh-configuration? + this-machine-ssh-configuration + (host-name machine-ssh-configuration-host-name) ; string + (port machine-ssh-configuration-port ; integer + (default 22)) + (user machine-ssh-configuration-user ; string + (default "root")) + (identity machine-ssh-configuration-identity ; path to a private key + (default #f)) + (session machine-ssh-configuration-session ; session + (default #f))) + +(define (machine-ssh-session machine) + "Return the SSH session that was given in MACHINE's configuration, or create +one from the configuration's parameters if one was not provided." + (let ((config (machine-configuration machine))) + (if (machine-ssh-configuration? config) + (or (machine-ssh-configuration-session config) + (let ((host-name (machine-ssh-configuration-host-name config)) + (user (machine-ssh-configuration-user config)) + (port (machine-ssh-configuration-port config)) + (identity (machine-ssh-configuration-identity config))) + (open-ssh-session host-name + #:user user + #:port port + #:identity identity))) + (error "unsupported configuration type")))) + + +;;; +;;; Remote evaluation. +;;; + +(define (remote-eval machine exp) + "Internal implementation of 'remote-eval' for MACHINE instances with an +environment type of 'managed-host." + (unless (machine-configuration machine) + (error (format #f (G_ "no configuration specified for machine of environment '~a'") + (symbol->string (machine-environment machine))))) + ((@ (guix remote) remote-eval) exp (machine-ssh-session machine))) + + +;;; +;;; System deployment. +;;; + +(define (switch-to-system machine) + "Monadic procedure creating a new generation on MACHINE and execute the +activation script for the new system configuration." + (define (remote-exp drv script) + (with-extensions (list guile-gcrypt) + (with-imported-modules (source-module-closure '((guix config) + (guix profiles) + (guix utils))) + #~(begin + (use-modules (guix config) + (guix profiles) + (guix utils)) + + (define %system-profile + (string-append %state-directory "/profiles/system")) + + (let* ((system #$(derivation->output-path drv)) + (number (1+ (generation-number %system-profile))) + (generation (generation-file-name %system-profile number)) + (old-env (environ)) + (old-path %load-path) + (old-cpath %load-compiled-path)) + (switch-symlinks generation system) + (switch-symlinks %system-profile generation) + ;; Guard against the activation script modifying $PATH. + (dynamic-wind + (const #t) + (lambda () + (setenv "GUIX_NEW_SYSTEM" system) + ;; Guard against the activation script modifying '%load-path'. + (dynamic-wind + (const #t) + (lambda () + ;; The activation script may write to stdout, which + ;; confuses 'remote-eval' when it attempts to read a + ;; result from the remote REPL. We work around this by + ;; forcing the output to a string. + (with-output-to-string + (lambda () + (primitive-load #$script)))) + (lambda () + (set! %load-path old-path) + (set! %load-compiled-path old-cpath)))) + (lambda () + (environ old-env)))))))) + + (let* ((os (machine-system machine)) + (script (operating-system-activation-script os))) + (mlet* %store-monad ((drv (operating-system-derivation os))) + (remote-eval machine (remote-exp drv script))))) + +(define (upgrade-shepherd-services machine) + "Monadic procedure unloading and starting services on the remote as needed +to realize the MACHINE's system configuration." + (define target-services + ;; Monadic expression evaluating to a list of (name output-path) pairs for + ;; all of MACHINE's services. + (mapm %store-monad + (lambda (service) + (mlet %store-monad ((file ((compose lower-object + shepherd-service-file) + service))) + (return (list (shepherd-service-canonical-name service) + (derivation->output-path file))))) + (service-value + (fold-services (operating-system-services (machine-system machine)) + #:target-type shepherd-root-service-type)))) + + (define (remote-exp target-services) + (with-imported-modules '((gnu services herd)) + #~(begin + (use-modules (gnu services herd) + (srfi srfi-1)) + + (define running + (filter live-service-running (current-services))) + + (define (essential? service) + ;; Return #t if SERVICE is essential and should not be unloaded + ;; under any circumstance. + (memq (first (live-service-provision service)) + '(root shepherd))) + + (define (obsolete? service) + ;; Return #t if SERVICE can be safely unloaded. + (and (not (essential? service)) + (every (lambda (requirements) + (not (memq (first (live-service-provision service)) + requirements))) + (map live-service-requirement running)))) + + (define to-unload + (filter obsolete? + (remove (lambda (service) + (memq (first (live-service-provision service)) + (map first '#$target-services))) + running))) + + (define to-start + (remove (lambda (service-pair) + (memq (first service-pair) + (map (compose first live-service-provision) + running))) + '#$target-services)) + + ;; Unload obsolete services. + (for-each (lambda (service) + (false-if-exception + (unload-service service))) + to-unload) + + ;; Load the service files for any new services and start them. + (load-services/safe (map second to-start)) + (for-each start-service (map first to-start)) + + #t))) + + (mlet %store-monad ((target-services target-services)) + (remote-eval machine (remote-exp target-services)))) + +(define (machine-boot-parameters machine) + "Monadic procedure returning a list of 'boot-parameters' for the generations +of MACHINE's system profile, ordered from most recent to oldest." + (define bootable-kernel-arguments + (@@ (gnu system) bootable-kernel-arguments)) + + (define remote-exp + (with-extensions (list guile-gcrypt) + (with-imported-modules (source-module-closure '((guix config) + (guix profiles))) + #~(begin + (use-modules (guix config) + (guix profiles) + (ice-9 textual-ports)) + + (define %system-profile + (string-append %state-directory "/profiles/system")) + + (define (read-file path) + (call-with-input-file path + (lambda (port) + (get-string-all port)))) + + (map (lambda (generation) + (let* ((system-path (generation-file-name %system-profile + generation)) + (boot-parameters-path (string-append system-path + "/parameters")) + (time (stat:mtime (lstat system-path)))) + (list generation + system-path + time + (read-file boot-parameters-path)))) + (reverse (generation-numbers %system-profile))))))) + + (mlet* %store-monad ((generations (remote-eval machine remote-exp))) + (return + (map (lambda (generation) + (match generation + ((generation system-path time serialized-params) + (let* ((params (call-with-input-string serialized-params + read-boot-parameters)) + (root (boot-parameters-root-device params)) + (label (boot-parameters-label params))) + (boot-parameters + (inherit params) + (label + (string-append label " (#" + (number->string generation) ", " + (let ((time (make-time time-utc 0 time))) + (date->string (time-utc->date time) + "~Y-~m-~d ~H:~M")) + ")")) + (kernel-arguments + (append (bootable-kernel-arguments system-path root) + (boot-parameters-kernel-arguments params)))))))) + generations)))) + +(define (install-bootloader machine) + "Create a bootloader entry for the new system generation on MACHINE, and +configure the bootloader to boot that generation by default." + (define bootloader-installer-script + (@@ (guix scripts system) bootloader-installer-script)) + + (define (remote-exp installer bootcfg bootcfg-file) + (with-extensions (list guile-gcrypt) + (with-imported-modules (source-module-closure '((gnu build install) + (guix store) + (guix utils))) + #~(begin + (use-modules (gnu build install) + (guix store) + (guix utils)) + (let* ((gc-root (string-append "/" %gc-roots-directory "/bootcfg")) + (temp-gc-root (string-append gc-root ".new")) + (old-path %load-path) + (old-cpath %load-compiled-path)) + (switch-symlinks temp-gc-root gc-root) + + (unless (false-if-exception + (begin + (install-boot-config #$bootcfg #$bootcfg-file "/") + ;; Guard against the activation script modifying + ;; '%load-path'. + (dynamic-wind + (const #t) + (lambda () + ;; The installation script may write to stdout, + ;; which confuses 'remote-eval' when it attempts to + ;; read a result from the remote REPL. We work + ;; around this by forcing the output to a string. + (with-output-to-string + (lambda () + (primitive-load #$installer)))) + (lambda () + (set! %load-path old-path) + (set! %load-compiled-path old-cpath))))) + (delete-file temp-gc-root) + (error "failed to install bootloader")) + + (rename-file temp-gc-root gc-root) + #t))))) + + (mlet* %store-monad ((boot-parameters (machine-boot-parameters machine))) + (let* ((os (machine-system machine)) + (bootloader ((compose bootloader-configuration-bootloader + operating-system-bootloader) + os)) + (bootloader-target (bootloader-configuration-target + (operating-system-bootloader os))) + (installer (bootloader-installer-script + (bootloader-installer bootloader) + (bootloader-package bootloader) + bootloader-target + "/")) + (menu-entries (map boot-parameters->menu-entry boot-parameters)) + (bootcfg (operating-system-bootcfg os menu-entries)) + (bootcfg-file (bootloader-configuration-file bootloader))) + (remote-eval machine (remote-exp installer bootcfg bootcfg-file))))) + +(define (deploy-machine machine) + "Internal implementation of 'deploy-machine' for MACHINE instances with an +environment type of 'managed-host." + (unless (machine-configuration machine) + (error (format #f (G_ "no configuration specified for machine of environment '~a'") + (symbol->string (machine-environment machine))))) + (mbegin %store-monad + (switch-to-system machine) + (upgrade-shepherd-services machine) + (install-bootloader machine))) diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm index bcb3a2ea4c..0be279642b 100644 --- a/guix/scripts/deploy.scm +++ b/guix/scripts/deploy.scm @@ -64,13 +64,13 @@ ;; Build all the OSes and create a mapping from machine to OS derivation ;; for use in the deploy step. (let ((osdrvs (map (lambda (machine) - (format #t "building ~a... " (display-name machine)) - (let ((osdrv (build-os machine store))) + (format #t "building ~a... " (machine-display-name machine)) + (let ((osdrv (run-with-store store (build-machine machine)))) (display "done\n") (cons machine osdrv))) machines))) (for-each (lambda (machine) - (format #t "deploying to ~a... " (display-name machine)) - (deploy-os machine store (assq-ref osdrvs machine)) + (format #t "deploying to ~a... " (machine-display-name machine)) + (run-with-store store (deploy-machine machine)) (display "done\n")) machines))))) diff --git a/tests/machine.scm b/tests/machine.scm new file mode 100644 index 0000000000..390c0189bb --- /dev/null +++ b/tests/machine.scm @@ -0,0 +1,450 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Jakob L. Kreuze +;;; +;;; 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)) + + +;;; +;;; 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 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")