From mboxrd@z Thu Jan 1 00:00:00 1970 From: Christopher Allan Webber Subject: Re: Guix "ops" Date: Fri, 10 Jul 2015 11:37:54 -0500 Message-ID: <87lheovuf8.fsf@earlgrey.lan> References: <87k2wx6t1e.fsf@fsf.org> <87vbgdy6x8.fsf@gnu.org> <87fv7h5zhk.fsf@fsf.org> <87mw1obbfq.fsf@gnu.org> <87bnhzrjf1.fsf@gnusosa.net> <87382oejz8.fsf@fsf.org> Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" Return-path: Received: from eggs.gnu.org ([2001:4830:134:3::10]:57459) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1ZDbK7-00071p-0M for guix-devel@gnu.org; Fri, 10 Jul 2015 12:38:52 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1ZDbK5-0006MR-2v for guix-devel@gnu.org; Fri, 10 Jul 2015 12:38:50 -0400 Received: from [2600:3c02::f03c:91ff:feae:cb51] (port=36469 helo=dustycloud.org) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1ZDbK4-0006ME-RZ for guix-devel@gnu.org; Fri, 10 Jul 2015 12:38:49 -0400 In-reply-to: <87382oejz8.fsf@fsf.org> List-Id: "Development of GNU Guix and the GNU System distribution." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-devel-bounces+gcggd-guix-devel=m.gmane.org@gnu.org Sender: guix-devel-bounces+gcggd-guix-devel=m.gmane.org@gnu.org To: David Thompson Cc: guix-devel@gnu.org, Carlos Sosa --=-=-= Content-Type: text/plain David Thompson writes: > Hello again Carlos, > > Carlos Sosa writes: > >> I like the idea of 'guix deploy', and maybe something to propagates >> given configuration files, like 'guix config prepare' and later 'guix >> config apply'. >> >> Now, how can I contribute? work the guix command? >> >> Let me know if you have a specific repository or place to find any work >> done on this. > > I have just pushed a new branch called "wip-deploy" to the official guix > repository. Since this branch is prefixed with "wip-", expect it to be > rebased frequently. There's not much code here yet, but a very simple > prototype has been implemented that supports the creation of local QEMU > VMs. > > To take it for a spin, add something like this to a file, let's call it > "deployment.scm": I've confirmed that the above works and works great. I wanted to play with it with current master, so I rebased the current branch on top of it. It's a mere single patch at the moment, so here's the patch with appropriate conflicts resolved, in case anyone wants to play with it with master (or in case David wants someone else to handle the conflict resolving work for them ;)) --=-=-= Content-Type: text/x-diff; charset=utf-8 Content-Disposition: inline; filename=0001-scripts-Add-deploy.patch Content-Transfer-Encoding: quoted-printable >From 25047d057c2adc30901b3052bf5017a6763741a1 Mon Sep 17 00:00:00 2001 From: David Thompson Date: Mon, 13 Apr 2015 19:14:31 -0400 Subject: [PATCH] scripts: Add deploy. * gnu/machines.scm: New file. * gnu-system.am (GNU_SYSTEM_MODULES): Add it. * guix/scripts/deploy.scm: New file. * Makefile.am (MODULES): Add it. * gnu.scm: Export (gnu machines) symbols. * gnu/system/vm.scm (virtualized-operating-system): Export it. --- Makefile.am | 1 + gnu-system.am | 4 +- gnu.scm | 1 + gnu/machines.scm | 125 +++++++++++++++++++++++++++++++++++++++ gnu/system/vm.scm | 2 + guix/scripts/deploy.scm | 153 ++++++++++++++++++++++++++++++++++++++++++= ++++++ 6 files changed, 285 insertions(+), 1 deletion(-) create mode 100644 gnu/machines.scm create mode 100644 guix/scripts/deploy.scm diff --git a/Makefile.am b/Makefile.am index 7059a8f..9458b2c 100644 --- a/Makefile.am +++ b/Makefile.am @@ -121,6 +121,7 @@ MODULES =3D \ guix/scripts/publish.scm \ guix/scripts/edit.scm \ guix/scripts/size.scm \ + guix/scripts/deploy.scm \ guix.scm \ $(GNU_SYSTEM_MODULES) =20 diff --git a/gnu-system.am b/gnu-system.am index d6369b5..d2d6f79 100644 --- a/gnu-system.am +++ b/gnu-system.am @@ -359,7 +359,9 @@ GNU_SYSTEM_MODULES =3D \ gnu/build/linux-container.scm \ gnu/build/linux-initrd.scm \ gnu/build/linux-modules.scm \ - gnu/build/vm.scm + gnu/build/vm.scm \ + \ + gnu/machines.scm =20 =20 patchdir =3D $(guilemoduledir)/gnu/packages/patches diff --git a/gnu.scm b/gnu.scm index e3147b3..5cd1dea 100644 --- a/gnu.scm +++ b/gnu.scm @@ -42,6 +42,7 @@ (gnu services base) (gnu packages) (gnu packages base) + (gnu machines) (guix gexp))) ; so gexps can be used =20 (for-each (let ((i (module-public-interface (current-module)))) diff --git a/gnu/machines.scm b/gnu/machines.scm new file mode 100644 index 0000000..2276732 --- /dev/null +++ b/gnu/machines.scm @@ -0,0 +1,125 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright =C2=A9 2015 David Thompson +;;; +;;; 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 (a= t +;;; 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 machines) + #:use-module (guix records) + #:use-module (gnu system) + #:use-module (gnu system vm) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:export (deployment + make-deployment + deployment? + deployment-name + deployment-machines + + machine + make-machine + machine? + machine-name + machine-system + machine-platform + + platform + make-platform + platform-name + platform-description + platform-provision + platform-install + platform-reconfigure + platform-boot + platform-reboot + platform-halt + platform-destroy + + machine-os-for-platform + provision-machine + boot-machine + + local-vm)) + +(define-record-type* deployment + make-deployment + deployment? + (name deployment-name) ; string + (machines deployment-machines)) ; list of + +(define-record-type* machine + make-machine + machine? + (name machine-name) ; string + (system machine-system) ; + (platform machine-platform)) ; + +(define-record-type* platform + make-platform + platform? + (name platform-name) ; string + (description platform-description) ; string + (transform platform-transform) ; procedure + (provision platform-provision) ; procedure + ;; (install platform-install) ; procedure + ;; (reconfigure platform-reconfigure) ; procedure + (boot platform-boot) ; procedure + ;; (reboot platform-reboot) ; procedure + ;; (halt platform-halt) ; procedure + ;; (destroy platform-destroy) ; procedure + ) + +(define (machine-os-for-platform machine) + ((platform-transform (machine-platform machine)) (machine-system machi= ne))) + +(define (provision-machine machine) + (let ((os (machine-os-for-platform machine))) + ((platform-provision (machine-platform machine)) os))) + +(define (boot-machine machine state) + ((platform-boot (machine-platform machine)) state)) + +(use-modules (guix monads) + (guix derivations) + (guix store) + (gnu services networking)) + +(define* (local-vm #:key (ip-address "10.0.2.10")) + (platform + (name "local-vm") + (description "Local QEMU/KVM platform") + (transform + (lambda (os) + (let ((os (operating-system (inherit os) + (services + (cons + (static-networking-service "eth0" ip-address + #:name-servers '("10.0.2.= 3") + #:gateway "10.0.2.2") + (operating-system-user-services os)))))) + (virtualized-operating-system os '())))) + (provision + (lambda (os) + (mlet %store-monad + ((vm-script (system-qemu-image/shared-store-script os))) + (mbegin %store-monad + (built-derivations (list vm-script)) + (return (derivation-output-path + (assoc-ref (derivation-outputs vm-script) "out"))))))= ) + (boot + (lambda (script) + (match (primitive-fork) + (0 (primitive-exit (system* script))) + (pid #t)))))) diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 2520493..20f95d5 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -58,6 +58,8 @@ qemu-image system-qemu-image =20 + virtualized-operating-system + system-qemu-image/shared-store system-qemu-image/shared-store-script system-disk-image)) diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm new file mode 100644 index 0000000..514d08a --- /dev/null +++ b/guix/scripts/deploy.scm @@ -0,0 +1,153 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright =C2=A9 2015 David Thompson +;;; +;;; 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 (a= t +;;; 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 (guix ui) + #:use-module (guix store) + #:use-module (guix derivations) + #:use-module (guix packages) + #:use-module (guix profiles) + #:use-module (guix utils) + #:use-module (guix monads) + #:use-module (guix build utils) + #:use-module (guix scripts build) + #:use-module (gnu packages) + #:use-module (gnu system) + #:use-module (gnu system vm) + #:use-module (gnu machines) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-37) + #:use-module (srfi srfi-98) + #:export (guix-deploy)) + +(define (show-help) + (display (_ "Usage: guix deploy [OPTION] ACTION FILE +Manage your data beans without disturbing Terry the data goblin.\n")) + (newline) + (display (_ "The valid values for ACTION are:\n")) + (display (_ "\ + - 'build', build all of the operating systems without deploying\n")) + (display (_ "\ + - 'init', provision and install the operating systems\n")) + (display (_ "\ + - 'reconfigure', update an existing deployment\n")) + (display (_ "\ + - 'destroy', unprovision the deployed operating systems\n")) + (display (_ " + -e, --expression=3DEXPR create environment for the package that EXPR + evaluates to")) + (newline) + (show-build-options-help) + (newline) + (display (_ " + -h, --help display this help and exit")) + (display (_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %default-options + `((substitutes? . #t) + (max-silent-time . 3600) + (verbosity . 0))) + +(define %options + (cons* (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix deploy"))) + %standard-build-options)) + +(define-syntax-rule (return* body ...) + "Generate the monadic form of BODY, an expression evaluated for its +side-effects. The result is always #t." + (return (begin body ... #t))) + +(define (deployment-derivations deployment) + (map (lambda (machine) + (operating-system-derivation + (machine-os-for-platform machine))) + (deployment-machines deployment))) + +(define (build-deployment deployment) + (mlet* %store-monad + ((drvs (sequence %store-monad (deployment-derivations deployment))= )) + (mbegin %store-monad + (show-what-to-build* drvs) + (built-derivations drvs) + (return* + (for-each (lambda (drv) + (display (derivation->output-path drv)) + (newline)) + drvs))))) + +(define (provision-deployment deployment) + (sequence %store-monad + (map (lambda (machine) + (mlet %store-monad + ((state (provision-machine machine))) + (return (list machine state)))) + (deployment-machines deployment)))) + +(define (spawn-deployment deployment) + (mlet %store-monad + ((states (provision-deployment deployment))) + (sequence %store-monad + (map (match-lambda + ((machine state) + (return* (boot-machine machine state)))) + states)))) + +(define (perform-action action deployment) + (case action + ((build) (build-deployment deployment)) + ((provision) (provision-deployment deployment)) + ((spawn) (spawn-deployment deployment)))) + +(define (guix-deploy . args) + (define (parse-sub-command-or-config arg result) + (cond + ((assoc-ref result 'config) + (leave (_ "~a: extraneous argument~%") arg)) + ((assoc-ref result 'action) + (alist-cons 'config arg result)) + (else + (let ((action (string->symbol arg))) + (case action + ((build provision spawn) + (alist-cons 'action action result)) + (else (leave (_ "~a: unknown action~%") action))))))) + + (with-error-handling + (let* ((opts (args-fold* args %options + (lambda (opt name arg result) + (leave (_ "~A: unrecognized option~%") na= me)) + parse-sub-command-or-config %default-option= s)) + (action (assoc-ref opts 'action)) + (deployment (load (assoc-ref opts 'config)))) + (with-store store + (run-with-store store + (mbegin %store-monad + (set-build-options-from-command-line* opts) + (perform-action action deployment))))))) --=20 2.1.4 --=-=-=--