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 diagnostics) #:select (formatted-message))
  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
  56             digital-ocean-configuration-enable-ipv6?
  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
 132   (enable-ipv6? digital-ocean-configuration-enable-ipv6?)) ; boolean
 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))
 328          (enable-ipv6? (digital-ocean-configuration-enable-ipv6? config))
 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)
 336                          ("ipv6" . ,enable-ipv6?)
 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))
 418       (raise (formatted-message (G_ "unsupported machine configuration '~a' \
 419 for environment of type '~a'")
 420                                 config
 421                                 environment)))))