01/01: scripts: Add deploy.

[Christopher Allan Webber]

cwebber pushed a commit to branch wip-deploy
in repository guix.

commit fcd6fc84e493d05be1f7590ee77509c81ac315c2
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.scm                 |    1 +
 gnu/local.mk            |    2 +
 gnu/machines.scm        |  127 ++++++++++++++++++++++++++++++++++++++
 gnu/system/vm.scm       |    2 +
 guix/scripts/deploy.scm |  154 +++++++++++++++++++++++++++++++++++++++++++++++
 6 files changed, 287 insertions(+)

diff --git a/Makefile.am b/Makefile.am
index 908eaf6..b8dbc39 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 932e4cd..0edecb0 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 19dd9ae..8b382c2 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 0000000..a02f668
--- /dev/null
+++ b/gnu/machines.scm
@@ -0,0 +1,127 @@
+;;; 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")
+                   (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 03f7d6c..e34fdbb 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 0000000..bd61753
--- /dev/null
+++ b/guix/scripts/deploy.scm
@@ -0,0 +1,154 @@
+;;; 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)
+  #: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)))))))