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