gnu/machine/digital-ocean.scm

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