[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
01/01: scripts: Add deploy.
|
From: |
David Thompson |
|
Subject: |
01/01: scripts: Add deploy. |
|
Date: |
Sun, 02 Aug 2015 02:30:03 +0000 |
davexunit pushed a commit to branch wip-deploy
in repository guix.
commit b51eb233ab234e745ab4dd83ee9978c1dbbfb54b
Author: David Thompson <address@hidden>
Date: Mon Apr 13 19:14:31 2015 -0400
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 deletions(-)
diff --git a/Makefile.am b/Makefile.am
index ada4cbe..7de5dfe 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -121,6 +121,7 @@ MODULES = \
guix/scripts/publish.scm \
guix/scripts/edit.scm \
guix/scripts/size.scm \
+ guix/scripts/deploy.scm \
guix.scm \
$(GNU_SYSTEM_MODULES)
diff --git a/gnu-system.am b/gnu-system.am
index 87924fe..f0adced 100644
--- a/gnu-system.am
+++ b/gnu-system.am
@@ -365,7 +365,9 @@ GNU_SYSTEM_MODULES = \
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
patchdir = $(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
(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 © 2015 David Thompson <address@hidden>
+;;;
+;;; 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"))
+ (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 dfb6996..fcc61b3 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -58,6 +58,8 @@
qemu-image
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 0000000..514d08a
--- /dev/null
+++ b/guix/scripts/deploy.scm
@@ -0,0 +1,153 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2015 David Thompson <address@hidden>
+;;;
+;;; 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 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 (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)))))))