From mboxrd@z Thu Jan 1 00:00:00 1970 Received: from eggs.gnu.org ([2001:470:142:3::10]:55812) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hjLWg-0007dh-JD for guix-patches@gnu.org; Fri, 05 Jul 2019 06:33:13 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1hjLWc-0007zD-Pq for guix-patches@gnu.org; Fri, 05 Jul 2019 06:33:10 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:43572) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1hjLWX-0007oQ-Us for guix-patches@gnu.org; Fri, 05 Jul 2019 06:33:04 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1hjLWX-0007Ou-Pv for guix-patches@gnu.org; Fri, 05 Jul 2019 06:33:01 -0400 Subject: [bug#36404] [PATCH v4 2/4] gnu: Add machine type for deployment specifications. References: <87o92ianbj.fsf@sdf.lonestar.org> In-Reply-To: <87o92ianbj.fsf@sdf.lonestar.org> Resent-Message-ID: From: Christopher Lemmer Webber Message-ID: <87h882n2g1.fsf@dustycloud.org> Date: Fri, 05 Jul 2019 06:32:37 -0400 MIME-Version: 1.0 Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+kyle=kyleam.com@gnu.org Sender: "Guix-patches" To: "Jakob L. Kreuze" Cc: 36404@debbugs.gnu.org References: <87o92ianbj.fsf@sdf.lonestar.org> <87o92glap5.fsf@dustycloud.or= g> <878sthoqzi.fsf@gnu.org> <87imsl9tsx.fsf_-_@sdf.lonestar.org> <87ef399tp= u.fsf_-_@sdf.lonestar.org> <87a7dx9tog.fsf_-_@sdf.lonestar.org> <875zol9tn2= .fsf_-_@sdf.lonestar.org> <871rz99tl9.fsf_-_@sdf.lonestar.org> <875zoldqah.= fsf@kyleam.com> <87muhwtmfp.fsf@sdf.lonestar.org> <871rz874l2.fsf@kyleam.co= m> <877e90tj7l.fsf_-_@sdf.lonestar.org> <8736jotj5v.fsf_-_@sdf.lonestar.org= > <87y31gs4k5.fsf_-_@sdf.lonestar.org> User-agent: mu4e 1.2.0; emacs 26.2 In-reply-to: <87y31gs4k5.fsf_-_@sdf.lonestar.org> Jakob L. Kreuze writes: > +(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 f= ile > + ;; that shares the same name. For example, 'machine-remote-eval' shoul= d 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=3D> (current-source-location) > + source-properties->location)) > + (innate))) Yeah! I think this is much nicer. :) > + > + > +;;; > +;;; 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 r= eturning > +a list containing the path of the derivation file and the path of the de= rivation > +output." > + (let ((os (machine-system machine))) > + (mlet* %store-monad ((osdrv (operating-system-derivation os)) > + (_ ((store-lift build-derivations) (list osdrv)= ))) > + (return (list (derivation-file-name osdrv) > + (derivation->output-path osdrv)))))) > + > +(define (machine-remote-eval machine exp) > + "Evaluate EXP, a gexp, on MACHINE. Ensure that all the elements EXP re= fers to > +are built and deployed to MACHINE beforehand." > + (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 rem= ote > +MACHINE, activating it on MACHINE and switching MACHINE to the new gener= ation." > + (let ((environment (machine-environment machine))) > + ((environment-type-deploy-machine environment) machine))) Oooooh so much cleaner. Nice nice nice! I like this. > 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 =C2=A9 2019 Jakob L. Kreuze > +;;; > +;;; This file is part of GNU Guix. > +;;; > +;;; GNU Guix is free software; you can redistribute it and/or modify it > +;;; under the terms of the GNU General Public License as published by > +;;; the Free Software Foundation; either version 3 of the License, or (at > +;;; your option) any later version. > +;;; > +;;; GNU Guix is distributed in the hope that it will be useful, but > +;;; WITHOUT ANY WARRANTY; without even the implied warranty of > +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the > +;;; GNU General Public License for more details. > +;;; > +;;; You should have received a copy of the GNU General Public License > +;;; along with GNU Guix. If not, see . > + > +(define-module (gnu machine ssh) > + #:use-module (gnu bootloader) > + #:use-module (gnu machine) > + #:autoload (gnu packages gnupg) (guile-gcrypt) > + #:use-module (gnu services) > + #:use-module (gnu services shepherd) > + #:use-module (gnu system) > + #:use-module (guix derivations) > + #:use-module (guix gexp) > + #:use-module (guix 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 environmen= t for > +;;; such machines as 'managed-host. > +;;; > +;;; Code: > + > + > +;;; > +;;; Parameters for the SSH client. > +;;; > + > +(define-record-type* machine-ssh-configurati= on > + make-machine-ssh-configuration > + machine-ssh-configuration? > + this-machine-ssh-configuration > + (host-name machine-ssh-configuration-host-name) ; string > + (port machine-ssh-configuration-port ; integer > + (default 22)) > + (user machine-ssh-configuration-user ; string > + (default "root")) > + (identity machine-ssh-configuration-identity ; path to a private key > + (default #f)) > + (session machine-ssh-configuration-session ; session > + (default #f))) > + > +(define (machine-ssh-session machine) > + "Return the SSH session that was given in MACHINE's configuration, or = create > +one from the configuration's parameters if one was not provided." > + (let ((config (machine-configuration machine))) > + (if (machine-ssh-configuration? config) > + (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 instance= s 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 num= ber))) > + (switch-symlinks generation system) > + (switch-symlinks %system-profile generation) > + ;; The implementation of 'guix system reconfigure' saves t= he > + ;; load path and environment here. This is unnecessary here > + ;; because each invocation of 'remote-eval' runs in a dist= inct > + ;; Guile REPL. > + (setenv "GUIX_NEW_SYSTEM" system) > + ;; The activation script may write to stdout, which confus= es > + ;; '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. Th= is is > +;; also the case with 'guix system reconfigure'. > +;; > +;; See . > +(define (upgrade-shepherd-services machine) > + "Monadic procedure unloading and starting services on the remote as ne= eded > +to realize the MACHINE's system configuration." > + (define target-services > + ;; Monadic expression evaluating to a list of (name output-path) pai= rs for > + ;; all of MACHINE's services. > + (mapm %store-monad > + (lambda (service) > + (mlet %store-monad ((file ((compose lower-object > + shepherd-service-file) > + service))) > + (return (list (shepherd-service-canonical-name service) > + (derivation->output-path file))))) > + (service-value > + (fold-services (operating-system-services (machine-system mac= hine)) > + #:target-type shepherd-root-service-type)))) > + > + (define (remote-exp target-services) > + (with-imported-modules '((gnu services herd)) > + #~(begin > + (use-modules (gnu services herd) > + (srfi srfi-1)) > + > + (define running > + (filter live-service-running (current-services))) > + > + (define (essential? service) > + ;; Return #t if SERVICE is essential and should not be unloa= ded > + ;; under any circumstance. > + (memq (first (live-service-provision service)) > + '(root shepherd))) > + > + (define (obsolete? service) > + ;; Return #t if SERVICE can be safely unloaded. > + (and (not (essential? service)) > + (every (lambda (requirements) > + (not (memq (first (live-service-provision serv= ice)) > + requirements))) > + (map live-service-requirement running)))) > + > + (define to-unload > + (filter obsolete? > + (remove (lambda (service) > + (memq (first (live-service-provision servi= ce)) > + (map first '#$target-services))) > + running))) > + > + (define to-start > + (remove (lambda (service-pair) > + (memq (first service-pair) > + (map (compose first live-service-provision) > + running))) > + '#$target-services)) > + > + ;; Unload obsolete services. > + (for-each (lambda (service) > + (false-if-exception > + (unload-service service))) > + to-unload) > + > + ;; Load the service files for any new services and start them. > + (load-services/safe (map second to-start)) > + (for-each start-service (map first to-start)) > + > + #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 gener= ations > +of MACHINE's system profile, ordered from most recent to oldest." > + (define bootable-kernel-arguments > + (@@ (gnu system) bootable-kernel-arguments)) > + > + (define remote-exp > + (with-extensions (list guile-gcrypt) > + (with-imported-modules (source-module-closure '((guix config) > + (guix profiles))) > + #~(begin > + (use-modules (guix config) > + (guix profiles) > + (ice-9 textual-ports)) > + > + (define %system-profile > + (string-append %state-directory "/profiles/system")) > + > + (define (read-file path) > + (call-with-input-file path > + (lambda (port) > + (get-string-all port)))) > + > + (map (lambda (generation) > + (let* ((system-path (generation-file-name %system-pro= file > + generation)) > + (boot-parameters-path (string-append system-pa= th > + "/paramet= ers")) > + (time (stat:mtime (lstat system-path)))) > + (list generation > + system-path > + time > + (read-file boot-parameters-path)))) > + (reverse (generation-numbers %system-profile))))))) > + > + (mlet* %store-monad ((generations (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, a= nd > +configure the bootloader to boot that generation by default." > + (define bootloader-installer-script > + (@@ (guix scripts system) bootloader-installer-script)) > + > + (define (remote-exp installer bootcfg bootcfg-file) > + (with-extensions (list guile-gcrypt) > + (with-imported-modules (source-module-closure '((gnu build install) > + (guix store) > + (guix utils))) > + #~(begin > + (use-modules (gnu build install) > + (guix store) > + (guix utils)) > + (let* ((gc-root (string-append "/" %gc-roots-directory "/boo= tcfg")) > + (temp-gc-root (string-append gc-root ".new"))) > + > + (switch-symlinks temp-gc-root gc-root) > + > + (unless (false-if-exception > + (begin > + ;; The implementation of 'guix system reconfigu= re' > + ;; saves the load path here. This is unnecessar= y here > + ;; because each invocation of 'remote-eval' run= s 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 r= ead 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-parameter= s)) > + (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 wit= h 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 o= ver 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)= )))))) Yeah ok! This looks good to me. I think my issues are all addressed here.