gnu/machine/digital-ocean.scm

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