Re: Guix "ops"

[Christopher Allan Webber]

David Thompson writes:

> Hello again Carlos,
>
> Carlos Sosa <address@hidden> 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 ;))

>From 25047d057c2adc30901b3052bf5017a6763741a1 Mon Sep 17 00:00:00 2001
From: David Thompson <address@hidden>
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 =                                   \
   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 d6369b5..d2d6f79 100644
--- a/gnu-system.am
+++ b/gnu-system.am
@@ -359,7 +359,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 2520493..20f95d5 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)))))))
-- 
2.1.4