;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013, 2014, 2015 Ludovic Courtès ;;; Copyright © 2015 Mark H Weaver ;;; ;;; This file is part of GNU Guix. ;;; ;;; GNU Guix is free software; you can redistribute it and/or modify it ;;; under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or (at ;;; your option) any later version. ;;; ;;; GNU Guix is distributed in the hope that it will be useful, but ;;; WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with GNU Guix. If not, see . (define-module (gnu build activation) #:use-module (gnu build linux-boot) #:use-module (guix build utils) #:use-module (ice-9 ftw)
aboutsummaryrefslogtreecommitdiff
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.org>
;;; Copyright © 2020 Brice Waegeneire <brice@waegenei.re>
;;; Copyright © 2022 Matthew James Kraai <kraai@ftbfs.org>
;;; Copyright © 2022 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gnu machine digital-ocean)
  #:use-module (gnu machine ssh)
  #:use-module (gnu machine)
  #:use-module (gnu services)
  #:use-module (gnu services base)
  #:use-module (gnu services networking)
  #:use-module (gnu system)
  #:use-module (gnu system pam)
  #:use-module (guix base32)
  #:use-module (guix derivations)
  #:use-module (guix i18n)
  #:use-module ((guix diagnostics) #:select (formatted-message))
  #:use-module (guix import json)
  #:use-module (guix monads)
  #:use-module (guix records)
  #:use-module (guix ssh)
  #:use-module (guix store)
  #:use-module (ice-9 format)
  #:use-module (ice-9 iconv)
  #:use-module (ice-9 string-fun)
  #:use-module (json)
  #:use-module (rnrs bytevectors)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-2)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (ssh key)
  #:use-module (ssh sftp)
  #:use-module (ssh shell)
  #:use-module (web client)
  #:use-module (web request)
  #:use-module (web response)
  #:use-module (web uri)
  #:export (digital-ocean-configuration
            digital-ocean-configuration?

            digital-ocean-configuration-ssh-key
            digital-ocean-configuration-tags
            digital-ocean-configuration-region
            digital-ocean-configuration-size
            digital-ocean-configuration-enable-ipv6?

            digital-ocean-environment-type))

;;; Commentary:
;;;
;;; This module implements a high-level interface for provisioning "droplets"
;;; from the Digital Ocean virtual private server (VPS) service.
;;;
;;; Code:

(define %api-base "https://api.digitalocean.com")

(define %digital-ocean-token
  (make-parameter (getenv "GUIX_DIGITAL_OCEAN_TOKEN")))

