[bug#37083] [PATCH 1/1] machine: Implement 'digital-ocean-environment-type'.

[Jakob L. Kreuze]

gnu/machine/digital-ocean.scm: New file.
gnu/local.mk (GNU_SYSTEM_MODULES): Add it.
doc/guix.texi (Invoking 'guix deploy'): Add documentation for
'digital-ocean-configuration'.
---
 doc/guix.texi                 |  21 +-
 gnu/local.mk                  |   1 +
 gnu/machine/digital-ocean.scm | 409 ++++++++++++++++++++++++++++++++++
 3 files changed, 428 insertions(+), 3 deletions(-)
 create mode 100644 gnu/machine/digital-ocean.scm

diff --git a/doc/guix.texi b/doc/guix.texi
index 043851e418..f86a7ceac4 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -25566,12 +25566,10 @@ The object of the operating system configuration to 
deploy.
 
 @item @code{environment}
 An @code{environment-type} describing how the machine should be provisioned.
-At the moment, the only supported value is
-@code{managed-host-environment-type}.
 
 @item @code{configuration} (default: @code{#f})
 An object describing the configuration for the machine's @code{environment}.
-If the @code{environment} has a default configuration, @code{#f} maybe used.
+If the @code{environment} has a default configuration, @code{#f} may be used.
 If @code{#f} is used for an environment with no default configuration,
 however, an error will be thrown.
 @end table
@@ -25599,6 +25597,23 @@ remote host.
 @end table
 @end deftp
 
+@deftp {Data Type} digital-ocean-configuration
+This is the data type describing the Droplet that should be created for a
+machine with an @code{environment} of @code{digital-ocean-environment-type}.
+
+@table @asis
+@item @code{ssh-key}
+The path to the SSH private key to use to authenticate with the remote
+host. In the future, this field may not exist.
+@item @code{region}
+A Digital Ocean region slug, such as @code{"nyc3"}.
+@item @code{size}
+A Digital Ocean size slug, such as @code{"s-1vcpu-1gb"}
+@item @code{enable-ipv6}
+Whether or not the droplet should be created with IPv6 networking.
+@end table
+@end deftp
+
 @node Running Guix in a VM
 @section Running Guix in a Virtual Machine
 
diff --git a/gnu/local.mk b/gnu/local.mk
index aab29beb0a..e89562a1e2 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -570,6 +570,7 @@ GNU_SYSTEM_MODULES =                                \
   %D%/system/vm.scm                            \
                                                \
   %D%/machine.scm                              \
+  %D%/machine/digital-ocean.scm                        \
   %D%/machine/ssh.scm                          \
                                                \
   %D%/build/accounts.scm                       \
diff --git a/gnu/machine/digital-ocean.scm b/gnu/machine/digital-ocean.scm
new file mode 100644
index 0000000000..01393ccc35
--- /dev/null
+++ b/gnu/machine/digital-ocean.scm
@@ -0,0 +1,409 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 Jakob L. Kreuze <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 machine digital-ocean)
+  #:use-module (gnu machine ssh)
+  #:use-module (gnu machine)
+  #:use-module (gnu services networking)
+  #:use-module (gnu system)
+  #:use-module (guix base32)
+  #:use-module (guix derivations)
+  #:use-module (guix i18n)
+  #:use-module (guix import json)
+  #:use-module (guix monads)
+  #:use-module (guix records)
+  #:use-module (guix ssh)
+  #:use-module (guix store)
+  #:use-module (ice-9 hash-table)
+  #:use-module (ice-9 iconv)
+  #:use-module (json)
+  #:use-module (rnrs bytevectors)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-2)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:use-module (ssh key)
+  #:use-module (ssh sftp)
+  #:use-module (ssh shell)
+  #:use-module (web client)
+  #:use-module (web request)
+  #:use-module (web response)
+  #:use-module (web uri)
+  #:export (digital-ocean-configuration
+            digital-ocean-configuration?
+
+            digital-ocean-configuration-ssh-key
+            digital-ocean-configuration-region
+            digital-ocean-configuration-size
+            digital-ocean-configuration-enable-ipv6
+
+            digital-ocean-environment-type))
+
+;;; Commentary:
+;;;
+;;; This module implements a high-level interface for provisioning "droplets"
+;;; from the Digital Ocean virtual private server (VPS) service.
+;;;
+;;; Code:
+
+(define %api-base "https://api.digitalocean.com";)
+
+(define %digital-ocean-token
+  (make-parameter (getenv "GUIX_DIGITAL_OCEAN_TOKEN")))
+
+(define* (post-endpoint endpoint body)
+  "Encode BODY as JSON and send it to the Digital Ocean API endpoint
+ENDPOINT. This procedure is quite a bit more specialized than 'http-post', as
+it takes care to set headers such as 'Content-Type', 'Content-Length', and
+'Authorization' appropriately."
+  (let* ((uri (string->uri (string-append %api-base endpoint)))
+         (body (string->bytevector (scm->json-string body) "UTF-8"))
+         (headers `((User-Agent . "Guix Deploy")
+                    (Accept . "application/json")
+                    (Content-Type . "application/json")
+                    (Authorization . ,(format #f "Bearer ~a"
+                                              (%digital-ocean-token)))
+                    (Content-Length . ,(number->string
+                                        (bytevector-length body)))))
+         (port (open-socket-for-uri uri))
+         (request (build-request uri
+                                 #:method 'POST
+                                 #:version '(1 . 1)
+                                 #:headers headers
+                                 #:port port))
+         (request (write-request request port)))
+    (write-request-body request body)
+    (force-output (request-port request))
+    (let* ((response (read-response port))
+           (body (read-response-body response)))
+      (unless (= 2 (floor/ (response-code response) 100))
+        (raise
+         (condition (&message
+                     (message (format
+                               #f
+                               (G_ "~a: HTTP post failed: ~a (~s)")
+                               (uri->string uri)
+                               (response-code response)
+                               (response-reason-phrase response)))))))
+      (close-port port)
+      (bytevector->string body "UTF-8"))))
+
+(define (fetch-endpoint endpoint)
+  "Return the contents of the Digital Ocean API endpoint ENDPOINT as a Guile
+hash-table. This procedure is quite a bit more specialized than 'json-fetch',
+as it takes care to set headers such as 'Accept' and 'Authorization'
+appropriately."
+  (define headers
+    `((user-agent . "Guix Deploy")
+      (Accept . "application/json")
+      (Authorization . ,(format #f "Bearer ~a" (%digital-ocean-token)))))
+  (json-fetch (string-append %api-base endpoint) #:headers headers))
+
+
+;;;
+;;; Parameters for droplet creation.
+;;;
+
+(define-record-type* <digital-ocean-configuration> digital-ocean-configuration
+  make-digital-ocean-configuration
+  digital-ocean-configuration?
+  this-digital-ocean-configuration
+  (ssh-key     digital-ocean-configuration-ssh-key)      ; string
+  (region      digital-ocean-configuration-region)       ; string
+  (size        digital-ocean-configuration-size)         ; string
+  (enable-ipv6 digital-ocean-configuration-enable-ipv6)) ; boolean
+
+(define (read-key-fingerprint file-name)
+  "Read the private key at FILE-NAME and return the key's fingerprint as a hex
+string."
+  (let* ((privkey (private-key-from-file file-name))
+         (pubkey (private-key->public-key privkey))
+         (hash (get-public-key-hash pubkey 'md5)))
+    (bytevector->hex-string hash)))
+
+(define (droplet-name machine)
+  "Return a string uniquely identifying MACHINE."
+  (mlet* %store-monad ((os -> (machine-operating-system machine))
+                       (osdrv (operating-system-derivation os)))
+    (return
+     (format #f "~a-~a"
+             (machine-display-name machine)
+             (bytevector->base32-string (derivation-hash osdrv))))))
+
+(define (droplet-by-name name)
+  "Return a Guile hash-table describing the droplet named DROPLET-NAME."
+  (find (lambda (droplet)
+          (string= (hash-ref droplet "name") name))
+        (hash-ref (fetch-endpoint "/v2/droplets") "droplets")))
+
+(define (droplet-public-ipv4-network droplet-name)
+  "Return the public IPv4 network interface for the droplet named DROPLET-NAME
+as a Guile hash-table. The expected fields are 'ip_address', 'netmask', and
+'gateway'."
+  (and-let* ((droplet (droplet-by-name droplet-name))
+             (networks (hash-ref droplet "networks"))
+             (network (find (lambda (network)
+                              (string= "public" (hash-ref network "type")))
+                            (hash-ref networks "v4"))))
+    network))
+
+
+;;;
+;;; Remote evaluation.
+;;;
+
+(define (digital-ocean-remote-eval target exp)
+  "Internal implementation of 'machine-remote-eval' for MACHINE instances with
+an environment type of 'digital-ocean-environment-type'."
+  (mlet* %store-monad ((name (droplet-name target))
+                       (network -> (droplet-public-ipv4-network name))
+                       (address -> (hash-ref network "ip_address"))
+                       (ssh-key -> (digital-ocean-configuration-ssh-key
+                                    (machine-configuration target)))
+                       (delegate -> (machine
+                                     (inherit target)
+                                     (environment 
managed-host-environment-type)
+                                     (configuration
+                                      (machine-ssh-configuration
+                                       (host-name address)
+                                       (identity ssh-key)
+                                       (system "x86_64-linux"))))))
+    (machine-remote-eval delegate exp)))
+
+
+;;;
+;;; System deployment.
+;;;
+
+;; The following script was adapted from the guide available at
+;; <https://wiki.pantherx.org/Installation-digital-ocean/>.
+(define (guix-infect network)
+  "Given NETWORK, a Guile hash-table describing the Droplet's public IPv4
+network interface, return a Bash script that will install the Guix system."
+  (format #f "#!/bin/bash
+
+apt-get update
+apt-get install xz-utils -y
+wget https://ftp.gnu.org/gnu/guix/guix-binary-1.0.1.x86_64-linux.tar.xz
+cd /tmp
+tar --warning=no-timestamp -xf ~~/guix-binary-1.0.1.x86_64-linux.tar.xz
+mv var/guix /var/ && mv gnu /
+mkdir -p ~~root/.config/guix
+ln -sf /var/guix/profiles/per-user/root/current-guix 
~~root/.config/guix/current
+export GUIX_PROFILE=\"`echo ~~root`/.config/guix/current\" ;
+source $GUIX_PROFILE/etc/profile
+groupadd --system guixbuild
+for i in `seq -w 1 10`; do
+   useradd -g guixbuild -G guixbuild         \
+           -d /var/empty -s `which nologin`  \
+           -c \"Guix build user $i\" --system  \
+           guixbuilder$i;
+done;
+cp ~~root/.config/guix/current/lib/systemd/system/guix-daemon.service 
/etc/systemd/system/
+systemctl start guix-daemon && systemctl enable guix-daemon
+mkdir -p /usr/local/bin
+cd /usr/local/bin
+ln -s /var/guix/profiles/per-user/root/current-guix/bin/guix
+mkdir -p /usr/local/share/info
+cd /usr/local/share/info
+for i in /var/guix/profiles/per-user/root/current-guix/share/info/*; do
+    ln -s $i;
+done
+guix archive --authorize < 
~~root/.config/guix/current/share/guix/ci.guix.gnu.org.pub
+guix pull
+guix package -i glibc-utf8-locales
+export GUIX_LOCPATH=\"$HOME/.guix-profile/lib/locale\"
+guix package -i openssl
+cat > /etc/bootstrap-config.scm << EOF
+(use-modules (gnu))
+(use-service-modules networking ssh)
+
+(operating-system
+  (host-name \"gnu-bootstrap\")
+  (timezone \"Etc/UTC\")
+  (bootloader (bootloader-configuration
+               (bootloader grub-bootloader)
+               (target \"/dev/vda\")
+               (terminal-outputs '(console))))
+  (file-systems (cons (file-system
+                        (mount-point \"/\")
+                        (device \"/dev/vda1\")
+                        (type \"ext4\"))
+                      %base-file-systems))
+  (services
+   (append (list (static-networking-service \"eth0\" \"~a\"
+                    #:netmask \"~a\"
+                    #:gateway \"~a\"
+                    #:name-servers '(\"84.200.69.80\" \"84.200.70.40\"))
+                 (service openssh-service-type
+                          (openssh-configuration
+                           (permit-root-login 'without-password))))
+           %base-services)))
+EOF
+guix pull
+guix system build /etc/bootstrap-config.scm
+guix system reconfigure /etc/bootstrap-config.scm
+mv /etc /old-etc
+mkdir /etc
+cp -r /old-etc/{passwd,group,shadow,gshadow,mtab,guix,bootstrap-config.scm} 
/etc/
+guix system reconfigure /etc/bootstrap-config.scm"
+          (hash-ref network "ip_address")
+          (hash-ref network "netmask")
+          (hash-ref network "gateway")))
+
+(define (droplet-wait-until-available droplet-name)
+  "Block until the initial Debian image has been installed on the droplet
+named DROPLET-NAME."
+  (and-let* ((droplet (droplet-by-name droplet-name))
+             (droplet-id (hash-ref droplet "id"))
+             (endpoint (format #f "/v2/droplets/~a/actions" droplet-id)))
+    (let loop ()
+      (let ((actions (hash-ref (fetch-endpoint endpoint) "actions")))
+        (unless (every (lambda (action)
+                         (string= "completed" (hash-ref action "status")))
+                       actions)
+          (sleep 5)
+          (loop))))))
+
+(define (wait-for-ssh address ssh-key)
+  "Block until the an SSH session can be made as 'root' with SSH-KEY at 
ADDRESS."
+  (let loop ()
+    (catch #t
+      (lambda ()
+        (open-ssh-session address #:user "root" #:identity ssh-key))
+      (lambda args
+        (sleep 5)
+        (loop)))))
+
+(define (add-static-networking target network)
+  "Return an <operating-system> based on TARGET with a static networking
+configuration for the public IPv4 network described by the Guile hash-table
+NETWORK."
+  (operating-system
+    (inherit (machine-operating-system target))
+    (services (cons (static-networking-service "eth0"
+                        (hash-ref network "ip_address")
+                        #:netmask (hash-ref network "netmask")
+                        #:gateway (hash-ref network "gateway")
+                        #:name-servers '("84.200.69.80" "84.200.70.40"))
+                    (operating-system-services
+                     (machine-operating-system target))))))
+
+(define (deploy-digital-ocean target)
+  "Internal implementation of 'deploy-machine' for 'machine' instances with an
+environment type of 'digital-ocean-environment-type'."
+  (maybe-raise-missing-api-key-error)
+  (maybe-raise-unsupported-configuration-error target)
+  (mlet* %store-monad ((config -> (machine-configuration target))
+                       (name (droplet-name target))
+                       (region -> (digital-ocean-configuration-region config))
+                       (size -> (digital-ocean-configuration-size config))
+                       (ssh-key -> (digital-ocean-configuration-ssh-key 
config))
+                       (enable-ipv6 -> 
(digital-ocean-configuration-enable-ipv6 config))
+                       (fingerprint -> (read-key-fingerprint ssh-key))
+                       (request-body -> `(("name" . ,name)
+                                          ("region" . ,region)
+                                          ("size" . ,size)
+                                          ("image" . "debian-9-x64")
+                                          ("ssh_keys" . (,fingerprint))
+                                          ("backups" . #f)
+                                          ("ipv6" . ,enable-ipv6)
+                                          ("user_data" . #nil)
+                                          ("private_networking" . #nil)
+                                          ("volumes" . #nil)
+                                          ("tags" . ())))
+                       (response -> (post-endpoint "/v2/droplets" 
request-body)))
+    (droplet-wait-until-available name)
+    (let* ((network (droplet-public-ipv4-network name))
+           (address (hash-ref network "ip_address")))
+      (wait-for-ssh address ssh-key)
+      (let* ((ssh-session (open-ssh-session address #:user "root" #:identity 
ssh-key))
+             (sftp-session (make-sftp-session ssh-session)))
+        (call-with-remote-output-file sftp-session "/tmp/guix-infect.sh"
+                                      (lambda (port)
+                                        (display (guix-infect network) port)))
+        (rexec ssh-session "/bin/bash /tmp/guix-infect.sh")
+        ;; Session will close upon rebooting, which will raise 
'guile-ssh-error.
+        (catch 'guile-ssh-error
+          (lambda () (rexec ssh-session "reboot"))
+          (lambda args #t)))
+      (wait-for-ssh address ssh-key)
+      (let ((delegate (machine
+                       (operating-system (add-static-networking target 
network))
+                       (environment managed-host-environment-type)
+                       (configuration
+                        (machine-ssh-configuration
+                         (host-name address)
+                         (identity ssh-key)
+                         (system "x86_64-linux"))))))
+        (deploy-machine delegate)))))
+
+
+;;;
+;;; Roll-back.
+;;;
+
+(define (roll-back-digital-ocean machine)
+  "Internal implementation of 'roll-back-machine' for MACHINE instances with
+an environment type of 'digital-ocean-environment-type'. This destroys the
+associated droplet."
+  (mlet* %store-monad ((name (droplet-name machine)))
+    (let* ((droplet (droplet-by-name name))
+           (droplet-id (hash-ref droplet "id"))
+           (headers `((Content-Type . "application/json")
+                      (user-agent . "Guix Deploy")
+                      (Authorization . ,(format #f "Bearer ~a"
+                                                (%digital-ocean-token))))))
+      (http-delete (format #f "~a/v2/droplets/~a" %api-base droplet-id)
+                   #:headers headers))))
+
+
+;;;
+;;; Environment type.
+;;;
+
+(define digital-ocean-environment-type
+  (environment-type
+   (machine-remote-eval digital-ocean-remote-eval)
+   (deploy-machine      deploy-digital-ocean)
+   (roll-back-machine   roll-back-digital-ocean)
+   (name                'digital-ocean-environment-type)
+   (description         "Provisioning of \"droplets\": virtual machines
+ provided by the Digital Ocean virtual private server (VPS) service.")))
+
+
+(define (maybe-raise-missing-api-key-error)
+  (unless (%digital-ocean-token)
+    (raise (condition
+            (&message
+             (message (G_ "No Digital Ocean access token was provided. This \
+may be fixed by setting the environment variable GUIX_DIGITAL_OCAEN_TOKEN to \
+one procured from https://cloud.digitalocean.com/account/api/tokens.";)))))))
+
+(define (maybe-raise-unsupported-configuration-error machine)
+  "Raise an error if MACHINE's configuration is not an instance of
+<digital-ocean-configuration>."
+  (let ((config (machine-configuration machine))
+        (environment (environment-type-name (machine-environment machine))))
+    (unless (and config (digital-ocean-configuration? config))
+      (raise (condition
+              (&message
+               (message (format #f (G_ "unsupported machine configuration '~a'
+for environment of type '~a'")
+                                config
+                                environment))))))))
-- 
2.22.0

signature.asc
Description: PGP signature