[bug#37083] [PATCH 0/1] (Help needed!) machine: Implement 'digital-ocean-environment-type'.

[bug#37083] [PATCH 0/1] (Help needed!) machine: Implement 'digital-ocean-environment-type'.

[Jakob L. Kreuze]

[-- Attachment #1.1: Type: text/plain, Size: 495 bytes --]

Hi all,

I've spent the past couple of days attempting to add rudimentary support
to 'guix deploy' for some more complicated use-cases. I think I've made
some decent progress, but I've reached a point where I'm having an issue
that's beyond my abilities.

'deploy-digital-ocean' gets to a point where there's a droplet running a
"bootstrap" configuration of the Guix System, but I can't keep an open
SSH channel for sending over the operating-system configuration
specified for the deployment.


[-- Attachment #1.2: Error --]
[-- Type: text/plain, Size: 1894 bytes --]

sending 3 store items (0 MiB) to '167.71.253.223'...
;;; [2019/08/19 12:21:33.409456, 0] write_to_channel_port: [GSSH ERROR] Remote channel is closed: #<input-output: channel (open) d3b2e0>
Backtrace:
In ice-9/eval.scm:
    619:8 19 (_ #(#(#<directory (guile-user) e17140>)))
In guix/ui.scm:
  1692:12 18 (run-guix-command _ . _)
In guix/store.scm:
   623:10 17 (call-with-store _)
In srfi/srfi-1.scm:
    640:9 16 (for-each #<procedure 48d21c0 at guix/scripts/deploy.s…> …)
In guix/scripts/deploy.scm:
    96:20 15 (_ _)
In ice-9/boot-9.scm:
    829:9 14 (catch _ _ #<procedure 48d4980 at guix/scripts/deploy.…> …)
In guix/store.scm:
  1803:24 13 (run-with-store #<store-connection 256.99 43d6420> _ # _ …)
In unknown file:
          12 (_ #<procedure 48fe260 at ice-9/eval.scm:330:13 ()> #<…> …)
          11 (_ #<procedure 4975a20 at ice-9/eval.scm:330:13 ()> #<…> …)
          10 (_ #<procedure 4975840 at ice-9/eval.scm:330:13 ()> #<…> …)
In guix/monads.scm:
    482:9  9 (_ _)
In unknown file:
           8 (_ #<procedure 4975660 at ice-9/eval.scm:330:13 ()> #<…> …)
In guix/remote.scm:
   134:10  7 (_ _)
In guix/store.scm:
  1696:38  6 (_ #<store-connection 256.99 3606720>)
In guix/ssh.scm:
    358:4  5 (send-files #<store-connection 256.99 3606720> _ _ # _ # …)
In guix/store.scm:
  1568:12  4 (export-paths #<store-connection 256.99 3606720> _ #<i…> …)
  1548:22  3 (export-path #<store-connection 256.99 3606720> _ #<in…> …)
   697:13  2 (process-stderr _ _)
   660:10  1 (dump-port #<input-output: socket 15> #<input-output: …> …)
In unknown file:
           0 (put-bytevector #<input-output: channel (open) d3b2e0> # …)

ERROR: In procedure put-bytevector:
Throw to key `guile-ssh-error' with args `("write_to_channel_port" "Remote channel is closed" #<input-output: channel (open) d3b2e0> #f)'.

[-- Attachment #1.3: Type: text/plain, Size: 341 bytes --]


I can connect to the droplet over SSH, but trying to manually deploy to
the droplet with 'managed-host-environment-type' fails with the same
error. I am still able to deploy to my various Guix QEMU guests using
'managed-host-environment-type' without fail -- this seems to be
specific to Digital Ocean droplets running this configuration.


[-- Attachment #1.4: config.scm --]
[-- Type: text/plain, Size: 899 bytes --]

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

[-- Attachment #1.5: Type: text/plain, Size: 657 bytes --]


I suspect there may an issue with the configuration of the bootstrap
system's SSH daemon, but the logs are devoid of anything particularly
telling. If anyone is willing to offer up their knowledge of SSH to
suggest what could be going wrong, I would appreciate it greatly.

Thank you,
Jakob

Jakob L. Kreuze (1):
  machine: Implement 'digital-ocean-environment-type'.

 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

-- 
2.22.0


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

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

[Jakob L. Kreuze]

[-- Attachment #1: Type: text/plain, Size: 20623 bytes --]

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 <zerodaysfordays@sdf.lonestar.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 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))
+
+\f
+;;;
+;;; 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))
+
+\f
+;;;
+;;; 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)))
+
+\f
+;;;
+;;; 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)))))
+
+\f
+;;;
+;;; 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))))
+
+\f
+;;;
+;;; 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


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#37083] [PATCH 0/1] (Help needed!) machine: Implement 'digital-ocean-environment-type'.

[Ludovic Courtès]

Hi Jakob,

Nice that you’re working on Digital Ocean support!

zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) skribis:

> 'deploy-digital-ocean' gets to a point where there's a droplet running a
> "bootstrap" configuration of the Guix System, but I can't keep an open
> SSH channel for sending over the operating-system configuration
> specified for the deployment.

[...]

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

Could you add (log-level 'debug) to ‘openssh-configuration’, then try
again ‘guix deploy’, and finally grab the OpenSSH log from that machine?
That would allow us to see if there’s something wrong with SSH.

Hmm now that I think about it, ‘send-files’ may be failing because the
(guix …) modules aren’t in GUILE_LOAD_PATH on the remote side.  On the
berlin build machines, we have this:

  (simple-service 'guile-load-path-in-global-env
                  session-environment-service-type
                  `(("GUILE_LOAD_PATH"
                     . "/run/current-system/profile/share/guile/site/2.2")
                    ("GUILE_LOAD_COMPILED_PATH"
                     . ,(string-append "/run/current-system/profile/lib/guile/2.2/site-ccache:"
                                       "/run/current-system/profile/share/guile/site/2.2"))))

It’s ridiculous that we have to do this, but that’s how it is.

Can you try that?

HTH,
Ludo’.

[bug#37083] [PATCH 0/1] (Help needed!) machine: Implement 'digital-ocean-environment-type'.

[Ludovic Courtès]

Hi Jakob,

Did you have a chance to try this out?

Thanks,
Ludo’.

Ludovic Courtès <ludo@gnu.org> skribis:

> Hi Jakob,
>
> Nice that you’re working on Digital Ocean support!
>
> zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) skribis:
>
>> 'deploy-digital-ocean' gets to a point where there's a droplet running a
>> "bootstrap" configuration of the Guix System, but I can't keep an open
>> SSH channel for sending over the operating-system configuration
>> specified for the deployment.
>
> [...]
>
>>   (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)))
>
> Could you add (log-level 'debug) to ‘openssh-configuration’, then try
> again ‘guix deploy’, and finally grab the OpenSSH log from that machine?
> That would allow us to see if there’s something wrong with SSH.
>
> Hmm now that I think about it, ‘send-files’ may be failing because the
> (guix …) modules aren’t in GUILE_LOAD_PATH on the remote side.  On the
> berlin build machines, we have this:
>
>   (simple-service 'guile-load-path-in-global-env
>                   session-environment-service-type
>                   `(("GUILE_LOAD_PATH"
>                      . "/run/current-system/profile/share/guile/site/2.2")
>                     ("GUILE_LOAD_COMPILED_PATH"
>                      . ,(string-append "/run/current-system/profile/lib/guile/2.2/site-ccache:"
>                                        "/run/current-system/profile/share/guile/site/2.2"))))
>
> It’s ridiculous that we have to do this, but that’s how it is.
>
> Can you try that?
>
> HTH,
> Ludo’.

[bug#37083] [PATCH 0/1] (Help needed!) machine: Implement 'digital-ocean-environment-type'.

[Jakob L. Kreuze]

[-- Attachment #1: Type: text/plain, Size: 363 bytes --]

Hi Ludovic,

Ludovic Courtès <ludo@gnu.org> writes:

> Did you have a chance to try this out?

So sorry about this -- I've been busy moving in for fall semester and
the little bit of time I had to work on this was spent migrating the
code to the newer guile-json API. I will have some time this weekend to
see if it fixes the issue.

Regards,
Jakob

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#37083] [PATCH 0/1] (Help needed!) machine: Implement 'digital-ocean-environment-type'.

[Jakob L. Kreuze]

[-- Attachment #1: Type: text/plain, Size: 503 bytes --]

zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) writes:

> So sorry about this -- I've been busy moving in for fall semester and
> the little bit of time I had to work on this was spent migrating the
> code to the newer guile-json API. I will have some time this weekend to
> see if it fixes the issue.

Indeed, it does :)  Now, to fix the other issues with this. I'm getting a
"more than one target service of type 'shepherd-root'" error, which is
unusual. I'll investigate further.

Regards,
Jakob

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#37083] [PATCH 0/1] (Help needed!) machine: Implement 'digital-ocean-environment-type'.

[Ludovic Courtès]

Hi Jakob,

zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) skribis:

> Indeed, it does :)

Yay!

> Now, to fix the other issues with this. I'm getting a "more than one
> target service of type 'shepherd-root'" error, which is unusual. I'll
> investigate further.

Presumably there’s more than one service of type
‘shepherd-root-service-type’ in the ‘services’ field?  Let me know if I
can help.

Good luck with your other endeavors!

Thanks,
Ludo’.

[bug#37083] [PATCH 0/1] (Help needed!) machine: Implement 'digital-ocean-environment-type'.

[Jakob L. Kreuze]

[-- Attachment #1.1: Type: text/plain, Size: 1357 bytes --]

Hey Ludovic,

Ludovic Courtès <ludo@gnu.org> writes:

> Presumably there’s more than one service of type
> ‘shepherd-root-service-type’ in the ‘services’ field? Let me know if I
> can help.

Sorry about how long this has been taking, I've been plucking away at it
on the weekends, but I've reached the point where I have to admit that
I'm stuck and I really need help if I'm ever going to finish this.

I have this procedure to create a static networking service for the
Digital Ocean droplet based on an API response:

(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 alist NETWORK."
  (operating-system
    (inherit (machine-operating-system target))
    (services (cons (static-networking-service "eth0"
                        (assoc-ref network "ip_address")
                        #:netmask (assoc-ref network "netmask")
                        #:gateway (assoc-ref network "gateway")
                        #:name-servers '("84.200.69.80" "84.200.70.40"))
                    (operating-system-services
                     (machine-operating-system target))))))

And when this operating system is deployed with the basic SSH
environment-type, I get the following backtrace:


[-- Attachment #1.2: backtrace --]
[-- Type: text/plain, Size: 1335 bytes --]

Backtrace:
           6 (apply-smob/1 #<catch-closure 23ab600>)
In ice-9/boot-9.scm:
    705:2  5 (call-with-prompt _ _ #<procedure default-prompt-handle…>)
In ice-9/eval.scm:
    619:8  4 (_ #(#(#<directory (guile-user) 24a1140>)))
In guix/ui.scm:
  1692:12  3 (run-guix-command _ . _)
In guix/store.scm:
   623:10  2 (call-with-store _)
In srfi/srfi-1.scm:
    640:9  1 (for-each #<procedure 4fbf800 at guix/scripts/deploy.s…> …)
In guix/scripts/deploy.scm:
    96:20  0 (_ _)

guix/scripts/deploy.scm:96:20: Throw to key `srfi-34' with args `(#<condition %compound [service: #<<service> type: #<service-type openssh 4246960> value: #<<openssh-configuration> openssh: #<package openssh@8.0p1 gnu/packages/ssh.scm:165 3315210> pid-file: "/var/run/sshd.pid" port-number: 22 permit-root-login: #t allow-empty-passwords?: #f password-authentication?: #t public-key-authentication?: #t x11-forwarding?: #f allow-agent-forwarding?: #t allow-tcp-forwarding?: #t gateway-ports?: #f challenge-response-authentication?: #f use-pam?: #t print-last-log?: #t subsystems: (("sftp" "internal-sftp")) accepted-environment: () log-level: info extra-content: "" authorized-keys: () %auto-start?: #t>> target-type: #<service-type shepherd-root 2c4ac30> message: "more than one target service of type 'shepherd-root'"] 5579510>)'.

[-- Attachment #1.3: Type: text/plain, Size: 168 bytes --]


I have no idea where to begin with this. Why would the OpenSSH service
be giving me this "more than one target service of type 'shepherd-root'"
error?

Regards,
Jakob

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#37083] [PATCH 0/1] (Help needed!) machine: Implement 'digital-ocean-environment-type'.

[Ludovic Courtès]

Hi Jakob!

zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) skribis:

> Ludovic Courtès <ludo@gnu.org> writes:
>
>> Presumably there’s more than one service of type
>> ‘shepherd-root-service-type’ in the ‘services’ field? Let me know if I
>> can help.
>
> Sorry about how long this has been taking, I've been plucking away at it
> on the weekends, but I've reached the point where I have to admit that
> I'm stuck and I really need help if I'm ever going to finish this.
>
> I have this procedure to create a static networking service for the
> Digital Ocean droplet based on an API response:
>
> (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 alist NETWORK."
>   (operating-system
>     (inherit (machine-operating-system target))
>     (services (cons (static-networking-service "eth0"
>                         (assoc-ref network "ip_address")
>                         #:netmask (assoc-ref network "netmask")
>                         #:gateway (assoc-ref network "gateway")
>                         #:name-servers '("84.200.69.80" "84.200.70.40"))
>                     (operating-system-services
>                      (machine-operating-system target))))))

Oooh, got it: right above, you should call
‘operating-system-user-services’, not ‘operating-system-services’.

The latter includes “essential” services like ‘etc’ and ‘shepherd-root’,
which is why we’d end up with two copies of each of these.

Admittedly quite error-prone!

Let me know if there are other stumbling blocks.  I look forward to
seeing Digital Ocean support in ‘guix deploy’!

Thanks,
Ludo’.

[bug#37083] [PATCH 0/1] (Help needed!) machine: Implement 'digital-ocean-environment-type'.

[Jakob L. Kreuze]

[-- Attachment #1: Type: text/plain, Size: 677 bytes --]

Ludovic Courtès <ludo@gnu.org> writes:

> Oooh, got it: right above, you should call
> ‘operating-system-user-services’, not ‘operating-system-services’.
>
> The latter includes “essential” services like ‘etc’ and ‘shepherd-root’,
> which is why we’d end up with two copies of each of these.
>
> Admittedly quite error-prone!

Ah, thank you. I feel like I've been bitten by that once before and just
forgot.

> Let me know if there are other stumbling blocks.  I look forward to
> seeing Digital Ocean support in ‘guix deploy’!

With that, I think we've got working support for Digital Ocean :)  Patch
to follow.

Regards,
Jakob

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

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

[Jakob L. Kreuze]

[-- Attachment #1: Type: text/plain, Size: 21414 bytes --]

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                 |  24 +-
 gnu/local.mk                  |   1 +
 gnu/machine/digital-ocean.scm | 422 ++++++++++++++++++++++++++++++++++
 3 files changed, 444 insertions(+), 3 deletions(-)
 create mode 100644 gnu/machine/digital-ocean.scm

diff --git a/doc/guix.texi b/doc/guix.texi
index 0d3bb19325..0c8d531684 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -25929,12 +25929,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
@@ -25962,6 +25960,26 @@ 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{tags}
+A list of string ``tags'' that uniquely identify the machine. Must be given
+such that no two machines in the deployment have the same set of tags.
+@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 b04a5d796e..3bcde0ccc5 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -578,6 +578,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..5ad7c4d4a3
--- /dev/null
+++ b/gnu/machine/digital-ocean.scm
@@ -0,0 +1,422 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.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 machine digital-ocean)
+  #:use-module (gnu machine ssh)
+  #:use-module (gnu machine)
+  #:use-module (gnu services)
+  #:use-module (gnu services networking)
+  #:use-module (gnu system)
+  #:use-module (gnu system pam)
+  #: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 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-tags
+            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 an
+alist. 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))
+
+\f
+;;;
+;;; 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
+  (tags        digital-ocean-configuration-tags)         ; list of strings
+  (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 (machine-droplet machine)
+  "Return an alist describing the droplet allocated to MACHINE."
+  (let ((tags (digital-ocean-configuration-tags
+               (machine-configuration machine))))
+    (find (lambda (droplet)
+            (equal? (assoc-ref droplet "tags") (list->vector tags)))
+          (vector->list
+           (assoc-ref (fetch-endpoint "/v2/droplets") "droplets")))))
+
+(define (machine-public-ipv4-network machine)
+  "Return the public IPv4 network interface of the droplet allocated to
+MACHINE as an alist. The expected fields are 'ip_address', 'netmask', and
+'gateway'."
+  (and-let* ((droplet (machine-droplet machine))
+             (networks (assoc-ref droplet "networks"))
+             (network (find (lambda (network)
+                              (string= "public" (assoc-ref network "type")))
+                            (vector->list (assoc-ref networks "v4")))))
+    network))
+
+\f
+;;;
+;;; 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'."
+  (let* ((network (machine-public-ipv4-network target))
+         (address (assoc-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)))
+
+\f
+;;;
+;;; 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, an alist 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\"))
+                 (simple-service 'guile-load-path-in-global-env
+                  session-environment-service-type
+                  \\`((\"GUILE_LOAD_PATH\"
+                     . \"/run/current-system/profile/share/guile/site/2.2\")
+                    (\"GUILE_LOAD_COMPILED_PATH\"
+                     . ,(string-append \"/run/current-system/profile/lib/guile/2.2/site-ccache:\"
+                                       \"/run/current-system/profile/share/guile/site/2.2\"))))
+                 (service openssh-service-type
+                          (openssh-configuration
+                           (log-level 'debug)
+                           (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"
+          (assoc-ref network "ip_address")
+          (assoc-ref network "netmask")
+          (assoc-ref network "gateway")))
+
+(define (machine-wait-until-available machine)
+  "Block until the initial Debian image has been installed on the droplet
+named DROPLET-NAME."
+  (and-let* ((droplet (machine-droplet machine))
+             (droplet-id (assoc-ref droplet "id"))
+             (endpoint (format #f "/v2/droplets/~a/actions" droplet-id)))
+    (let loop ()
+      (let ((actions (assoc-ref (fetch-endpoint endpoint) "actions")))
+        (unless (every (lambda (action)
+                         (string= "completed" (assoc-ref action "status")))
+                       (vector->list 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 alist NETWORK."
+  (operating-system
+    (inherit (machine-operating-system target))
+    (services (cons* (static-networking-service "eth0"
+                        (assoc-ref network "ip_address")
+                        #:netmask (assoc-ref network "netmask")
+                        #:gateway (assoc-ref network "gateway")
+                        #:name-servers '("84.200.69.80" "84.200.70.40"))
+                    (simple-service 'guile-load-path-in-global-env
+                                    session-environment-service-type
+                                    `(("GUILE_LOAD_PATH"
+                                       . "/run/current-system/profile/share/guile/site/2.2")
+                                      ("GUILE_LOAD_COMPILED_PATH"
+                                       . ,(string-append "/run/current-system/profile/lib/guile/2.2/site-ccache:"
+                                                         "/run/current-system/profile/share/guile/site/2.2"))))
+                    (operating-system-user-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)
+  (let* ((config (machine-configuration target))
+         (name (machine-display-name target))
+         (region (digital-ocean-configuration-region config))
+         (size (digital-ocean-configuration-size config))
+         (ssh-key (digital-ocean-configuration-ssh-key config))
+         (fingerprint (read-key-fingerprint ssh-key))
+         (enable-ipv6 (digital-ocean-configuration-enable-ipv6 config))
+         (tags (digital-ocean-configuration-tags config))
+         (request-body `(("name" . ,name)
+                         ("region" . ,region)
+                         ("size" . ,size)
+                         ("image" . "debian-9-x64")
+                         ("ssh_keys" . ,(vector fingerprint))
+                         ("backups" . #f)
+                         ("ipv6" . ,enable-ipv6)
+                         ("user_data" . #nil)
+                         ("private_networking" . #nil)
+                         ("volumes" . #nil)
+                         ("tags" . ,(list->vector tags))))
+         (response (post-endpoint "/v2/droplets" request-body)))
+    (machine-wait-until-available target)
+    (let* ((network (machine-public-ipv4-network target))
+           (address (assoc-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)))))
+
+\f
+;;;
+;;; Roll-back.
+;;;
+
+(define (roll-back-digital-ocean target)
+  "Internal implementation of 'roll-back-machine' for MACHINE instances with an
+environment type of 'digital-ocean-environment-type'."
+  (let* ((network (machine-public-ipv4-network target))
+         (address (assoc-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"))))))
+    (roll-back-machine delegate)))
+
+\f
+;;;
+;;; 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.21.0

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

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

[Ludovic Courtès]

Hi Jakob!

zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) skribis:

> gnu/machine/digital-ocean.scm: New file.
> gnu/local.mk (GNU_SYSTEM_MODULES): Add it.
> doc/guix.texi (Invoking 'guix deploy'): Add documentation for
  ^
Nitpick: please add a “*” before each bullet.  :-)

Apart from that, LGTM, woohoo!

> +(define (fetch-endpoint endpoint)
> +  "Return the contents of the Digital Ocean API endpoint ENDPOINT as an
> +alist. 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))

Note for later: we could use ‘define-json-mapping’ to work on Scheme
records rather than on alists.

> +             (message (G_ "No Digital Ocean access token was provided. This \
> +may be fixed by setting the environment variable GUIX_DIGITAL_OCAEN_TOKEN to \
                                                                   ^^
Typo.

Thank you!

Ludo’.

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

[Ludovic Courtès]

Hi Jakob,

A friendly reminder.  :-)

I can commit it on your behalf if you lack the bandwidth right now.

Thanks,
Ludo’.

Ludovic Courtès <ludo@gnu.org> skribis:

> Hi Jakob!
>
> zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) skribis:
>
>> gnu/machine/digital-ocean.scm: New file.
>> gnu/local.mk (GNU_SYSTEM_MODULES): Add it.
>> doc/guix.texi (Invoking 'guix deploy'): Add documentation for
>   ^
> Nitpick: please add a “*” before each bullet.  :-)
>
> Apart from that, LGTM, woohoo!
>
>> +(define (fetch-endpoint endpoint)
>> +  "Return the contents of the Digital Ocean API endpoint ENDPOINT as an
>> +alist. 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))
>
> Note for later: we could use ‘define-json-mapping’ to work on Scheme
> records rather than on alists.
>
>> +             (message (G_ "No Digital Ocean access token was provided. This \
>> +may be fixed by setting the environment variable GUIX_DIGITAL_OCAEN_TOKEN to \
>                                                                    ^^
> Typo.
>
> Thank you!
>
> Ludo’.

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

[Ludovic Courtès]

Hi,

Ludovic Courtès <ludo@gnu.org> skribis:

> I can commit it on your behalf if you lack the bandwidth right now.

Done!

I followed up with commit c93994b5e43acc6048b81836d30632e015306c92 to
rename ‘enable-ipv6’ to ‘enable-ipv6?’ with a question mark as is
customary.  :-)

Thanks,
Ludo’.

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

[Jakob L. Kreuze]

[-- Attachment #1: Type: text/plain, Size: 583 bytes --]

Hi Ludo,

Ludovic Courtès <ludo@gnu.org> writes:

> Ludovic Courtès <ludo@gnu.org> skribis:
>
>> I can commit it on your behalf if you lack the bandwidth right now.
>
> Done!
>
> I followed up with commit c93994b5e43acc6048b81836d30632e015306c92 to
> rename ‘enable-ipv6’ to ‘enable-ipv6?’ with a question mark as is
> customary.  :-)

Thanks! Sorry, I haven't paying as much attention to this mailing list
recently due to the whole you-know-what spiel, so that email ended up
burried in my inbox. Glad it finally made it into master :)

Regards,
Jakob

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

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

[Ludovic Courtès]

Hi Jakob,

zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) skribis:

> Ludovic Courtès <ludo@gnu.org> writes:
>
>> Ludovic Courtès <ludo@gnu.org> skribis:
>>
>>> I can commit it on your behalf if you lack the bandwidth right now.
>>
>> Done!
>>
>> I followed up with commit c93994b5e43acc6048b81836d30632e015306c92 to
>> rename ‘enable-ipv6’ to ‘enable-ipv6?’ with a question mark as is
>> customary.  :-)
>
> Thanks! Sorry, I haven't paying as much attention to this mailing list
> recently due to the whole you-know-what spiel, so that email ended up
> burried in my inbox. Glad it finally made it into master :)

Heheh, I understand, and I’m happy it has landed too!

Ludo’.