(define* (post-endpoint endpoint body)
  "Encode BODY as JSON and send it to the Digital Ocean API endpoint
ENDPOINT. This procedure is quite a bit more specialized than 'http-post', as
it takes care to set headers such as 'Content-Type', 'Content-Length', and
'Authorization' appropriately."
  (let* ((uri (string->uri (string-append %api-base endpoint)))
         (body (string->bytevector (scm->json-string body) "UTF-8"))
         (headers `((User-Agent . "Guix Deploy")
                    (Accept . "application/json")
                    (Content-Type . "application/json")
                    (Authorization . ,(format #f "Bearer ~a"
                                              (%digital-ocean-token)))
                    (Content-Length . ,(number->string
                                        (bytevector-length body)))))
         (port (open-socket-for-uri uri))
         (request (build-request uri
                                 #:method 'POST
                                 #:version '(1 . 1)
                                 #:headers headers
                                 #:port port))
         (request (write-request request port)))
    (write-request-body request body)
    (force-output (request-port request))
    (let* ((response (read-response port))
           (body (read-response-body response)))
      (unless (= 2 (floor/ (response-code response) 100))
        (raise
         (condition (&message
                     (message (format
                               #f
                               (G_ "~a: HTTP post failed: ~a (~s)")
                               (uri->string uri)
                               (response-code response)
                               (response-reason-phrase response)))))))
      (close-port port)
      (bytevector->string body "UTF-8"))))

(define (fetch-endpoint endpoint)
  "Return the contents of the Digital Ocean API endpoint ENDPOINT as an
alist. This procedure is quite a bit more specialized than 'json-fetch', as it
takes care to set headers such as 'Accept' and 'Authorization' appropriately."
  (define headers
    `((user-agent . "Guix Deploy")
      (Accept . "application/json")
      (Authorization . ,(format #f "Bearer ~a" (%digital-ocean-token)))))
  (json-fetch (string-append %api-base endpoint) #:headers headers))


;;;
;;; Parameters for droplet creation.
;;;

(define-record-type* <digital-ocean-configuration> digital-ocean-configuration
  make-digital-ocean-configuration
  digital-ocean-configuration?
  this-digital-ocean-configuration
  (ssh-key     digital-ocean-configuration-ssh-key)      ; string
  (tags        digital-ocean-configuration-tags)         ; list of strings
  (region      digital-ocean-configuration-region)       ; string
  (size        digital-ocean-configuration-size)         ; string
  (enable-ipv6? digital-ocean-configuration-enable-ipv6?)) ; boolean

(define (read-key-fingerprint file-name)
  "Read the private key at FILE-NAME and return the key's fingerprint as a hex
string."
  (let* ((privkey (private-key-from-file file-name))
         (pubkey (private-key->public-key privkey))
         (hash (get-public-key-hash pubkey 'md5)))
    (bytevector->hex-string hash)))

(define (machine-droplet machine)
  "Return an alist describing the droplet allocated to MACHINE."
  (let ((tags (digital-ocean-configuration-tags
               (machine-configuration machine))))
    (find (lambda (droplet)
            (equal? (assoc-ref droplet "tags") (list->vector tags)))
          (vector->list
           (assoc-ref (fetch-endpoint "/v2/droplets") "droplets")))))

(define (machine-public-ipv4-network machine)
  "Return the public IPv4 network interface of the droplet allocated to
MACHINE as an alist. The expected fields are 'ip_address', 'netmask', and
'gateway'."
  (and-let* ((droplet (machine-droplet machine))
             (networks (assoc-ref droplet "networks"))
             (network (find (lambda (network)
                              (string= "public" (assoc-ref network "type")))
                            (vector->list (assoc-ref networks "v4")))))
    network))


;;;
;;; Remote evaluation.
;;;

(define (digital-ocean-remote-eval target exp)
  "Internal implementation of 'machine-remote-eval' for MACHINE instances with
an environment type of 'digital-ocean-environment-type'."
  (let* ((network (machine-public-ipv4-network target))
         (address (assoc-ref network "ip_address"))
         (ssh-key (digital-ocean-configuration-ssh-key
                   (machine-configuration target)))
         (delegate (machine
                    (inherit target)
                    (environment managed-host-environment-type)
                    (configuration
                     (machine-ssh-configuration
                      (host-name address)
                      (identity ssh-key)
                      (system "x86_64-linux"))))))
    (machine-remote-eval delegate exp)))


;;;
;;; System deployment.
;;;

;; XXX Copied from (gnu services base)
(define* (ip+netmask->cidr ip netmask #:optional (family AF_INET))
  "Return the CIDR notation (a string) for @var{ip} and @var{netmask}, two
@var{family} address strings, where @var{family} is @code{AF_INET} or
@code{AF_INET6}."
  (let* ((netmask (inet-pton family netmask))
         (bits    (logcount netmask)))
    (string-append ip "/" (number->string bits))))

;; The following script was adapted from the guide available at
;; <https://wiki.pantherx.org/Installation-digital-ocean/>.
(define (guix-infect network)
  "Given NETWORK, an alist describing the Droplet's public IPv4 network
interface, return a Bash script that will install the Guix system."
  (define os
    `(operating-system
       (host-name "gnu-bootstrap")
       (timezone "Etc/UTC")
       (bootloader (bootloader-configuration
                    (bootloader grub-bootloader)
                    (targets '("/dev/vda"))
                    (terminal-outputs '(console))))
       (file-systems (cons (file-system
                             (mount-point "/")
                             (device "/dev/vda1")
                             (type "ext4"))
                           %base-file-systems))
       (services
        (append (list (service static-networking-service-type
                               (list (static-networking
                                      (addresses
                                       (list (network-address
                                              (device "eth0")
                                              (value ,(ip+netmask->cidr
                                                       (assoc-ref network "ip_address")
                                                       (assoc-ref network "netmask"))))))
                                      (routes
                                       (list (network-route
                                              (destination "default")
                                              (gateway ,(assoc-ref network "gateway")))))
                                      (name-servers '("84.200.69.80" "84.200.70.40")))))
                      (simple-service 'guile-load-path-in-global-env
                                      session-environment-service-type
                                      `(("GUILE_LOAD_PATH"
                                         . "/run/current-system/profile/share/guile/site/3.0")
                                        ("GUILE_LOAD_COMPILED_PATH"
                                         . ,(string-append "/run/current-system/profile/lib/guile/3.0/site-ccache:"
                                                           "/run/current-system/profile/share/guile/site/3.0"))))
                      (service openssh-service-type
                               (openssh-configuration
                                (log-level 'debug)
                                (permit-root-login 'prohibit-password))))
            %base-services))))
  (format #f "#!/bin/bash

apt-get update
apt-get install xz-utils -y
wget -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
cd /tmp
tar --warning=no-timestamp -xf ~~/guix-binary-nightly.x86_64-linux.tar.xz
mv var/guix /var/ && mv gnu /
mkdir -p ~~root/.config/guix
ln -sf /var/guix/profiles/per-user/root/current-guix ~~root/.config/guix/current
export GUIX_PROFILE=\"`echo ~~root`/.config/guix/current\" ;
source $GUIX_PROFILE/etc/profile
groupadd --system guixbuild
for i in `seq -w 1 10`; do
   useradd -g guixbuild -G guixbuild         \
           -d /var/empty -s `which nologin`  \
           -c \"Guix build user $i\" --system  \
           guixbuilder$i;
done;
cp ~~root/.config/guix/current/lib/systemd/system/guix-daemon.service /etc/systemd/system/
systemctl start guix-daemon && systemctl enable guix-daemon
mkdir -p /usr/local/bin
cd /usr/local/bin
ln -s /var/guix/profiles/per-user/root/current-guix/bin/guix
mkdir -p /usr/local/share/info
cd /usr/local/share/info
for i in /var/guix/profiles/per-user/root/current-guix/share/info/*; do
    ln -s $i;
done
guix archive --authorize < ~~root/.config/guix/current/share/guix/ci.guix.gnu.org.pub
# guix pull
guix package -i glibc-utf8-locales
export GUIX_LOCPATH=\"$HOME/.guix-profile/lib/locale\"
guix package -i openssl
cat > /etc/bootstrap-config.scm << EOF
(use-modules (gnu))
(use-service-modules base networking ssh)

~a
EOF
# guix pull
guix system build /etc/bootstrap-config.scm
guix system reconfigure /etc/bootstrap-config.scm
mv /etc /old-etc
mkdir /etc
cp -r /old-etc/{passwd,group,shadow,gshadow,mtab,guix,bootstrap-config.scm} /etc/
guix system reconfigure /etc/bootstrap-config.scm"
          ;; Escape the bare backtick to avoid having it interpreted by Bash.
          (string-replace-substring
           (format #f "~y" os) "`" "\\`")))

(define (machine-wait-until-available machine)
  "Block until the initial Debian image has been installed on the droplet
named DROPLET-NAME."
  (and-let* ((droplet (machine-droplet machine))
             (droplet-id (assoc-ref droplet "id"))
             (endpoint (format #f "/v2/droplets/~a/actions" droplet-id)))
    (let loop ()
      (let ((actions (assoc-ref (fetch-endpoint endpoint) "actions")))
        (unless (every (lambda (action)