From patchwork Tue Jul 2 00:16:13 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: 14452 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 819FD17193; Tue, 2 Jul 2019 04:10:51 +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=unavailable 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 4BDED17191 for ; Tue, 2 Jul 2019 04:10:51 +0100 (BST) Received: from localhost ([::1]:47834 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hi9By-00020f-OA for patchwork@mira.cbaines.net; Mon, 01 Jul 2019 23:10:50 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:57958) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hi6sh-0006wV-1p for guix-patches@gnu.org; Mon, 01 Jul 2019 20:42:53 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1hi6sH-000540-3z for guix-patches@gnu.org; Mon, 01 Jul 2019 20:42:46 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:37510) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1hi6Tl-0007qV-To for guix-patches@gnu.org; Mon, 01 Jul 2019 20:17:33 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1hi6Tl-0004uN-O5 for guix-patches@gnu.org; Mon, 01 Jul 2019 20:17:01 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#36404] [PATCH 1/4] 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: Tue, 02 Jul 2019 00:17: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: Ludovic =?utf-8?q?Court=C3=A8s?= Received: via spool by 36404-submit@debbugs.gnu.org id=B36404.156202658218817 (code B ref 36404); Tue, 02 Jul 2019 00:17:01 +0000 Received: (at 36404) by debbugs.gnu.org; 2 Jul 2019 00:16:22 +0000 Received: from localhost ([127.0.0.1]:46331 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hi6T5-0004tP-Kk for submit@debbugs.gnu.org; Mon, 01 Jul 2019 20:16:22 -0400 Received: from mx.sdf.org ([205.166.94.20]:56364) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hi6T3-0004tD-Qh for 36404@debbugs.gnu.org; Mon, 01 Jul 2019 20:16:18 -0400 Received: from Upsilon (mobile-107-107-57-169.mycingular.net [107.107.57.169]) (authenticated (0 bits)) by mx.sdf.org (8.15.2/8.14.5) with ESMTPSA id x620GEbf004314 (using TLSv1.2 with cipher AES256-GCM-SHA384 (256 bits) verified NO); Tue, 2 Jul 2019 00:16:16 GMT From: zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) References: <87o92ianbj.fsf@sdf.lonestar.org> <87o92glap5.fsf@dustycloud.org> <878sthoqzi.fsf@gnu.org> <87imsl9tsx.fsf_-_@sdf.lonestar.org> Date: Mon, 01 Jul 2019 20:16:13 -0400 In-Reply-To: <87imsl9tsx.fsf_-_@sdf.lonestar.org> (Jakob L. Kreuze's message of "Mon, 01 Jul 2019 20:14:22 -0400") Message-ID: <87ef399tpu.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 | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/guix/ssh.scm b/guix/ssh.scm index 9b9baf54e..9bf10b9a0 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -57,12 +57,14 @@ (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." + "Open an SSH session for HOST and return it. IDENTITY specifies the path of +a private key to use for authenticating with the host. When USER, PORT, or +IDENTITY 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 Tue Jul 2 00:17:03 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: 14450 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 2403317193; Tue, 2 Jul 2019 04:02:56 +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=unavailable 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 62E6617191 for ; Tue, 2 Jul 2019 04:02:55 +0100 (BST) Received: from localhost ([::1]:47738 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hi94J-0001Kb-0x for patchwork@mira.cbaines.net; Mon, 01 Jul 2019 23:02:55 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:32955) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hi74d-0000yz-QU for guix-patches@gnu.org; Mon, 01 Jul 2019 20:55:13 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1hi74a-00082l-Iq for guix-patches@gnu.org; Mon, 01 Jul 2019 20:55:07 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:37517) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1hi6Uk-00088o-Qd for guix-patches@gnu.org; Mon, 01 Jul 2019 20:18:22 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1hi6Uk-0004wF-AC for guix-patches@gnu.org; Mon, 01 Jul 2019 20:18:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#36404] [PATCH 2/4] 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: Tue, 02 Jul 2019 00:18: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: Ludovic =?utf-8?q?Court=C3=A8s?= Received: via spool by 36404-submit@debbugs.gnu.org id=B36404.156202664118920 (code B ref 36404); Tue, 02 Jul 2019 00:18:02 +0000 Received: (at 36404) by debbugs.gnu.org; 2 Jul 2019 00:17:21 +0000 Received: from localhost ([127.0.0.1]:46335 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hi6U1-0004v1-8i for submit@debbugs.gnu.org; Mon, 01 Jul 2019 20:17:21 -0400 Received: from mx.sdf.org ([205.166.94.20]:55471) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hi6Tv-0004up-91 for 36404@debbugs.gnu.org; Mon, 01 Jul 2019 20:17:13 -0400 Received: from Upsilon (mobile-107-107-57-169.mycingular.net [107.107.57.169]) (authenticated (0 bits)) by mx.sdf.org (8.15.2/8.14.5) with ESMTPSA id x620H4es006465 (using TLSv1.2 with cipher AES256-GCM-SHA384 (256 bits) verified NO); Tue, 2 Jul 2019 00:17:06 GMT From: zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) References: <87o92ianbj.fsf@sdf.lonestar.org> <87o92glap5.fsf@dustycloud.org> <878sthoqzi.fsf@gnu.org> <87imsl9tsx.fsf_-_@sdf.lonestar.org> <87ef399tpu.fsf_-_@sdf.lonestar.org> Date: Mon, 01 Jul 2019 20:17:03 -0400 In-Reply-To: <87ef399tpu.fsf_-_@sdf.lonestar.org> (Jakob L. Kreuze's message of "Mon, 01 Jul 2019 20:16:13 -0400") Message-ID: <87a7dx9tog.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. --- Makefile.am | 3 +- gnu/local.mk | 5 +- gnu/machine.scm | 118 ++++++++++++++ gnu/machine/ssh.scm | 363 ++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 487 insertions(+), 2 deletions(-) create mode 100644 gnu/machine.scm create mode 100644 gnu/machine/ssh.scm diff --git a/Makefile.am b/Makefile.am index 42307abae..f10c000ea 100644 --- a/Makefile.am +++ b/Makefile.am @@ -425,7 +425,8 @@ SCM_TESTS = \ tests/import-utils.scm \ tests/store-database.scm \ tests/store-deduplication.scm \ - tests/store-roots.scm + tests/store-roots.scm \ + tests/machine.scm SH_TESTS = \ tests/guix-build.sh \ diff --git a/gnu/local.mk b/gnu/local.mk index 81de156cf..0e17af953 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -562,6 +562,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 \ @@ -627,7 +630,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 000000000..3dfcab797 --- /dev/null +++ b/gnu/machine.scm @@ -0,0 +1,118 @@ +;;; 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) + #:use-module ((guix utils) #:select (source-properties->location)) + #:export (environment-type + environment-type? + environment-type-name + environment-type-description + environment-type-location + + machine + machine? + this-machine + + machine-system + machine-environment + machine-configuration + machine-display-name + + build-machine + deploy-machine + machine-remote-eval)) + +;;; Commentary: +;;; +;;; This module provides the types used to declare individual machines in a +;;; heterogeneous Guix deployment. The interface allows users of specify system +;;; configurations and the means by which resources should be provisioned on a +;;; per-host basis. +;;; +;;; Code: + + +;;; +;;; Declarations for resources that can be provisioned. +;;; + +(define-record-type* environment-type + make-environment-type + environment-type? + + ;; Interface to the environment type's deployment code. Each procedure + ;; should take the same arguments as the top-level procedure of this file + ;; that shares the same name. For example, 'machine-remote-eval' should be + ;; of the form '(machine-remote-eval machine exp)'. + (machine-remote-eval environment-type-machine-remote-eval) ; procedure + (deploy-machine environment-type-deploy-machine) ; procedure + + ;; Metadata. + (name environment-type-name) ; symbol + (description environment-type-description ; string + (default #f)) + (location environment-type-location ; + (default (and=> (current-source-location) + source-properties->location)) + (innate))) + + +;;; +;;; Declarations for machines in a deployment. +;;; + +(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 (machine-remote-eval machine exp) + "Evaluate EXP, a gexp, on MACHINE. Ensure that all the elements EXP refers to +are built and deployed to MACHINE beforehand." + (let ((environment (machine-environment machine))) + ((environment-type-machine-remote-eval environment) machine exp))) + +(define (deploy-machine machine) + "Monadic procedure transferring the new system's OS closure to the remote +MACHINE, activating it on MACHINE and switching MACHINE to the new generation." + (let ((environment (machine-environment machine))) + ((environment-type-deploy-machine environment) machine))) diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm new file mode 100644 index 000000000..6ce106bb2 --- /dev/null +++ b/gnu/machine/ssh.scm @@ -0,0 +1,363 @@ +;;; 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 i18n) + #:use-module (guix modules) + #:use-module (guix monads) + #:use-module (guix records) + #:use-module (guix remote) + #:use-module (guix ssh) + #:use-module (guix store) + #:use-module (ice-9 match) + #:use-module (srfi srfi-19) + #:export (managed-host-environment-type + + machine-ssh-configuration + machine-ssh-configuration? + machine-ssh-configuration + + machine-ssh-configuration-host-name + machine-ssh-configuration-port + machine-ssh-configuration-user + machine-ssh-configuration-session)) + +;;; Commentary: +;;; +;;; This module implements remote evaluation and system deployment for +;;; machines that are accessable over SSH and have a known host-name. In the +;;; sense of the broader "machine" interface, we describe the environment for +;;; such machines as 'managed-host. +;;; +;;; Code: + + +;;; +;;; Parameters for the SSH client. +;;; + +(define-record-type* machine-ssh-configuration + 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 (managed-host-remote-eval machine exp) + "Internal implementation of 'machine-remote-eval' for MACHINE instances with +an environment type of 'managed-host." + (maybe-raise-missing-configuration-error machine) + (remote-eval exp (machine-ssh-session machine))) + + +;;; +;;; System deployment. +;;; + +(define (switch-to-system machine) + "Monadic procedure creating a new generation on MACHINE and execute the +activation script for the new system configuration." + (define (remote-exp drv script) + (with-extensions (list guile-gcrypt) + (with-imported-modules (source-module-closure '((guix config) + (guix profiles) + (guix utils))) + #~(begin + (use-modules (guix config) + (guix profiles) + (guix utils)) + + (define %system-profile + (string-append %state-directory "/profiles/system")) + + (let* ((system #$(derivation->output-path drv)) + (number (1+ (generation-number %system-profile))) + (generation (generation-file-name %system-profile number))) + (switch-symlinks generation system) + (switch-symlinks %system-profile generation) + ;; The implementation of 'guix system reconfigure' saves the + ;; load path and environment here. This is unnecessary here + ;; because each invocation of 'remote-eval' runs in a distinct + ;; Guile REPL. + (setenv "GUIX_NEW_SYSTEM" system) + ;; The activation script may write to stdout, which confuses + ;; 'remote-eval' when it attempts to read a result from the + ;; remote REPL. We work around this by forcing the output to a + ;; string. + (with-output-to-string + (lambda () + (primitive-load #$script)))))))) + + (let* ((os (machine-system machine)) + (script (operating-system-activation-script os))) + (mlet* %store-monad ((drv (operating-system-derivation os))) + (machine-remote-eval machine (remote-exp drv script))))) + +;; XXX: Currently, this does NOT attempt to restart running services. This is +;; also the case with 'guix system reconfigure'. +;; +;; See . +(define (upgrade-shepherd-services machine) + "Monadic procedure unloading and starting services on the remote as needed +to realize the MACHINE's system configuration." + (define target-services + ;; Monadic expression evaluating to a list of (name output-path) pairs for + ;; all of MACHINE's services. + (mapm %store-monad + (lambda (service) + (mlet %store-monad ((file ((compose lower-object + shepherd-service-file) + service))) + (return (list (shepherd-service-canonical-name service) + (derivation->output-path file))))) + (service-value + (fold-services (operating-system-services (machine-system machine)) + #:target-type shepherd-root-service-type)))) + + (define (remote-exp target-services) + (with-imported-modules '((gnu services herd)) + #~(begin + (use-modules (gnu services herd) + (srfi srfi-1)) + + (define running + (filter live-service-running (current-services))) + + (define (essential? service) + ;; Return #t if SERVICE is essential and should not be unloaded + ;; under any circumstance. + (memq (first (live-service-provision service)) + '(root shepherd))) + + (define (obsolete? service) + ;; Return #t if SERVICE can be safely unloaded. + (and (not (essential? service)) + (every (lambda (requirements) + (not (memq (first (live-service-provision service)) + requirements))) + (map live-service-requirement running)))) + + (define to-unload + (filter obsolete? + (remove (lambda (service) + (memq (first (live-service-provision service)) + (map first '#$target-services))) + running))) + + (define to-start + (remove (lambda (service-pair) + (memq (first service-pair) + (map (compose first live-service-provision) + running))) + '#$target-services)) + + ;; Unload obsolete services. + (for-each (lambda (service) + (false-if-exception + (unload-service service))) + to-unload) + + ;; Load the service files for any new services and start them. + (load-services/safe (map second to-start)) + (for-each start-service (map first to-start)) + + #t))) + + (mlet %store-monad ((target-services target-services)) + (machine-remote-eval machine (remote-exp target-services)))) + +(define (machine-boot-parameters machine) + "Monadic procedure returning a list of 'boot-parameters' for the generations +of MACHINE's system profile, ordered from most recent to oldest." + (define bootable-kernel-arguments + (@@ (gnu system) bootable-kernel-arguments)) + + (define remote-exp + (with-extensions (list guile-gcrypt) + (with-imported-modules (source-module-closure '((guix config) + (guix profiles))) + #~(begin + (use-modules (guix config) + (guix profiles) + (ice-9 textual-ports)) + + (define %system-profile + (string-append %state-directory "/profiles/system")) + + (define (read-file path) + (call-with-input-file path + (lambda (port) + (get-string-all port)))) + + (map (lambda (generation) + (let* ((system-path (generation-file-name %system-profile + generation)) + (boot-parameters-path (string-append system-path + "/parameters")) + (time (stat:mtime (lstat system-path)))) + (list generation + system-path + time + (read-file boot-parameters-path)))) + (reverse (generation-numbers %system-profile))))))) + + (mlet* %store-monad ((generations (machine-remote-eval machine remote-exp))) + (return + (map (lambda (generation) + (match generation + ((generation system-path time serialized-params) + (let* ((params (call-with-input-string serialized-params + read-boot-parameters)) + (root (boot-parameters-root-device params)) + (label (boot-parameters-label params))) + (boot-parameters + (inherit params) + (label + (string-append label " (#" + (number->string generation) ", " + (let ((time (make-time time-utc 0 time))) + (date->string (time-utc->date time) + "~Y-~m-~d ~H:~M")) + ")")) + (kernel-arguments + (append (bootable-kernel-arguments system-path root) + (boot-parameters-kernel-arguments params)))))))) + generations)))) + +(define (install-bootloader machine) + "Create a bootloader entry for the new system generation on MACHINE, and +configure the bootloader to boot that generation by default." + (define bootloader-installer-script + (@@ (guix scripts system) bootloader-installer-script)) + + (define (remote-exp installer bootcfg bootcfg-file) + (with-extensions (list guile-gcrypt) + (with-imported-modules (source-module-closure '((gnu build install) + (guix store) + (guix utils))) + #~(begin + (use-modules (gnu build install) + (guix store) + (guix utils)) + (let* ((gc-root (string-append "/" %gc-roots-directory "/bootcfg")) + (temp-gc-root (string-append gc-root ".new"))) + + (switch-symlinks temp-gc-root gc-root) + + (unless (false-if-exception + (begin + ;; The implementation of 'guix system reconfigure' + ;; saves the load path here. This is unnecessary here + ;; because each invocation of 'remote-eval' runs in a + ;; distinct Guile REPL. + (install-boot-config #$bootcfg #$bootcfg-file "/") + ;; The installation script may write to stdout, which + ;; confuses 'remote-eval' when it attempts to read a + ;; result from the remote REPL. We work around this + ;; by forcing the output to a string. + (with-output-to-string + (lambda () + (primitive-load #$installer))))) + (delete-file temp-gc-root) + (error "failed to install bootloader")) + + (rename-file temp-gc-root gc-root) + #t))))) + + (mlet* %store-monad ((boot-parameters (machine-boot-parameters machine))) + (let* ((os (machine-system machine)) + (bootloader ((compose bootloader-configuration-bootloader + operating-system-bootloader) + os)) + (bootloader-target (bootloader-configuration-target + (operating-system-bootloader os))) + (installer (bootloader-installer-script + (bootloader-installer bootloader) + (bootloader-package bootloader) + bootloader-target + "/")) + (menu-entries (map boot-parameters->menu-entry boot-parameters)) + (bootcfg (operating-system-bootcfg os menu-entries)) + (bootcfg-file (bootloader-configuration-file bootloader))) + (machine-remote-eval machine (remote-exp installer bootcfg bootcfg-file))))) + +(define (deploy-managed-host machine) + "Internal implementation of 'deploy-machine' for MACHINE instances with an +environment type of 'managed-host." + (maybe-raise-missing-configuration-error machine) + (mbegin %store-monad + (switch-to-system machine) + (upgrade-shepherd-services machine) + (install-bootloader machine))) + + +;;; +;;; Environment type. +;;; + +(define managed-host-environment-type + (environment-type + (machine-remote-eval managed-host-remote-eval) + (deploy-machine deploy-managed-host) + (name 'managed-host-environment-type) + (description "Provisioning for machines that are accessable over SSH +and have a known host-name. This entails little more than maintaining an SSH +connection to the host."))) + +(define (maybe-raise-missing-configuration-error machine) + "Raise an error if MACHINE's configuration is #f." + (let ((environment (machine-environment machine))) + (unless (machine-configuration machine) + (error (format #f (G_ "no configuration specified for environment '~a'") + (symbol->string (environment-type-name environment))))))) From patchwork Tue Jul 2 00:17: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: 14449 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 E0C5517193; Tue, 2 Jul 2019 03:57:13 +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=unavailable 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 8A1B317191 for ; Tue, 2 Jul 2019 03:57:13 +0100 (BST) Received: from localhost ([::1]:47648 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hi8yn-00032b-6A for patchwork@mira.cbaines.net; Mon, 01 Jul 2019 22:57:13 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:58151) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hi6td-00074M-88 for guix-patches@gnu.org; Mon, 01 Jul 2019 20:43:47 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1hi6tM-0005Ez-Uj for guix-patches@gnu.org; Mon, 01 Jul 2019 20:43:44 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:37518) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1hi6Ul-000896-9V for guix-patches@gnu.org; Mon, 01 Jul 2019 20:18:22 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1hi6Ul-0004wN-3m for guix-patches@gnu.org; Mon, 01 Jul 2019 20:18:03 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#36404] [PATCH 3/4] Add 'guix deploy'. Resent-From: zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Tue, 02 Jul 2019 00:18:03 +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: Ludovic =?utf-8?q?Court=C3=A8s?= Received: via spool by 36404-submit@debbugs.gnu.org id=B36404.156202668018974 (code B ref 36404); Tue, 02 Jul 2019 00:18:03 +0000 Received: (at 36404) by debbugs.gnu.org; 2 Jul 2019 00:18:00 +0000 Received: from localhost ([127.0.0.1]:46338 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hi6Uh-0004vy-RT for submit@debbugs.gnu.org; Mon, 01 Jul 2019 20:18:00 -0400 Received: from mx.sdf.org ([205.166.94.20]:54914) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hi6Uf-0004vq-UG for 36404@debbugs.gnu.org; Mon, 01 Jul 2019 20:17:59 -0400 Received: from Upsilon (mobile-107-107-57-169.mycingular.net [107.107.57.169]) (authenticated (0 bits)) by mx.sdf.org (8.15.2/8.14.5) with ESMTPSA id x620Hsak027915 (using TLSv1.2 with cipher AES256-GCM-SHA384 (256 bits) verified NO); Tue, 2 Jul 2019 00:17:56 GMT From: zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) References: <87o92ianbj.fsf@sdf.lonestar.org> <87o92glap5.fsf@dustycloud.org> <878sthoqzi.fsf@gnu.org> <87imsl9tsx.fsf_-_@sdf.lonestar.org> <87ef399tpu.fsf_-_@sdf.lonestar.org> <87a7dx9tog.fsf_-_@sdf.lonestar.org> Date: Mon, 01 Jul 2019 20:17:53 -0400 In-Reply-To: <87a7dx9tog.fsf_-_@sdf.lonestar.org> (Jakob L. Kreuze's message of "Mon, 01 Jul 2019 20:17:03 -0400") Message-ID: <875zol9tn2.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 f10c000ea..4d3024e58 100644 --- a/Makefile.am +++ b/Makefile.am @@ -267,6 +267,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 000000000..4fb1babe8 --- /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 '((gnu) (gnu machine) (gnu machine ssh))))) + (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 Tue Jul 2 00:18:58 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: 14451 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 236CE17193; Tue, 2 Jul 2019 04:03:34 +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=unavailable 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 C725617191 for ; Tue, 2 Jul 2019 04:03:33 +0100 (BST) Received: from localhost ([::1]:47750 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hi94v-0001xM-Ek for patchwork@mira.cbaines.net; Mon, 01 Jul 2019 23:03:33 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:54965) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hi6X0-0002cd-83 for guix-patches@gnu.org; Mon, 01 Jul 2019 20:20:27 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1hi6Wn-0000cS-1h for guix-patches@gnu.org; Mon, 01 Jul 2019 20:20:12 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:37523) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1hi6Wf-0000Z6-W2 for guix-patches@gnu.org; Mon, 01 Jul 2019 20:20:04 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1hi6Wf-0004zM-Nw for guix-patches@gnu.org; Mon, 01 Jul 2019 20:20:01 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#36404] [PATCH 4/4] 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: Tue, 02 Jul 2019 00:20: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: Ludovic =?utf-8?q?Court=C3=A8s?= Received: via spool by 36404-submit@debbugs.gnu.org id=B36404.156202674819111 (code B ref 36404); Tue, 02 Jul 2019 00:20:01 +0000 Received: (at 36404) by debbugs.gnu.org; 2 Jul 2019 00:19:08 +0000 Received: from localhost ([127.0.0.1]:46344 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hi6Vo-0004yA-Ex for submit@debbugs.gnu.org; Mon, 01 Jul 2019 20:19:08 -0400 Received: from mx.sdf.org ([205.166.94.20]:54124) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hi6Vm-0004y2-TV for 36404@debbugs.gnu.org; Mon, 01 Jul 2019 20:19:07 -0400 Received: from Upsilon (mobile-107-107-57-169.mycingular.net [107.107.57.169]) (authenticated (0 bits)) by mx.sdf.org (8.15.2/8.14.5) with ESMTPSA id x620J0b9024446 (using TLSv1.2 with cipher AES256-GCM-SHA384 (256 bits) verified NO); Tue, 2 Jul 2019 00:19:05 GMT From: zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) References: <87o92ianbj.fsf@sdf.lonestar.org> <87o92glap5.fsf@dustycloud.org> <878sthoqzi.fsf@gnu.org> <87imsl9tsx.fsf_-_@sdf.lonestar.org> <87ef399tpu.fsf_-_@sdf.lonestar.org> <87a7dx9tog.fsf_-_@sdf.lonestar.org> <875zol9tn2.fsf_-_@sdf.lonestar.org> Date: Mon, 01 Jul 2019 20:18:58 -0400 In-Reply-To: <875zol9tn2.fsf_-_@sdf.lonestar.org> (Jakob L. Kreuze's message of "Mon, 01 Jul 2019 20:17:53 -0400") Message-ID: <871rz99tl9.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 | 101 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 101 insertions(+) diff --git a/doc/guix.texi b/doc/guix.texi index 9dc1d2a9c..23b7416ab 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. @@ -10302,6 +10304,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 @@ -25335,6 +25338,104 @@ 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-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-environment-type) + (configuration (machine-ssh-configuration + (host-name "localhost") + (identity "./id_rsa") + (port 2222))))) +@end example + +The file should evaluate to a list of @var{machine} objects. 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