mirror/guix
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/guix.git synced 2025-01-18 13:36:36 +01:00
Code Issues Projects Releases Packages Wiki Activity Actions

scripts: Add deploy.

Browse source 
* 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.
This commit is contained in:
David Thompson 2015-04-13 19:14:31 -04:00 committed by Christopher Allan Webber
parent b37e1e6428
commit fcd6fc84e4
6 changed files with 287 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
Makefile.am
View file

@ -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)

1
gnu.scm
View file

@ -43,6 +43,7 @@ (define %public-modules
(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))))

2
gnu/local.mk
View file

@ -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 \

127
gnu/machines.scm Normal file
View file

@ -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))))))

2
gnu/system/vm.scm
View file

@ -62,6 +62,8 @@ (define-module (gnu system vm)
virtualized-operating-system
system-qemu-image
virtualized-operating-system
system-qemu-image/shared-store
system-qemu-image/shared-store-script
system-disk-image))

154
guix/scripts/deploy.scm Normal file
View file

@ -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)))))))