diff options
| -rw-r--r-- | Makefile.am | 1 | ||||
| -rw-r--r-- | gnu.scm | 1 | ||||
| -rw-r--r-- | gnu/local.mk | 2 | ||||
| -rw-r--r-- | gnu/machines.scm | 127 | ||||
| -rw-r--r-- | gnu/system/vm.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/deploy.scm | 154 |
6 files changed, 287 insertions, 0 deletions
diff --git a/Makefile.am b/Makefile.am index 908eaf6ec0..b8dbc39d24 100644 --- a/Makefile.am +++ b/Makefile.am @@ -148,6 +148,7 @@ MODULES = \ guix/scripts/graph.scm \ guix/scripts/container.scm \ guix/scripts/container/exec.scm \ + guix/scripts/deploy.scm \ guix.scm \ $(GNU_SYSTEM_MODULES) diff --git a/gnu.scm b/gnu.scm index 932e4cdd58..0edecb0311 100644 --- a/gnu.scm +++ b/gnu.scm @@ -43,6 +43,7 @@ (gnu services base) (gnu packages) (gnu packages base) + (gnu machines) (guix gexp))) ; so gexps can be used (for-each (let ((i (module-public-interface (current-module)))) diff --git a/gnu/local.mk b/gnu/local.mk index 19dd9ae38f..8b382c2b14 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -430,6 +430,8 @@ GNU_SYSTEM_MODULES = \ %D%/build/marionette.scm \ %D%/build/vm.scm \ \ + %D%/machines.scm \ + \ %D%/tests.scm \ %D%/tests/base.scm \ %D%/tests/install.scm \ diff --git a/gnu/machines.scm b/gnu/machines.scm new file mode 100644 index 0000000000..a02f668b66 --- /dev/null +++ b/gnu/machines.scm @@ -0,0 +1,127 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 David Thompson <davet@gnu.org> +;;; +;;; 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 <http://www.gnu.org/licenses/>. + +(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> deployment + make-deployment + deployment? + (name deployment-name) ; string + (machines deployment-machines)) ; list of <machine> + +(define-record-type* <machine> machine + make-machine + machine? + (name machine-name) ; string + (system machine-system) ; <operating-system> + (platform machine-platform)) ; <platform> + +(define-record-type* <platform> 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 machine))) + +(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") + (disk-image-size (* 32 (expt 2 20)))) + (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 #:disk-image-size disk-image-size))) + (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 03f7d6c913..e34fdbbd65 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -62,6 +62,8 @@ virtualized-operating-system system-qemu-image + 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 0000000000..bd617538ba --- /dev/null +++ b/guix/scripts/deploy.scm @@ -0,0 +1,154 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 David Thompson <davet@gnu.org> +;;; +;;; 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 <http://www.gnu.org/licenses/>. + +(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) + #: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=EXPR 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~%") name)) + parse-sub-command-or-config %default-options)) + (action (assoc-ref opts 'action)) + (deployment (primitive-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))))))) |