projects/guix·blob java-team · refs

455 lines · 19.6 KiB

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