Commit | Line | Data |
---|---|---|
12712817 | 1 | ;;; GNU Guix --- Functional package management for GNU |
e8134442 | 2 | ;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.org> |
12712817 JK |
3 | ;;; |
4 | ;;; This file is part of GNU Guix. | |
5 | ;;; | |
6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
7 | ;;; under the terms of the GNU General Public License as published by | |
8 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
9 | ;;; your option) any later version. | |
10 | ;;; | |
11 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
14 | ;;; GNU General Public License for more details. | |
15 | ;;; | |
16 | ;;; You should have received a copy of the GNU General Public License | |
17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
18 | ||
19 | (define-module (gnu machine digital-ocean) | |
20 | #:use-module (gnu machine ssh) | |
21 | #:use-module (gnu machine) | |
22 | #:use-module (gnu services) | |
23 | #:use-module (gnu services networking) | |
24 | #:use-module (gnu system) | |
25 | #:use-module (gnu system pam) | |
26 | #:use-module (guix base32) | |
27 | #:use-module (guix derivations) | |
28 | #:use-module (guix i18n) | |
d51bfe24 | 29 | #:use-module ((guix diagnostics) #:select (formatted-message)) |
12712817 JK |
30 | #:use-module (guix import json) |
31 | #:use-module (guix monads) | |
32 | #:use-module (guix records) | |
33 | #:use-module (guix ssh) | |
34 | #:use-module (guix store) | |
35 | #:use-module (ice-9 iconv) | |
36 | #:use-module (json) | |
37 | #:use-module (rnrs bytevectors) | |
38 | #:use-module (srfi srfi-1) | |
39 | #:use-module (srfi srfi-2) | |
40 | #:use-module (srfi srfi-34) | |
41 | #:use-module (srfi srfi-35) | |
42 | #:use-module (ssh key) | |
43 | #:use-module (ssh sftp) | |
44 | #:use-module (ssh shell) | |
45 | #:use-module (web client) | |
46 | #:use-module (web request) | |
47 | #:use-module (web response) | |
48 | #:use-module (web uri) | |
49 | #:export (digital-ocean-configuration | |
50 | digital-ocean-configuration? | |
51 | ||
52 | digital-ocean-configuration-ssh-key | |
53 | digital-ocean-configuration-tags | |
54 | digital-ocean-configuration-region | |
55 | digital-ocean-configuration-size | |
c93994b5 | 56 | digital-ocean-configuration-enable-ipv6? |
12712817 JK |
57 | |
58 | digital-ocean-environment-type)) | |
59 | ||
60 | ;;; Commentary: | |
61 | ;;; | |
62 | ;;; This module implements a high-level interface for provisioning "droplets" | |
63 | ;;; from the Digital Ocean virtual private server (VPS) service. | |
64 | ;;; | |
65 | ;;; Code: | |
66 | ||
67 | (define %api-base "https://api.digitalocean.com") | |
68 | ||
69 | (define %digital-ocean-token | |
70 | (make-parameter (getenv "GUIX_DIGITAL_OCEAN_TOKEN"))) | |
71 | ||
72 | (define* (post-endpoint endpoint body) | |
73 | "Encode BODY as JSON and send it to the Digital Ocean API endpoint | |
74 | ENDPOINT. This procedure is quite a bit more specialized than 'http-post', as | |
75 | it takes care to set headers such as 'Content-Type', 'Content-Length', and | |
76 | 'Authorization' appropriately." | |
77 | (let* ((uri (string->uri (string-append %api-base endpoint))) | |
78 | (body (string->bytevector (scm->json-string body) "UTF-8")) | |
79 | (headers `((User-Agent . "Guix Deploy") | |
80 | (Accept . "application/json") | |
81 | (Content-Type . "application/json") | |
82 | (Authorization . ,(format #f "Bearer ~a" | |
83 | (%digital-ocean-token))) | |
84 | (Content-Length . ,(number->string | |
85 | (bytevector-length body))))) | |
86 | (port (open-socket-for-uri uri)) | |
87 | (request (build-request uri | |
88 | #:method 'POST | |
89 | #:version '(1 . 1) | |
90 | #:headers headers | |
91 | #:port port)) | |
92 | (request (write-request request port))) | |
93 | (write-request-body request body) | |
94 | (force-output (request-port request)) | |
95 | (let* ((response (read-response port)) | |
96 | (body (read-response-body response))) | |
97 | (unless (= 2 (floor/ (response-code response) 100)) | |
98 | (raise | |
99 | (condition (&message | |
100 | (message (format | |
101 | #f | |
102 | (G_ "~a: HTTP post failed: ~a (~s)") | |
103 | (uri->string uri) | |
104 | (response-code response) | |
105 | (response-reason-phrase response))))))) | |
106 | (close-port port) | |
107 | (bytevector->string body "UTF-8")))) | |
108 | ||
109 | (define (fetch-endpoint endpoint) | |
110 | "Return the contents of the Digital Ocean API endpoint ENDPOINT as an | |
111 | alist. This procedure is quite a bit more specialized than 'json-fetch', as it | |
112 | takes care to set headers such as 'Accept' and 'Authorization' appropriately." | |
113 | (define headers | |
114 | `((user-agent . "Guix Deploy") | |
115 | (Accept . "application/json") | |
116 | (Authorization . ,(format #f "Bearer ~a" (%digital-ocean-token))))) | |
117 | (json-fetch (string-append %api-base endpoint) #:headers headers)) | |
118 | ||
119 | \f | |
120 | ;;; | |
121 | ;;; Parameters for droplet creation. | |
122 | ;;; | |
123 | ||
124 | (define-record-type* <digital-ocean-configuration> digital-ocean-configuration | |
125 | make-digital-ocean-configuration | |
126 | digital-ocean-configuration? | |
127 | this-digital-ocean-configuration | |
128 | (ssh-key digital-ocean-configuration-ssh-key) ; string | |
129 | (tags digital-ocean-configuration-tags) ; list of strings | |
130 | (region digital-ocean-configuration-region) ; string | |
131 | (size digital-ocean-configuration-size) ; string | |
c93994b5 | 132 | (enable-ipv6? digital-ocean-configuration-enable-ipv6?)) ; boolean |
12712817 JK |
133 | |
134 | (define (read-key-fingerprint file-name) | |
135 | "Read the private key at FILE-NAME and return the key's fingerprint as a hex | |
136 | string." | |
137 | (let* ((privkey (private-key-from-file file-name)) | |
138 | (pubkey (private-key->public-key privkey)) | |
139 | (hash (get-public-key-hash pubkey 'md5))) | |
140 | (bytevector->hex-string hash))) | |
141 | ||
142 | (define (machine-droplet machine) | |
143 | "Return an alist describing the droplet allocated to MACHINE." | |
144 | (let ((tags (digital-ocean-configuration-tags | |
145 | (machine-configuration machine)))) | |
146 | (find (lambda (droplet) | |
147 | (equal? (assoc-ref droplet "tags") (list->vector tags))) | |
148 | (vector->list | |
149 | (assoc-ref (fetch-endpoint "/v2/droplets") "droplets"))))) | |
150 | ||
151 | (define (machine-public-ipv4-network machine) | |
152 | "Return the public IPv4 network interface of the droplet allocated to | |
153 | MACHINE as an alist. The expected fields are 'ip_address', 'netmask', and | |
154 | 'gateway'." | |
155 | (and-let* ((droplet (machine-droplet machine)) | |
156 | (networks (assoc-ref droplet "networks")) | |
157 | (network (find (lambda (network) | |
158 | (string= "public" (assoc-ref network "type"))) | |
159 | (vector->list (assoc-ref networks "v4"))))) | |
160 | network)) | |
161 | ||
162 | \f | |
163 | ;;; | |
164 | ;;; Remote evaluation. | |
165 | ;;; | |
166 | ||
167 | (define (digital-ocean-remote-eval target exp) | |
168 | "Internal implementation of 'machine-remote-eval' for MACHINE instances with | |
169 | an environment type of 'digital-ocean-environment-type'." | |
170 | (let* ((network (machine-public-ipv4-network target)) | |
171 | (address (assoc-ref network "ip_address")) | |
172 | (ssh-key (digital-ocean-configuration-ssh-key | |
173 | (machine-configuration target))) | |
174 | (delegate (machine | |
175 | (inherit target) | |
176 | (environment managed-host-environment-type) | |
177 | (configuration | |
178 | (machine-ssh-configuration | |
179 | (host-name address) | |
180 | (identity ssh-key) | |
181 | (system "x86_64-linux")))))) | |
182 | (machine-remote-eval delegate exp))) | |
183 | ||
184 | \f | |
185 | ;;; | |
186 | ;;; System deployment. | |
187 | ;;; | |
188 | ||
189 | ;; The following script was adapted from the guide available at | |
190 | ;; <https://wiki.pantherx.org/Installation-digital-ocean/>. | |
191 | (define (guix-infect network) | |
192 | "Given NETWORK, an alist describing the Droplet's public IPv4 network | |
193 | interface, return a Bash script that will install the Guix system." | |
194 | (format #f "#!/bin/bash | |
195 | ||
196 | apt-get update | |
197 | apt-get install xz-utils -y | |
198 | wget https://ftp.gnu.org/gnu/guix/guix-binary-1.0.1.x86_64-linux.tar.xz | |
199 | cd /tmp | |
200 | tar --warning=no-timestamp -xf ~~/guix-binary-1.0.1.x86_64-linux.tar.xz | |
201 | mv var/guix /var/ && mv gnu / | |
202 | mkdir -p ~~root/.config/guix | |
203 | ln -sf /var/guix/profiles/per-user/root/current-guix ~~root/.config/guix/current | |
204 | export GUIX_PROFILE=\"`echo ~~root`/.config/guix/current\" ; | |
205 | source $GUIX_PROFILE/etc/profile | |
206 | groupadd --system guixbuild | |
207 | for i in `seq -w 1 10`; do | |
208 | useradd -g guixbuild -G guixbuild \ | |
209 | -d /var/empty -s `which nologin` \ | |
210 | -c \"Guix build user $i\" --system \ | |
211 | guixbuilder$i; | |
212 | done; | |
213 | cp ~~root/.config/guix/current/lib/systemd/system/guix-daemon.service /etc/systemd/system/ | |
214 | systemctl start guix-daemon && systemctl enable guix-daemon | |
215 | mkdir -p /usr/local/bin | |
216 | cd /usr/local/bin | |
217 | ln -s /var/guix/profiles/per-user/root/current-guix/bin/guix | |
218 | mkdir -p /usr/local/share/info | |
219 | cd /usr/local/share/info | |
220 | for i in /var/guix/profiles/per-user/root/current-guix/share/info/*; do | |
221 | ln -s $i; | |
222 | done | |
223 | guix archive --authorize < ~~root/.config/guix/current/share/guix/ci.guix.gnu.org.pub | |
224 | # guix pull | |
225 | guix package -i glibc-utf8-locales | |
226 | export GUIX_LOCPATH=\"$HOME/.guix-profile/lib/locale\" | |
227 | guix package -i openssl | |
228 | cat > /etc/bootstrap-config.scm << EOF | |
229 | (use-modules (gnu)) | |
230 | (use-service-modules networking ssh) | |
231 | ||
232 | (operating-system | |
233 | (host-name \"gnu-bootstrap\") | |
234 | (timezone \"Etc/UTC\") | |
235 | (bootloader (bootloader-configuration | |
236 | (bootloader grub-bootloader) | |
237 | (target \"/dev/vda\") | |
238 | (terminal-outputs '(console)))) | |
239 | (file-systems (cons (file-system | |
240 | (mount-point \"/\") | |
241 | (device \"/dev/vda1\") | |
242 | (type \"ext4\")) | |
243 | %base-file-systems)) | |
244 | (services | |
245 | (append (list (static-networking-service \"eth0\" \"~a\" | |
246 | #:netmask \"~a\" | |
247 | #:gateway \"~a\" | |
248 | #:name-servers '(\"84.200.69.80\" \"84.200.70.40\")) | |
249 | (simple-service 'guile-load-path-in-global-env | |
250 | session-environment-service-type | |
251 | \\`((\"GUILE_LOAD_PATH\" | |
252 | . \"/run/current-system/profile/share/guile/site/2.2\") | |
253 | (\"GUILE_LOAD_COMPILED_PATH\" | |
254 | . ,(string-append \"/run/current-system/profile/lib/guile/2.2/site-ccache:\" | |
255 | \"/run/current-system/profile/share/guile/site/2.2\")))) | |
256 | (service openssh-service-type | |
257 | (openssh-configuration | |
258 | (log-level 'debug) | |
259 | (permit-root-login 'without-password)))) | |
260 | %base-services))) | |
261 | EOF | |
262 | # guix pull | |
263 | guix system build /etc/bootstrap-config.scm | |
264 | guix system reconfigure /etc/bootstrap-config.scm | |
265 | mv /etc /old-etc | |
266 | mkdir /etc | |
267 | cp -r /old-etc/{passwd,group,shadow,gshadow,mtab,guix,bootstrap-config.scm} /etc/ | |
268 | guix system reconfigure /etc/bootstrap-config.scm" | |
269 | (assoc-ref network "ip_address") | |
270 | (assoc-ref network "netmask") | |
271 | (assoc-ref network "gateway"))) | |
272 | ||
273 | (define (machine-wait-until-available machine) | |
274 | "Block until the initial Debian image has been installed on the droplet | |
275 | named DROPLET-NAME." | |
276 | (and-let* ((droplet (machine-droplet machine)) | |
277 | (droplet-id (assoc-ref droplet "id")) | |
278 | (endpoint (format #f "/v2/droplets/~a/actions" droplet-id))) | |
279 | (let loop () | |
280 | (let ((actions (assoc-ref (fetch-endpoint endpoint) "actions"))) | |
281 | (unless (every (lambda (action) | |
282 | (string= "completed" (assoc-ref action "status"))) | |
283 | (vector->list actions)) | |
284 | (sleep 5) | |
285 | (loop)))))) | |
286 | ||
287 | (define (wait-for-ssh address ssh-key) | |
288 | "Block until the an SSH session can be made as 'root' with SSH-KEY at ADDRESS." | |
289 | (let loop () | |
290 | (catch #t | |
291 | (lambda () | |
292 | (open-ssh-session address #:user "root" #:identity ssh-key)) | |
293 | (lambda args | |
294 | (sleep 5) | |
295 | (loop))))) | |
296 | ||
297 | (define (add-static-networking target network) | |
298 | "Return an <operating-system> based on TARGET with a static networking | |
299 | configuration for the public IPv4 network described by the alist NETWORK." | |
300 | (operating-system | |
301 | (inherit (machine-operating-system target)) | |
302 | (services (cons* (static-networking-service "eth0" | |
303 | (assoc-ref network "ip_address") | |
304 | #:netmask (assoc-ref network "netmask") | |
305 | #:gateway (assoc-ref network "gateway") | |
306 | #:name-servers '("84.200.69.80" "84.200.70.40")) | |
307 | (simple-service 'guile-load-path-in-global-env | |
308 | session-environment-service-type | |
309 | `(("GUILE_LOAD_PATH" | |
310 | . "/run/current-system/profile/share/guile/site/2.2") | |
311 | ("GUILE_LOAD_COMPILED_PATH" | |
312 | . ,(string-append "/run/current-system/profile/lib/guile/2.2/site-ccache:" | |
313 | "/run/current-system/profile/share/guile/site/2.2")))) | |
314 | (operating-system-user-services | |
315 | (machine-operating-system target)))))) | |
316 | ||
317 | (define (deploy-digital-ocean target) | |
318 | "Internal implementation of 'deploy-machine' for 'machine' instances with an | |
319 | environment type of 'digital-ocean-environment-type'." | |
320 | (maybe-raise-missing-api-key-error) | |
321 | (maybe-raise-unsupported-configuration-error target) | |
322 | (let* ((config (machine-configuration target)) | |
323 | (name (machine-display-name target)) | |
324 | (region (digital-ocean-configuration-region config)) | |
325 | (size (digital-ocean-configuration-size config)) | |
326 | (ssh-key (digital-ocean-configuration-ssh-key config)) | |
327 | (fingerprint (read-key-fingerprint ssh-key)) | |
c93994b5 | 328 | (enable-ipv6? (digital-ocean-configuration-enable-ipv6? config)) |
12712817 JK |
329 | (tags (digital-ocean-configuration-tags config)) |
330 | (request-body `(("name" . ,name) | |
331 | ("region" . ,region) | |
332 | ("size" . ,size) | |
333 | ("image" . "debian-9-x64") | |
334 | ("ssh_keys" . ,(vector fingerprint)) | |
335 | ("backups" . #f) | |
c93994b5 | 336 | ("ipv6" . ,enable-ipv6?) |
12712817 JK |
337 | ("user_data" . #nil) |
338 | ("private_networking" . #nil) | |
339 | ("volumes" . #nil) | |
340 | ("tags" . ,(list->vector tags)))) | |
341 | (response (post-endpoint "/v2/droplets" request-body))) | |
342 | (machine-wait-until-available target) | |
343 | (let* ((network (machine-public-ipv4-network target)) | |
344 | (address (assoc-ref network "ip_address"))) | |
345 | (wait-for-ssh address ssh-key) | |
346 | (let* ((ssh-session (open-ssh-session address #:user "root" #:identity ssh-key)) | |
347 | (sftp-session (make-sftp-session ssh-session))) | |
348 | (call-with-remote-output-file sftp-session "/tmp/guix-infect.sh" | |
349 | (lambda (port) | |
350 | (display (guix-infect network) port))) | |
351 | (rexec ssh-session "/bin/bash /tmp/guix-infect.sh") | |
352 | ;; Session will close upon rebooting, which will raise 'guile-ssh-error. | |
353 | (catch 'guile-ssh-error | |
354 | (lambda () (rexec ssh-session "reboot")) | |
355 | (lambda args #t))) | |
356 | (wait-for-ssh address ssh-key) | |
357 | (let ((delegate (machine | |
358 | (operating-system (add-static-networking target network)) | |
359 | (environment managed-host-environment-type) | |
360 | (configuration | |
361 | (machine-ssh-configuration | |
362 | (host-name address) | |
363 | (identity ssh-key) | |
364 | (system "x86_64-linux")))))) | |
365 | (deploy-machine delegate))))) | |
366 | ||
367 | \f | |
368 | ;;; | |
369 | ;;; Roll-back. | |
370 | ;;; | |
371 | ||
372 | (define (roll-back-digital-ocean target) | |
373 | "Internal implementation of 'roll-back-machine' for MACHINE instances with an | |
374 | environment type of 'digital-ocean-environment-type'." | |
375 | (let* ((network (machine-public-ipv4-network target)) | |
376 | (address (assoc-ref network "ip_address")) | |
377 | (ssh-key (digital-ocean-configuration-ssh-key | |
378 | (machine-configuration target))) | |
379 | (delegate (machine | |
380 | (inherit target) | |
381 | (environment managed-host-environment-type) | |
382 | (configuration | |
383 | (machine-ssh-configuration | |
384 | (host-name address) | |
385 | (identity ssh-key) | |
386 | (system "x86_64-linux")))))) | |
387 | (roll-back-machine delegate))) | |
388 | ||
389 | \f | |
390 | ;;; | |
391 | ;;; Environment type. | |
392 | ;;; | |
393 | ||
394 | (define digital-ocean-environment-type | |
395 | (environment-type | |
396 | (machine-remote-eval digital-ocean-remote-eval) | |
397 | (deploy-machine deploy-digital-ocean) | |
398 | (roll-back-machine roll-back-digital-ocean) | |
399 | (name 'digital-ocean-environment-type) | |
400 | (description "Provisioning of \"droplets\": virtual machines | |
401 | provided by the Digital Ocean virtual private server (VPS) service."))) | |
402 | ||
403 | ||
404 | (define (maybe-raise-missing-api-key-error) | |
405 | (unless (%digital-ocean-token) | |
406 | (raise (condition | |
407 | (&message | |
408 | (message (G_ "No Digital Ocean access token was provided. This \ | |
409 | may be fixed by setting the environment variable GUIX_DIGITAL_OCAEN_TOKEN to \ | |
410 | one procured from https://cloud.digitalocean.com/account/api/tokens."))))))) | |
411 | ||
412 | (define (maybe-raise-unsupported-configuration-error machine) | |
413 | "Raise an error if MACHINE's configuration is not an instance of | |
414 | <digital-ocean-configuration>." | |
415 | (let ((config (machine-configuration machine)) | |
416 | (environment (environment-type-name (machine-environment machine)))) | |
417 | (unless (and config (digital-ocean-configuration? config)) | |
d51bfe24 | 418 | (raise (formatted-message (G_ "unsupported machine configuration '~a' \ |
12712817 JK |
419 | for environment of type '~a'") |
420 | config | |
d51bfe24 | 421 | environment))))) |