From patchwork Fri Jun 28 13:35:06 2019 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: "Jakob L. Kreuze" X-Patchwork-Id: 14419 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 3EE721716F; Fri, 28 Jun 2019 15:42:29 +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 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 E39D71716D for ; Fri, 28 Jun 2019 15:42:28 +0100 (BST) Received: from localhost ([::1]:60964 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hgs55-0006Mj-BR for patchwork@mira.cbaines.net; Fri, 28 Jun 2019 10:42:27 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:57215) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hgr47-0002e7-41 for guix-patches@gnu.org; Fri, 28 Jun 2019 09:37:24 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1hgr3z-0001ha-BL for guix-patches@gnu.org; Fri, 28 Jun 2019 09:37:17 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:55272) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1hgr3m-0001Tj-DW for guix-patches@gnu.org; Fri, 28 Jun 2019 09:37:07 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1hgr3m-000324-9K for guix-patches@gnu.org; Fri, 28 Jun 2019 09:37:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#36404] [PATCH 1/5] ssh: Add 'identity' keyword to 'open-ssh-session'. Resent-From: zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Fri, 28 Jun 2019 13:37: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: "Thompson\, David" Received: via spool by 36404-submit@debbugs.gnu.org id=B36404.156172900811637 (code B ref 36404); Fri, 28 Jun 2019 13:37:02 +0000 Received: (at 36404) by debbugs.gnu.org; 28 Jun 2019 13:36:48 +0000 Received: from localhost ([127.0.0.1]:40583 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hgr3Y-00031d-B3 for submit@debbugs.gnu.org; Fri, 28 Jun 2019 09:36:48 -0400 Received: from mx.sdf.org ([205.166.94.20]:52565) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hgr3W-00031U-2v for 36404@debbugs.gnu.org; Fri, 28 Jun 2019 09:36:46 -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 x5SDaiij012381 (using TLSv1.2 with cipher AES256-GCM-SHA384 (256 bits) verified NO); Fri, 28 Jun 2019 13:36:45 GMT From: zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) References: <87o92ianbj.fsf@sdf.lonestar.org> <87imspj0ks.fsf_-_@sdf.lonestar.org> Date: Fri, 28 Jun 2019 09:35:06 -0400 In-Reply-To: <87imspj0ks.fsf_-_@sdf.lonestar.org> (Jakob L. Kreuze's message of "Fri, 28 Jun 2019 09:34:11 -0400") Message-ID: <87ef3dj0j9.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: , Cc: 36404@debbugs.gnu.org Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches * guix/ssh.scm (open-ssh-session): Add 'identity' keyword argument. --- guix/ssh.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/guix/ssh.scm b/guix/ssh.scm index 9b9baf54ea..a2387564a4 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -57,12 +57,13 @@ (define %compression "zlib@openssh.com,zlib") -(define* (open-ssh-session host #:key user port +(define* (open-ssh-session host #:key user port identity (compression %compression)) "Open an SSH session for HOST and return it. When USER and PORT are #f, use default values or whatever '~/.ssh/config' specifies; otherwise use them. Throw an error on failure." (let ((session (make-session #:user user + #:identity identity #:host host #:port port #:timeout 10 ;seconds From patchwork Fri Jun 28 13:35:53 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: 14420 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 85F9F1716D; Fri, 28 Jun 2019 15:42:42 +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 8B02B1716D for ; Fri, 28 Jun 2019 15:42:39 +0100 (BST) Received: from localhost ([::1]:60966 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hgs5H-0006YY-7f for patchwork@mira.cbaines.net; Fri, 28 Jun 2019 10:42:39 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:57585) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hgr4p-0004N5-Fe for guix-patches@gnu.org; Fri, 28 Jun 2019 09:38:11 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1hgr4k-0002iI-Cb for guix-patches@gnu.org; Fri, 28 Jun 2019 09:38:07 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:55278) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1hgr4k-0002hb-1b for guix-patches@gnu.org; Fri, 28 Jun 2019 09:38:02 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1hgr4j-00033o-SX for guix-patches@gnu.org; Fri, 28 Jun 2019 09:38:01 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#36404] [PATCH 2/5] 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: Fri, 28 Jun 2019 13:38:01 +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: "Thompson\, David" Received: via spool by 36404-submit@debbugs.gnu.org id=B36404.156172906511742 (code B ref 36404); Fri, 28 Jun 2019 13:38:01 +0000 Received: (at 36404) by debbugs.gnu.org; 28 Jun 2019 13:37:45 +0000 Received: from localhost ([127.0.0.1]:40589 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hgr4M-00033B-Ma for submit@debbugs.gnu.org; Fri, 28 Jun 2019 09:37:44 -0400 Received: from mx.sdf.org ([205.166.94.20]:52317) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hgr4H-000330-Cu for 36404@debbugs.gnu.org; Fri, 28 Jun 2019 09:37:37 -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 x5SDbVkM017910 (using TLSv1.2 with cipher AES256-GCM-SHA384 (256 bits) verified NO); Fri, 28 Jun 2019 13:37:32 GMT From: zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) References: <87o92ianbj.fsf@sdf.lonestar.org> <87imspj0ks.fsf_-_@sdf.lonestar.org> <87ef3dj0j9.fsf_-_@sdf.lonestar.org> Date: Fri, 28 Jun 2019 09:35:53 -0400 In-Reply-To: <87ef3dj0j9.fsf_-_@sdf.lonestar.org> (Jakob L. Kreuze's message of "Fri, 28 Jun 2019 09:35:06 -0400") Message-ID: <87a7e1j0hy.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: , Cc: 36404@debbugs.gnu.org Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches * 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 +;;; 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 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)) + +;;; 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/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") From patchwork Fri Jun 28 13:36:35 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: 14421 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 B01F11716F; Fri, 28 Jun 2019 15:42:57 +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 527A51716D for ; Fri, 28 Jun 2019 15:42:57 +0100 (BST) Received: from localhost ([::1]:60968 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hgs5Z-0006mc-0C for patchwork@mira.cbaines.net; Fri, 28 Jun 2019 10:42:57 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:57908) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hgr5k-0005IC-Gf for guix-patches@gnu.org; Fri, 28 Jun 2019 09:39:05 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1hgr5i-0003lC-Nu for guix-patches@gnu.org; Fri, 28 Jun 2019 09:39:04 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:55288) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1hgr5i-0003ku-HI for guix-patches@gnu.org; Fri, 28 Jun 2019 09:39:02 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1hgr5i-00035o-CG for guix-patches@gnu.org; Fri, 28 Jun 2019 09:39:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#36404] [PATCH 3/5] Add 'guix deploy'. Resent-From: zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Fri, 28 Jun 2019 13:39: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: "Thompson\, David" Received: via spool by 36404-submit@debbugs.gnu.org id=B36404.156172909611811 (code B ref 36404); Fri, 28 Jun 2019 13:39:02 +0000 Received: (at 36404) by debbugs.gnu.org; 28 Jun 2019 13:38:16 +0000 Received: from localhost ([127.0.0.1]:40593 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hgr4y-00034R-4c for submit@debbugs.gnu.org; Fri, 28 Jun 2019 09:38:16 -0400 Received: from mx.sdf.org ([205.166.94.20]:52114) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hgr4w-00034J-H4 for 36404@debbugs.gnu.org; Fri, 28 Jun 2019 09:38:15 -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 x5SDcCZq018119 (using TLSv1.2 with cipher AES256-GCM-SHA384 (256 bits) verified NO); Fri, 28 Jun 2019 13:38:13 GMT From: zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) References: <87o92ianbj.fsf@sdf.lonestar.org> <87imspj0ks.fsf_-_@sdf.lonestar.org> <87ef3dj0j9.fsf_-_@sdf.lonestar.org> <87a7e1j0hy.fsf_-_@sdf.lonestar.org> Date: Fri, 28 Jun 2019 09:36:35 -0400 In-Reply-To: <87a7e1j0hy.fsf_-_@sdf.lonestar.org> (Jakob L. Kreuze's message of "Fri, 28 Jun 2019 09:35:53 -0400") Message-ID: <875zopj0gs.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: , Cc: 36404@debbugs.gnu.org Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches * guix/scripts/deploy.scm: New file. * Makefile.am (MODULES): Add it. --- Makefile.am | 1 + guix/scripts/deploy.scm | 90 +++++++++++++++++++++++++++++++++++++++++ 2 files changed, 91 insertions(+) create mode 100644 guix/scripts/deploy.scm diff --git a/Makefile.am b/Makefile.am index 9156554635..8dbc220489 100644 --- a/Makefile.am +++ b/Makefile.am @@ -266,6 +266,7 @@ MODULES = \ guix/scripts/weather.scm \ guix/scripts/container.scm \ guix/scripts/container/exec.scm \ + guix/scripts/deploy.scm \ guix.scm \ $(GNU_SYSTEM_MODULES) diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm new file mode 100644 index 0000000000..c52434f518 --- /dev/null +++ b/guix/scripts/deploy.scm @@ -0,0 +1,90 @@ +;;; 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 (guix scripts deploy) + #:use-module (gnu machine) + #:use-module (guix scripts) + #:use-module (guix scripts build) + #:use-module (guix store) + #:use-module (guix ui) + #:use-module (ice-9 format) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-37) + #:export (guix-deploy)) + +;;; Commentary: +;;; +;;; This program provides a command-line interface to (gnu machine), allowing +;;; users to perform remote deployments through specification files. +;;; +;;; Code: + + + +(define (show-help) + (display (G_ "Usage: guix deploy [OPTION] FILE... +Perform the deployment specified by FILE.\n")) + (show-build-options-help) + (newline) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + (cons* (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + %standard-build-options)) + +(define %default-options + '((system . ,(%current-system)) + (substitutes? . #t) + (build-hook? . #t) + (graft? . #t) + (debug . 0) + (verbosity . 2))) + +(define (load-source-file file) + "Load FILE as a user module." + (let ((module (make-user-module '()))) + (load* file module))) + +(define (guix-deploy . args) + (define (handle-argument arg result) + (alist-cons 'file arg result)) + (let* ((opts (parse-command-line args %options (list %default-options) + #:argument-handler handle-argument)) + (file (assq-ref opts 'file)) + (machines (or (and file (load-source-file file)) '()))) + (with-store store + (set-build-options-from-command-line store opts) + (for-each (lambda (machine) + (format #t "building ~a... " (machine-display-name machine)) + (run-with-store store (build-machine machine)) + (display "done\n")) + machines) + (for-each (lambda (machine) + (format #t "deploying to ~a... " (machine-display-name machine)) + (run-with-store store (deploy-machine machine)) + (display "done\n")) + machines)))) From patchwork Fri Jun 28 13:37:09 2019 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: "Jakob L. Kreuze" X-Patchwork-Id: 14417 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 519EB1716F; Fri, 28 Jun 2019 15:05:45 +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 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 C6D1E1716D for ; Fri, 28 Jun 2019 15:05:42 +0100 (BST) Received: from localhost ([::1]:60354 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hgrVV-0002VY-9Z for patchwork@mira.cbaines.net; Fri, 28 Jun 2019 10:05:41 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:57905) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hgr5k-0005I4-Bc for guix-patches@gnu.org; Fri, 28 Jun 2019 09:39:05 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1hgr5j-0003lt-6z for guix-patches@gnu.org; Fri, 28 Jun 2019 09:39:04 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:55289) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1hgr5j-0003ld-0U for guix-patches@gnu.org; Fri, 28 Jun 2019 09:39:03 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1hgr5i-00035w-Tu for guix-patches@gnu.org; Fri, 28 Jun 2019 09:39:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#36404] [PATCH 4/5] Export the (gnu machine) interface. Resent-From: zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Fri, 28 Jun 2019 13:39: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: "Thompson\, David" Received: via spool by 36404-submit@debbugs.gnu.org id=B36404.156172913011870 (code B ref 36404); Fri, 28 Jun 2019 13:39:02 +0000 Received: (at 36404) by debbugs.gnu.org; 28 Jun 2019 13:38:50 +0000 Received: from localhost ([127.0.0.1]:40599 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hgr5V-00035O-UK for submit@debbugs.gnu.org; Fri, 28 Jun 2019 09:38:50 -0400 Received: from mx.sdf.org ([205.166.94.20]:51920) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hgr5U-00035H-IP for 36404@debbugs.gnu.org; Fri, 28 Jun 2019 09:38:48 -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 x5SDckRG006713 (using TLSv1.2 with cipher AES256-GCM-SHA384 (256 bits) verified NO); Fri, 28 Jun 2019 13:38:47 GMT From: zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) References: <87o92ianbj.fsf@sdf.lonestar.org> <87imspj0ks.fsf_-_@sdf.lonestar.org> <87ef3dj0j9.fsf_-_@sdf.lonestar.org> <87a7e1j0hy.fsf_-_@sdf.lonestar.org> <875zopj0gs.fsf_-_@sdf.lonestar.org> Date: Fri, 28 Jun 2019 09:37:09 -0400 In-Reply-To: <875zopj0gs.fsf_-_@sdf.lonestar.org> (Jakob L. Kreuze's message of "Fri, 28 Jun 2019 09:36:35 -0400") Message-ID: <871rzdj0fu.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: , Cc: 36404@debbugs.gnu.org Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches * gnu.scm (%public-modules): Add '(gnu machine)'. * gnu.scm (use-machine-modules): New macro. --- gnu.scm | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/gnu.scm b/gnu.scm index 2c29b6dc3f..fa643a5b92 100644 --- a/gnu.scm +++ b/gnu.scm @@ -27,7 +27,8 @@ #:use-module (guix packages) #:use-module (gnu packages) #:use-module (gnu services) - #:export (use-package-modules + #:export (use-machine-modules + use-package-modules use-service-modules use-system-modules)) @@ -45,6 +46,7 @@ (gnu system file-systems) (gnu bootloader) (gnu bootloader grub) + (gnu machine) (gnu system keyboard) (gnu system pam) (gnu system shadow) ; 'user-account' @@ -142,6 +144,10 @@ Try adding @code{(use-service-modules ~a)}.") (current-source-location)) hint))) +(define-syntax-rule (use-machine-modules module ...) + (try-use-modules package-module-hint + (gnu machine module) ...)) + (define-syntax-rule (use-package-modules module ...) (try-use-modules package-module-hint (gnu packages module) ...)) From patchwork Fri Jun 28 13:37:49 2019 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: "Jakob L. Kreuze" X-Patchwork-Id: 14418 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 387901716F; Fri, 28 Jun 2019 15:06:05 +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 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 BCE0A1716D for ; Fri, 28 Jun 2019 15:06:04 +0100 (BST) Received: from localhost ([::1]:60358 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hgrVs-0002lZ-E9 for patchwork@mira.cbaines.net; Fri, 28 Jun 2019 10:06:04 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:58169) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hgr6o-0005kF-RL for guix-patches@gnu.org; Fri, 28 Jun 2019 09:40:14 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1hgr6k-0004tK-Py for guix-patches@gnu.org; Fri, 28 Jun 2019 09:40:08 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:55294) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1hgr6f-0004im-UZ for guix-patches@gnu.org; Fri, 28 Jun 2019 09:40:04 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1hgr6f-00037j-Qk for guix-patches@gnu.org; Fri, 28 Jun 2019 09:40:01 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#36404] [PATCH 5/5] doc: Add section for 'guix deploy'. Resent-From: zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Fri, 28 Jun 2019 13:40:01 +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: "Thompson\, David" Received: via spool by 36404-submit@debbugs.gnu.org id=B36404.156172917011965 (code B ref 36404); Fri, 28 Jun 2019 13:40:01 +0000 Received: (at 36404) by debbugs.gnu.org; 28 Jun 2019 13:39:30 +0000 Received: from localhost ([127.0.0.1]:40605 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hgr6A-00036u-7k for submit@debbugs.gnu.org; Fri, 28 Jun 2019 09:39:30 -0400 Received: from mx.sdf.org ([205.166.94.20]:51727) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hgr68-00036k-FG for 36404@debbugs.gnu.org; Fri, 28 Jun 2019 09:39:29 -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 x5SDdQ3N004767 (using TLSv1.2 with cipher AES256-GCM-SHA384 (256 bits) verified NO); Fri, 28 Jun 2019 13:39:27 GMT From: zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) References: <87o92ianbj.fsf@sdf.lonestar.org> <87imspj0ks.fsf_-_@sdf.lonestar.org> <87ef3dj0j9.fsf_-_@sdf.lonestar.org> <87a7e1j0hy.fsf_-_@sdf.lonestar.org> <875zopj0gs.fsf_-_@sdf.lonestar.org> <871rzdj0fu.fsf_-_@sdf.lonestar.org> Date: Fri, 28 Jun 2019 09:37:49 -0400 In-Reply-To: <871rzdj0fu.fsf_-_@sdf.lonestar.org> (Jakob L. Kreuze's message of "Fri, 28 Jun 2019 09:37:09 -0400") Message-ID: <87woh5hlua.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: , Cc: 36404@debbugs.gnu.org Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches * doc/guix.texi: Add section "Invoking guix deploy". --- doc/guix.texi | 103 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 103 insertions(+) diff --git a/doc/guix.texi b/doc/guix.texi index f0d148ace0..948767d8c8 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -81,6 +81,7 @@ Documentation License''. * guix gc: (guix)Invoking guix gc. Reclaiming unused disk space. * guix pull: (guix)Invoking guix pull. Update the list of available packages. * guix system: (guix)Invoking guix system. Manage the operating system configuration. +* guix deploy: (guix)Invoking guix deploy. Manage operating system configurations for remote hosts. @end direntry @dircategory Software development @@ -269,6 +270,7 @@ System Configuration * Initial RAM Disk:: Linux-Libre bootstrapping. * Bootloader Configuration:: Configuring the boot loader. * Invoking guix system:: Instantiating a system configuration. +* Invoking guix deploy:: Deploying a system configuration to a remote host. * Running Guix in a VM:: How to run Guix System in a virtual machine. * Defining Services:: Adding new service definitions. @@ -10303,6 +10305,7 @@ instance to support new system services. * Initial RAM Disk:: Linux-Libre bootstrapping. * Bootloader Configuration:: Configuring the boot loader. * Invoking guix system:: Instantiating a system configuration. +* Invoking guix deploy:: Deploying a system configuration to a remote host. * Running Guix in a VM:: How to run Guix System in a virtual machine. * Defining Services:: Adding new service definitions. @end menu @@ -25399,6 +25402,106 @@ example graph. @end table +@node Invoking guix deploy +@section Invoking @code{guix deploy} + +In addition to managing a machine's configuration locally through operating +system declarations, Guix also provides the ability to managing multiple remote +hosts as a logical ``deployment''. This is done using @command{guix deploy}. + +@example +guix deploy @var{file} +@end example + +Such an invocation will deploy the machines that the code within @var{file} +evaluates to. As an example, @var{file} might contain a definition like this: + +@example +;; This is a Guix deployment of a "bare bones" setup, with +;; no X11 display server, to a machine with an SSH daemon +;; listening on localhost:2222. A configuration such as this +;; may be appropriate for virtual machine with ports +;; forwarded to the host's loopback interface. + +(use-modules (gnu) (guix)) +(use-machine-modules ssh) +(use-service-modules networking ssh) +(use-package-modules bootloaders) + +(define %system + (operating-system + (host-name "gnu-deployed") + (timezone "Etc/UTC") + (bootloader (bootloader-configuration + (bootloader grub-bootloader) + (target "/dev/vda") + (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)))) + +(list (machine + (system %system) + (environment 'managed-host) + (configuration (machine-ssh-configuration + (host-name "localhost") + (identity "./id_rsa") + (port 2222))))) +@end example + +The file should evaluate to a list of machines, rather than just one. This +example, upon being deployed, will create a new generation on the remote system +realizing the operating-system configuration @var{%system}. @var{environment} +and @var{configuration} specify how the machine should be provisioned--that is, +deployment and management of computing resources. The above example does not +provision any resources -- a @code{'managed-host} is a machine that is already +up and running the Guix system. A more complex deployment may involve +i.e. starting virtual machines through a VPS provider, however, in which case a +different @var{environment} types would be used. + +@deftp {Data Type} machine +This is the data type representing a single machine in a heterogeneous Guix +deployment. + +@table @asis +@item @code{system} +The object of the operating system configuration to deploy. + +@item @code{environment} +A symbol describing how the machine should be provisioned. At the moment, only +the only supported value is @code{'managed-host}. + +@item @code{configuration} (default: @code{#f}) +An object describing the configuration for the machine's @code{environment}. If +the @code{environment} has a default configuration, @code{#f} can be used. If +@code{#f} is used for an environment with no default configuration, however, an +error will be thrown. +@end table +@end deftp + +@deftp {Data Type} machine-ssh-configuration +This is the data type representing the SSH client parameters for connecting to a +@code{'managed-host}. + +@table @asis +@item @code{host-name} +@item @code{port} (default: @code{22}) +@item @code{user} (default: @code{"root"}) +@item @code{identity} (default: @code{#f}) +If specified, the path to the SSH private key to use to authenticate with the +remote host. +@end table +@end deftp + @node Running Guix in a VM @section Running Guix in a Virtual Machine