Package: guix-patches;
Reported by: zerodaysfordays <at> sdf.lonestar.org (Jakob L. Kreuze)
Date: Mon, 19 Aug 2019 16:42:01 UTC
Severity: normal
Tags: fixed, patch
Done: Ludovic Courtès <ludo <at> gnu.org>
Bug is archived. No further changes may be made.
To add a comment to this bug, you must first unarchive it, by sending
a message to control AT debbugs.gnu.org, with unarchive 37083 in the body.
You can then email your comments to 37083 AT debbugs.gnu.org in the normal way.
Toggle the display of automated, internal messages from the tracker.
View this report as an mbox folder, status mbox, maintainer mbox
guix-patches <at> gnu.org:bug#37083; Package guix-patches.
(Mon, 19 Aug 2019 16:42:02 GMT) Full text and rfc822 format available.zerodaysfordays <at> sdf.lonestar.org (Jakob L. Kreuze):guix-patches <at> gnu.org.
(Mon, 19 Aug 2019 16:42:02 GMT) Full text and rfc822 format available.Message #5 received at submit <at> debbugs.gnu.org (full text, mbox):
From: zerodaysfordays <at> sdf.lonestar.org (Jakob L. Kreuze) To: guix-patches <at> gnu.org Subject: [PATCH 0/1] (Help needed!) machine: Implement 'digital-ocean-environment-type'. Date: Mon, 19 Aug 2019 12:41:24 -0400
[Message part 1 (text/plain, inline)]
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.
[Error (text/plain, inline)]
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)'.
[Message part 3 (text/plain, inline)]
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.
[config.scm (text/plain, inline)]
(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)))
[Message part 5 (text/plain, inline)]
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
[signature.asc (application/pgp-signature, inline)]
guix-patches <at> gnu.org:bug#37083; Package guix-patches.
(Mon, 19 Aug 2019 16:44:02 GMT) Full text and rfc822 format available.Message #8 received at 37083 <at> debbugs.gnu.org (full text, mbox):
From: zerodaysfordays <at> sdf.lonestar.org (Jakob L. Kreuze) To: 37083 <at> debbugs.gnu.org Subject: Re: [bug#37083] [PATCH 1/1] machine: Implement 'digital-ocean-environment-type'. Date: Mon, 19 Aug 2019 12:43:03 -0400
[Message part 1 (text/plain, inline)]
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 <at> 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))
+
+
+;;;
+;;; 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 (application/pgp-signature, inline)]
guix-patches <at> gnu.org:bug#37083; Package guix-patches.
(Tue, 27 Aug 2019 10:39:02 GMT) Full text and rfc822 format available.Message #11 received at 37083 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: zerodaysfordays <at> sdf.lonestar.org (Jakob L. Kreuze) Cc: 37083 <at> debbugs.gnu.org Subject: Re: [bug#37083] [PATCH 0/1] (Help needed!) machine: Implement 'digital-ocean-environment-type'. Date: Tue, 27 Aug 2019 12:38:23 +0200
Hi Jakob,
Nice that you’re working on Digital Ocean support!
zerodaysfordays <at> 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’.
guix-patches <at> gnu.org:bug#37083; Package guix-patches.
(Wed, 04 Sep 2019 12:09:02 GMT) Full text and rfc822 format available.Message #14 received at 37083 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: zerodaysfordays <at> sdf.lonestar.org (Jakob L. Kreuze) Cc: 37083 <at> debbugs.gnu.org Subject: Re: [bug#37083] [PATCH 0/1] (Help needed!) machine: Implement 'digital-ocean-environment-type'. Date: Wed, 04 Sep 2019 14:08:10 +0200
Hi Jakob,
Did you have a chance to try this out?
Thanks,
Ludo’.
Ludovic Courtès <ludo <at> gnu.org> skribis:
> Hi Jakob,
>
> Nice that you’re working on Digital Ocean support!
>
> zerodaysfordays <at> 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’.
guix-patches <at> gnu.org:bug#37083; Package guix-patches.
(Thu, 05 Sep 2019 14:17:02 GMT) Full text and rfc822 format available.Message #17 received at 37083 <at> debbugs.gnu.org (full text, mbox):
From: zerodaysfordays <at> sdf.lonestar.org (Jakob L. Kreuze) To: Ludovic Courtès <ludo <at> gnu.org> Cc: 37083 <at> debbugs.gnu.org Subject: Re: [bug#37083] [PATCH 0/1] (Help needed!) machine: Implement 'digital-ocean-environment-type'. Date: Thu, 05 Sep 2019 10:15:48 -0400
[Message part 1 (text/plain, inline)]
Hi Ludovic, Ludovic Courtès <ludo <at> 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
[signature.asc (application/pgp-signature, inline)]
guix-patches <at> gnu.org:bug#37083; Package guix-patches.
(Sat, 07 Sep 2019 20:11:01 GMT) Full text and rfc822 format available.Message #20 received at 37083 <at> debbugs.gnu.org (full text, mbox):
From: zerodaysfordays <at> sdf.lonestar.org (Jakob L. Kreuze) To: Ludovic Courtès <ludo <at> gnu.org> Cc: 37083 <at> debbugs.gnu.org Subject: Re: [bug#37083] [PATCH 0/1] (Help needed!) machine: Implement 'digital-ocean-environment-type'. Date: Sat, 07 Sep 2019 16:10:24 -0400
[Message part 1 (text/plain, inline)]
zerodaysfordays <at> 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
[signature.asc (application/pgp-signature, inline)]
guix-patches <at> gnu.org:bug#37083; Package guix-patches.
(Sun, 08 Sep 2019 19:38:02 GMT) Full text and rfc822 format available.Message #23 received at 37083 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: zerodaysfordays <at> sdf.lonestar.org (Jakob L. Kreuze) Cc: 37083 <at> debbugs.gnu.org Subject: Re: [bug#37083] [PATCH 0/1] (Help needed!) machine: Implement 'digital-ocean-environment-type'. Date: Sun, 08 Sep 2019 21:37:23 +0200
Hi Jakob, zerodaysfordays <at> 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’.
guix-patches <at> gnu.org:bug#37083; Package guix-patches.
(Sat, 21 Sep 2019 20:57:02 GMT) Full text and rfc822 format available.Message #26 received at 37083 <at> debbugs.gnu.org (full text, mbox):
From: zerodaysfordays <at> sdf.lonestar.org (Jakob L. Kreuze) To: Ludovic Courtès <ludo <at> gnu.org> Cc: 37083 <at> debbugs.gnu.org Subject: Re: [bug#37083] [PATCH 0/1] (Help needed!) machine: Implement 'digital-ocean-environment-type'. Date: Sat, 21 Sep 2019 16:56:36 -0400
[Message part 1 (text/plain, inline)]
Hey Ludovic,
Ludovic Courtès <ludo <at> 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:
[backtrace (text/plain, inline)]
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 <at> 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>)'.
[Message part 3 (text/plain, inline)]
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
[signature.asc (application/pgp-signature, inline)]
guix-patches <at> gnu.org:bug#37083; Package guix-patches.
(Mon, 23 Sep 2019 08:25:02 GMT) Full text and rfc822 format available.Message #29 received at 37083 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: zerodaysfordays <at> sdf.lonestar.org (Jakob L. Kreuze) Cc: 37083 <at> debbugs.gnu.org Subject: Re: [bug#37083] [PATCH 0/1] (Help needed!) machine: Implement 'digital-ocean-environment-type'. Date: Mon, 23 Sep 2019 10:24:07 +0200
Hi Jakob!
zerodaysfordays <at> sdf.lonestar.org (Jakob L. Kreuze) skribis:
> Ludovic Courtès <ludo <at> 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’.
guix-patches <at> gnu.org:bug#37083; Package guix-patches.
(Sat, 28 Sep 2019 20:47:01 GMT) Full text and rfc822 format available.Message #32 received at 37083 <at> debbugs.gnu.org (full text, mbox):
From: zerodaysfordays <at> sdf.lonestar.org (Jakob L. Kreuze) To: Ludovic Courtès <ludo <at> gnu.org> Cc: 37083 <at> debbugs.gnu.org Subject: Re: [bug#37083] [PATCH 0/1] (Help needed!) machine: Implement 'digital-ocean-environment-type'. Date: Sat, 28 Sep 2019 16:46:23 -0400
[Message part 1 (text/plain, inline)]
Ludovic Courtès <ludo <at> 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
[signature.asc (application/pgp-signature, inline)]
guix-patches <at> gnu.org:bug#37083; Package guix-patches.
(Sat, 28 Sep 2019 20:48:02 GMT) Full text and rfc822 format available.Message #35 received at 37083 <at> debbugs.gnu.org (full text, mbox):
From: zerodaysfordays <at> sdf.lonestar.org (Jakob L. Kreuze) To: Ludovic Courtès <ludo <at> gnu.org> Cc: 37083 <at> debbugs.gnu.org Subject: Re: [bug#37083] [PATCH] machine: Implement 'digital-ocean-environment-type'. Date: Sat, 28 Sep 2019 16:47:21 -0400
[Message part 1 (text/plain, inline)]
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 <at> 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))
+
+
+;;;
+;;; 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))
+
+
+;;;
+;;; 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)))
+
+
+;;;
+;;; 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)))))
+
+
+;;;
+;;; 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)))
+
+
+;;;
+;;; 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
[signature.asc (application/pgp-signature, inline)]
guix-patches <at> gnu.org:bug#37083; Package guix-patches.
(Sat, 28 Sep 2019 22:37:01 GMT) Full text and rfc822 format available.Message #38 received at 37083 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: zerodaysfordays <at> sdf.lonestar.org (Jakob L. Kreuze) Cc: 37083 <at> debbugs.gnu.org Subject: Re: [bug#37083] [PATCH] machine: Implement 'digital-ocean-environment-type'. Date: Sun, 29 Sep 2019 00:36:10 +0200
Hi Jakob!
zerodaysfordays <at> 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’.
guix-patches <at> gnu.org:bug#37083; Package guix-patches.
(Sun, 13 Oct 2019 10:57:02 GMT) Full text and rfc822 format available.Message #41 received at 37083 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: zerodaysfordays <at> sdf.lonestar.org (Jakob L. Kreuze) Cc: 37083 <at> debbugs.gnu.org Subject: Re: [bug#37083] [PATCH] machine: Implement 'digital-ocean-environment-type'. Date: Sun, 13 Oct 2019 12:56:21 +0200
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 <at> gnu.org> skribis: > Hi Jakob! > > zerodaysfordays <at> 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’.
guix-patches <at> gnu.org:bug#37083; Package guix-patches.
(Tue, 22 Oct 2019 16:35:01 GMT) Full text and rfc822 format available.Message #44 received at 37083 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: zerodaysfordays <at> sdf.lonestar.org (Jakob L. Kreuze) Cc: 37083 <at> debbugs.gnu.org Subject: Re: [bug#37083] [PATCH] machine: Implement 'digital-ocean-environment-type'. Date: Tue, 22 Oct 2019 18:34:07 +0200
Hi, Ludovic Courtès <ludo <at> 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’.
guix-patches <at> gnu.org:bug#37083; Package guix-patches.
(Tue, 22 Oct 2019 20:57:02 GMT) Full text and rfc822 format available.Message #47 received at 37083 <at> debbugs.gnu.org (full text, mbox):
From: zerodaysfordays <at> sdf.lonestar.org (Jakob L. Kreuze) To: Ludovic Courtès <ludo <at> gnu.org> Cc: 37083 <at> debbugs.gnu.org Subject: Re: [bug#37083] [PATCH] machine: Implement 'digital-ocean-environment-type'. Date: Tue, 22 Oct 2019 16:56:06 -0400
[Message part 1 (text/plain, inline)]
Hi Ludo, Ludovic Courtès <ludo <at> gnu.org> writes: > Ludovic Courtès <ludo <at> 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
[signature.asc (application/pgp-signature, inline)]
guix-patches <at> gnu.org:bug#37083; Package guix-patches.
(Wed, 23 Oct 2019 09:43:02 GMT) Full text and rfc822 format available.Message #50 received at 37083 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: zerodaysfordays <at> sdf.lonestar.org (Jakob L. Kreuze) Cc: 37083 <at> debbugs.gnu.org Subject: Re: [bug#37083] [PATCH] machine: Implement 'digital-ocean-environment-type'. Date: Wed, 23 Oct 2019 11:42:14 +0200
Hi Jakob, zerodaysfordays <at> sdf.lonestar.org (Jakob L. Kreuze) skribis: > Ludovic Courtès <ludo <at> gnu.org> writes: > >> Ludovic Courtès <ludo <at> 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’.
Ludovic Courtès <ludo <at> gnu.org>
to control <at> debbugs.gnu.org.
(Wed, 04 Dec 2019 17:08:01 GMT) Full text and rfc822 format available.Ludovic Courtès <ludo <at> gnu.org>
to control <at> debbugs.gnu.org.
(Wed, 04 Dec 2019 17:08:01 GMT) Full text and rfc822 format available.Debbugs Internal Request <help-debbugs <at> gnu.org>
to internal_control <at> debbugs.gnu.org.
(Thu, 02 Jan 2020 12:24:07 GMT) Full text and rfc822 format available.
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.