kreyren/guix-kreyren
1
0
Fork 0
Code Issues 1 Pull Requests 1 Releases Activity
005763301f
guix-kreyren/gnu/machine/digital-ocean.scm
Maxim Cournoyer da4e409483
Migrate to the new 'targets' field of bootloader-configuration. 
The old 'target' field is deprecated; adjust the sources to use the new
'targets' one instead.

* doc/guix-cookbook.texi<target>: Replace by 'targets'.
* gnu/bootloader/grub.scm: Likewise.
* gnu/installer/parted.scm: Likewise.
* gnu/machine/digital-ocean.scm: Likewise.
* gnu/system/examples/asus-c201.tmpl: Likewise
* gnu/system/examples/bare-bones.tmpl: Likewise
* gnu/system/examples/bare-hurd.tmpl: Likewise
* gnu/system/examples/beaglebone-black.tmpl: Likewise
* gnu/system/examples/desktop.tmpl: Likewise
* gnu/system/examples/docker-image.tmpl: Likewise
* gnu/system/examples/lightweight-desktop.tmpl: Likewise
* gnu/system/examples/vm-image.tmpl: Likewise
* gnu/system/examples/yggdrasil.tmpl: Likewise
* gnu/system/hurd.scm: Likewise
* gnu/system/images/hurd.scm: Likewise
* gnu/system/images/novena.scm: Likewise
* gnu/system/images/pine64.scm: Likewise
* gnu/system/images/pinebook-pro.scm: Likewise
* gnu/system/images/rock64.scm: Likewise
* gnu/system/install.scm: Likewise
* gnu/system/vm.scm: Likewise
* gnu/tests.scm: Likewise
* gnu/tests/ganeti.scm: Likewise
* gnu/tests/install.scm: Likewise
* gnu/tests/nfs.scm: Likewise
* gnu/tests/telephony.scm: Likewise
* tests/boot-parameters.scm: Likewise
* tests/system.scm: Likewise
2021-08-29 01:05:26 -04:00

423 lines
18 KiB
Scheme
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.org>
;;; Copyright © 2020 Brice Waegeneire <brice@waegenei.re>
;;;
;;; 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 diagnostics) #:select (formatted-message))
#: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)
(targets '(\"/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 'prohibit-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 (formatted-message (G_ "unsupported machine configuration '~a' \
for environment of type '~a'")
config
environment)))))
Reference in New Issue View Git Blame Copy Permalink