From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mp1.migadu.com ([2001:41d0:403:4876::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by ms13.migadu.com with LMTPS id +AtOIb3hbmdmiAAA62LTzQ:P1 (envelope-from ) for ; Fri, 27 Dec 2024 17:19:57 +0000 Received: from aspmx1.migadu.com ([2001:41d0:403:4876::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by mp1.migadu.com with LMTPS id +AtOIb3hbmdmiAAA62LTzQ (envelope-from ) for ; Fri, 27 Dec 2024 18:19:57 +0100 X-Envelope-To: larch@yhetil.org Authentication-Results: aspmx1.migadu.com; dkim=fail ("body hash did not verify") header.d=debbugs.gnu.org header.s=debbugs-gnu-org header.b=cBHT4Vg8; dkim=fail ("body hash did not verify") header.d=burningswell-com.20230601.gappssmtp.com header.s=20230601 header.b=I4MPWfC9; spf=pass (aspmx1.migadu.com: domain of "guix-patches-bounces+larch=yhetil.org@gnu.org" designates 209.51.188.17 as permitted sender) smtp.mailfrom="guix-patches-bounces+larch=yhetil.org@gnu.org"; dmarc=none ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=yhetil.org; s=key1; t=1735319997; h=from:from:sender:sender:reply-to:subject:subject:date:date: message-id:message-id:to:to:cc:cc:mime-version:mime-version: content-type:content-type: content-transfer-encoding:content-transfer-encoding:resent-cc: resent-from:resent-sender:resent-message-id:list-id:list-help: list-unsubscribe:list-subscribe:list-post:dkim-signature; bh=TCvhZi+pdsa0pCg3w62Z9LxQxoIq9tRViT1p2hv7Y/U=; b=bWFekRVxcTaD1c8KIPGYQAFOU6qO1sb5LDixSY60SumK29fFWJqu4nx9DLmRZaE4oU4FOx OOVdmAqF1a4rpeZ0EENHcoSHPrZV31X7ize/BI8eHEONcGXvC9q0fJzyGA57Rey+yiKHSN QFeUnbb1mG4qZzvtnNj/icIqOlK29LO8syJ8KWcANILi9dXMEEaJ6vypC2Egylp+w2lce8 loICXbT5MGAqcOiVflQdpNJsQ2ZCOCJw/0pVuVkzsqABlEorPIibLAhSjCg+iSrP/W3viy RMunW21tIjcQU0G9GvacP1SrVHZRcVeUdDKGEhMe8nqG4XjljUGa0Kwmaqx/2w== ARC-Authentication-Results: i=1; aspmx1.migadu.com; dkim=fail ("body hash did not verify") header.d=debbugs.gnu.org header.s=debbugs-gnu-org header.b=cBHT4Vg8; dkim=fail ("body hash did not verify") header.d=burningswell-com.20230601.gappssmtp.com header.s=20230601 header.b=I4MPWfC9; spf=pass (aspmx1.migadu.com: domain of "guix-patches-bounces+larch=yhetil.org@gnu.org" designates 209.51.188.17 as permitted sender) smtp.mailfrom="guix-patches-bounces+larch=yhetil.org@gnu.org"; dmarc=none ARC-Seal: i=1; s=key1; d=yhetil.org; t=1735319997; a=rsa-sha256; cv=none; b=jbjDjQCfdIaGFtrqWZtVyBQy0vIkmRNEq2dc+WrNa9Wk4A9LhOCHhSDVzsY9+BW1exj9xD zqEkT8ue6rH4cr4pWOj64pGkLwZv4MpSFSJ4YV7+TS4JsrYIm0yDx1zMzwtlAIHSuSA2oY tBos4mk3cRPOPbASPlvryk0oM+T/99mqxbW8nOzxEGcu6HpNihW2l5x6VMsvQo2dmmxpwj gVSRaqmVdXOeG/vOmQTP8klpPjypR7uKLB/VW4G9M9cntP0y9A9cIdBMykswtwtjU9IGSP xAv1PsbNyxV/hFy7mP58blJhqOSTOVWG/nwsfEIZ6aaq+bnghpEMmxyg1EYbow== Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by aspmx1.migadu.com (Postfix) with ESMTPS id B29CB18450 for ; Fri, 27 Dec 2024 18:19:56 +0100 (CET) Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1tRDVd-0005Mm-PZ; Fri, 27 Dec 2024 11:48:23 -0500 Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1tRDVQ-0005MK-Np for guix-patches@gnu.org; Fri, 27 Dec 2024 11:48:10 -0500 Received: from debbugs.gnu.org ([2001:470:142:5::43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1tRDVP-0002aC-Ic; Fri, 27 Dec 2024 11:48:07 -0500 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=debbugs.gnu.org; s=debbugs-gnu-org; h=MIME-Version:Date:From:To:Subject; bh=7+sWoUbKfgSUMdkmLNjUro1GQ0UinS/SjG9tUf/MDMY=; b=cBHT4Vg8WK9zSbhh2BF3M8KcKVxNenTv68LzdGIQzJ0p1nUlM6bIOddGh5629iEbZSP/HAF0iK6mSpLLn86bH9WiNW/n9IwQ4/gZIe/Emw8G2LFPef2zEqcWqcscpWASoJ4xn4WDNSr2RS8lpSr8NJyVsIX0Xk3kUcVi20oRuouthcyusezCcXL5Y450nbStZQZ0PEtXPgTous6c1tWxglGTAo/5hEn/UiKO5aQT/nS18K5imWVDeMET85JQKbg37b/VwiaeRz0SyAxkXJVW95RYwrHKE5jo7YBLTrC6X53Lsm/tWvr+2seZ5QlROxkLsTIRUfaOzBv4mNhukJIVzw==; Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1tRDVK-0003Gz-KC; Fri, 27 Dec 2024 11:48:02 -0500 X-Loop: help-debbugs@gnu.org Subject: [bug#75144] [PATCH] machine: Implement 'hetzner-environment-type'. Resent-From: Roman Scherer Original-Sender: "Debbugs-submit" Resent-CC: guix@cbaines.net, dev@jpoiret.xyz, ludo@gnu.org, othacehe@gnu.org, maxim.cournoyer@gmail.com, zimon.toutoune@gmail.com, me@tobias.gr, guix-patches@gnu.org Resent-Date: Fri, 27 Dec 2024 16:48:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: report 75144 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 75144@debbugs.gnu.org Cc: Roman Scherer , Christopher Baines , Josselin Poiret , Ludovic Court?s , Mathieu Othacehe , Maxim Cournoyer , Simon Tournier , Tobias Geerinckx-Rice X-Debbugs-Original-To: guix-patches@gnu.org X-Debbugs-Original-Xcc: Christopher Baines , Josselin Poiret , Ludovic Court?s , Mathieu Othacehe , Maxim Cournoyer , Simon Tournier , Tobias Geerinckx-Rice Received: via spool by submit@debbugs.gnu.org id=B.173531802612495 (code B ref -1); Fri, 27 Dec 2024 16:48:02 +0000 Received: (at submit) by debbugs.gnu.org; 27 Dec 2024 16:47:06 +0000 Received: from localhost ([127.0.0.1]:47356 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1tRDUO-0003FR-9Z for submit@debbugs.gnu.org; Fri, 27 Dec 2024 11:47:06 -0500 Received: from lists.gnu.org ([209.51.188.17]:38100) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1tRDUJ-0003Ex-8X for submit@debbugs.gnu.org; Fri, 27 Dec 2024 11:47:01 -0500 Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1tRDUE-0005He-N5 for guix-patches@gnu.org; Fri, 27 Dec 2024 11:46:57 -0500 Received: from mail-ej1-x62b.google.com ([2a00:1450:4864:20::62b]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1tRDU9-0002UJ-6g for guix-patches@gnu.org; Fri, 27 Dec 2024 11:46:53 -0500 Received: by mail-ej1-x62b.google.com with SMTP id a640c23a62f3a-aaef00ab172so485974466b.3 for ; Fri, 27 Dec 2024 08:46:47 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=burningswell-com.20230601.gappssmtp.com; s=20230601; t=1735318006; x=1735922806; darn=gnu.org; h=content-transfer-encoding:mime-version:message-id:date:subject:cc :to:from:from:to:cc:subject:date:message-id:reply-to; bh=7+sWoUbKfgSUMdkmLNjUro1GQ0UinS/SjG9tUf/MDMY=; b=I4MPWfC9mf4v/2Hh5ltjItBrX93ELH+WO8OAFeu/oz7rlHgvvvGDnXwn344y9TzBB5 jTtaJWZAnQX9//yxsRWuDTnq5Asf2q+yHR3iV08uC0nWh50MWX1//ImPwB20i9Mo7Dfx t6JQuWLf04IWg2LT/yDiFQKfv61vgIdiQRCYPHw8m2wUYpo1AHRYEGTHTrl/X65qxL+x yiEcHgS0R5Wf0FEr0IPEhTGNum3eM3Idu2Agngd62RV7ymjh5lCcx7k/fCXQCpthSeGg tCtr4gPsdYpkMURQdGFH+YWaupYFQnSQdusClOiUKj39D0J8/Q7OhVzNwQXzVonmW8+z wXCg== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1735318006; x=1735922806; h=content-transfer-encoding:mime-version:message-id:date:subject:cc :to:from:x-gm-message-state:from:to:cc:subject:date:message-id :reply-to; bh=7+sWoUbKfgSUMdkmLNjUro1GQ0UinS/SjG9tUf/MDMY=; b=nBS4XCztvjlhEW8Z60IwZAz4ccnK4+u7OkX4hnfzjOTIQhY7xp5RsW5voMWpW5WAcT 9YLk4oEV63+GVXLRDdaq/CjyEFYfZVjp7zvHOailgVWORTpx/hsGN2rV3bqfPKxcyShp Y8Oa/DYLHURbc2OyJwQvm/uNbuOSb6v31RD5WsTlF0FHCygmXCDd2dpEUC0zqmYlvu6z pKaXnoRPCi4N7ygLxVHLmuKxBlJzm9v4gN+m84HWeSXVAd9AaYQqYLJnntQYOXL4pELf 08/WCVI8g2j8wpqJTSFjmub8pjy7776NcqrwXMP/9+gnvLpl6OCzDI5ZZczPpYCKVeS0 lYaw== X-Gm-Message-State: AOJu0YzedxX9OpWAiCXHv7n7qIMyb47RMavGY4xrDt18YOOwxgsvXQ8Z peJVTGz4r+s0EcXn1Ofbw4yb7VP9sAR00HbuZNt/CJQ2/La3AXTNUtgGmlexfVh6K+e4lWVELmb l X-Gm-Gg: ASbGncusM98YYknK3etXzw8VTfgAgKQstwDyGkoTIBJm/sglcYE9upRUgReTle3RAIX 7FBuLHhy805XQ7X6HzWg5Vbqdh4hl1h/PMkgQsZSe0yqT+LeqNmazeTdgpURHXin0sES4j24x++ d+KUPuXqZerd+jDNlqJiUaMBkZqRq7ixat4TMmZ1P/4ZbXKObSrAQp9mA1iZwS3Gl1NVD0rFz+J Fs55ImPBnArpmGzKLiMiehnq++W+UjkELfuMbTDsV1gs6VzXLdAn0xaohQEsUuq9+e8oWrkTb53 fwAz415PeysWpnNQzUoUf44XJKv2RHpouslDL06RLn25yjE= X-Google-Smtp-Source: AGHT+IE9a6V6Mv1XOfjm2IvyknT7N6OIEtUyPbytCAy9+igIEM8+iRHpaMr5Fycto16ueviAtp6Aqg== X-Received: by 2002:a05:6402:40c9:b0:5d1:1064:326a with SMTP id 4fb4d7f45d1cf-5d81ddbf672mr61090814a12.15.1735318005407; Fri, 27 Dec 2024 08:46:45 -0800 (PST) Received: from m1.fritz.box (p200300c62f07fc003c43ee08cfef04e1.dip0.t-ipconnect.de. [2003:c6:2f07:fc00:3c43:ee08:cfef:4e1]) by smtp.gmail.com with ESMTPSA id 4fb4d7f45d1cf-5d806fedbc5sm11336142a12.60.2024.12.27.08.46.44 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Fri, 27 Dec 2024 08:46:44 -0800 (PST) From: Roman Scherer Date: Fri, 27 Dec 2024 17:46:39 +0100 Message-ID: <6ff52cb81582c81835e39beebc7e6f7f3ecfd81d.1735317980.git.roman@burningswell.com> X-Mailer: git-send-email 2.47.1 MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Received-SPF: none client-ip=2a00:1450:4864:20::62b; envelope-from=roman@burningswell.com; helo=mail-ej1-x62b.google.com X-Spam_score_int: -18 X-Spam_score: -1.9 X-Spam_bar: - X-Spam_report: (-1.9 / 5.0 requ) BAYES_00=-1.9, DKIM_SIGNED=0.1, DKIM_VALID=-0.1, RCVD_IN_DNSWL_NONE=-0.0001, SPF_HELO_NONE=0.001, SPF_NONE=0.001 autolearn=ham autolearn_force=no X-Spam_action: no action X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+larch=yhetil.org@gnu.org Sender: guix-patches-bounces+larch=yhetil.org@gnu.org X-Migadu-Country: US X-Migadu-Flow: FLOW_IN X-Migadu-Spam-Score: 0.10 X-Spam-Score: 0.10 X-Migadu-Queue-Id: B29CB18450 X-Migadu-Scanner: mx10.migadu.com X-TUID: nUYVsfjBXqyy * gnu/machine/hetzner.scm: New file. * gnu/local.mk (GNU_SYSTEM_MODULES): Add it. * guix/ssh.scm (open-ssh-session): Add stricthostkeycheck option. * doc/guix.texi (Invoking guix deploy): Add documentation for 'hetzner-configuration'. Change-Id: Idc17dbc33279ecbf3cbfe2c53d7699140f8b9f41 --- doc/guix.texi | 86 ++++ gnu/local.mk | 1 + gnu/machine/hetzner.scm | 1039 +++++++++++++++++++++++++++++++++++++++ guix/ssh.scm | 19 +- 4 files changed, 1137 insertions(+), 8 deletions(-) create mode 100644 gnu/machine/hetzner.scm diff --git a/doc/guix.texi b/doc/guix.texi index da4d2f5ebc..020f460327 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -44399,6 +44399,92 @@ Invoking guix deploy @end table @end deftp +@deftp {Data Type} hetzner-configuration +This is the data type describing the server that should be created for a +machine with an @code{environment} of @code{hetzner-environment-type}. + +@table @asis +@item @code{allow-downgrades?} (default: @code{#f}) +Whether to allow potential downgrades. +@item @code{authorize?} (default: @code{#t}) +If true, the coordinator's public signing key +@code{"/etc/guix/signing-key.pub"} will be added to the server's ACL +keyring. +@item @code{build-locally?} (default: @code{#t}) +If false, system derivations will be built on the machine being deployed to. +@item @code{delete?} (default: @code{#t}) +If true, the server will be deleted when an error happens in the +provisioning phase. If false, the server will be kept in order to debug +any issues. +@item @code{enable-ipv6?} (default: @code{#t}) +If true, attach an IPv6 on the public NIC. If false, no IPv6 address will be attached. +@item @code{labels} (default: @code{'()}) +A user defined alist of key/value pairs attached to the server. Keys and +values must be strings. For more information, see +@uref{https://docs.hetzner.cloud/#labels, Labels}. +@item @code{location} (default: @code{"fsn1"}) +The name of a @uref{https://docs.hetzner.com/cloud/general/locations, +location} to create the server in. +@item @code{cleanup} (default: @code{#t}) +Whether to delete the Hetzner server if provisioning fails or not. +@item @code{server-type} (default: @code{"cx42"}) +The name of the +@uref{https://docs.hetzner.com/cloud/servers/overview#server-types, +server type} this server should be created with. +@item @code{ssh-key} +The path to the SSH private key to use to authenticate with the remote +host. +@end table + +When deploying a machine with the @code{hetzner-environment-type} a +virtual private server (VPS) is created for it on the +@uref{https://www.hetzner.com/cloud, Hetzner Cloud} service. The server +is first booted into the +@uref{https://docs.hetzner.com/cloud/servers/getting-started/rescue-system, +Rescue System} to setup the partitions of the server and install a +minimal Guix system, which is then used with the +@code{managed-host-environment-type} to complete the deployment. + +Servers on the Hetzner Cloud service can be provisioned on the +@code{aarch64} architecture using UEFI boot mode, or on the +@code{x86_64} architecture using BIOS boot mode. The @code{(gnu machine +hetzner)} module exports the @code{%hetzner-os-arm} and +@code{%hetzner-os-x86} operating systems that are compatible with those +2 architectures, and can be used as a base for defining your custom +operating system. + +The following example shows the definition of 2 machines that are +deployed on the Hetzner Cloud service. The first one uses the +@code{%hetzner-os-arm} operating system to run a server with 16 shared +vCPUs and 32 GB of RAM on the @code{aarch64} architecture, the second +one uses the @code{%hetzner-os-x86} operating system on a server with 16 +shared vCPUs and 32 GB of RAM on the @code{x86_64} architecture. + +@lisp +(use-modules (gnu machine) + (gnu machine hetzner)) + +(list (machine + (operating-system %hetzner-os-arm) + (environment hetzner-environment-type) + (configuration (hetzner-configuration + (server-type "cax41") + (ssh-key "/home/charlie/.ssh/id_rsa")))) + (machine + (operating-system %hetzner-os-x86) + (environment hetzner-environment-type) + (configuration (hetzner-configuration + (server-type "cpx51") + (ssh-key "/home/charlie/.ssh/id_rsa"))))) +@end lisp + +Passing this file to @command{guix deploy} with the environment variable +@env{GUIX_HETZNER_API_TOKEN} set to a valid Hetzner +@uref{https://docs.hetzner.com/cloud/api/getting-started/generating-api-token, +API key} should provision 2 machines for you. + +@end deftp + @node Running Guix in a VM @section Running Guix in a Virtual Machine diff --git a/gnu/local.mk b/gnu/local.mk index 84160f407a..98000766af 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -911,6 +911,7 @@ if HAVE_GUILE_SSH GNU_SYSTEM_MODULES += \ %D%/machine/digital-ocean.scm \ + %D%/machine/hetzner.scm \ %D%/machine/ssh.scm endif HAVE_GUILE_SSH diff --git a/gnu/machine/hetzner.scm b/gnu/machine/hetzner.scm new file mode 100644 index 0000000000..9f8c3806b3 --- /dev/null +++ b/gnu/machine/hetzner.scm @@ -0,0 +1,1039 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2024 Roman Scherer +;;; +;;; 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 machine hetzner) + #:use-module (gnu bootloader grub) + #:use-module (gnu bootloader) + #:use-module (gnu machine ssh) + #:use-module (gnu machine) + #:use-module (gnu packages ssh) + #:use-module (gnu services base) + #:use-module (gnu services networking) + #:use-module (gnu services ssh) + #:use-module (gnu services) + #:use-module (gnu system file-systems) + #:use-module (gnu system image) + #:use-module (gnu system linux-initrd) + #:use-module (gnu system pam) + #:use-module (gnu system) + #:use-module (guix base32) + #:use-module (guix colors) + #:use-module (guix derivations) + #:use-module (guix diagnostics) + #:use-module (guix gexp) + #:use-module (guix i18n) + #:use-module (guix import json) + #:use-module (guix monads) + #:use-module (guix packages) + #:use-module (guix pki) + #: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 match) + #:use-module (ice-9 popen) + #:use-module (ice-9 pretty-print) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 receive) + #:use-module (ice-9 string-fun) + #:use-module (ice-9 textual-ports) + #: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 channel) + #:use-module (ssh key) + #:use-module (ssh popen) + #:use-module (ssh session) + #: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 (%hetzner-os-arm + %hetzner-os-x86 + deploy-hetzner + hetzner-api + hetzner-api-auth-token + hetzner-api-base-url + hetzner-configuration + hetzner-configuration-allow-downgrades? + hetzner-configuration-authorize? + hetzner-configuration-build-locally? + hetzner-configuration-delete? + hetzner-configuration-enable-ipv6? + hetzner-configuration-labels + hetzner-configuration-location + hetzner-configuration-networks + hetzner-configuration-server-type + hetzner-configuration-ssh-key + hetzner-configuration? + hetzner-environment-type)) + +;;; Commentary: +;;; +;;; This module implements a high-level interface for provisioning "servers" +;;; from the Hetzner Cloud service. +;;; + +(define %hetzner-api-token + (make-parameter (getenv "GUIX_HETZNER_API_TOKEN"))) + + +;;; +;;; Hetzner operating systems. +;;; + +;; Operating system for arm servers using UEFI boot mode. + +(define %hetzner-os-arm + (operating-system + (host-name "guix-arm") + (bootloader + (bootloader-configuration + (bootloader grub-efi-bootloader) + (targets (list "/boot/efi")) + (terminal-outputs '(console)))) + (file-systems + (cons* (file-system + (mount-point "/") + (device "/dev/sda1") + (type "ext4")) + (file-system + (mount-point "/boot/efi") + (device "/dev/sda15") + (type "vfat")) + %base-file-systems)) + (initrd-modules + (cons* "sd_mod" "virtio_scsi" %base-initrd-modules)) + (services + (cons* (service dhcp-client-service-type) + (service openssh-service-type + (openssh-configuration + (openssh openssh-sans-x) + (permit-root-login 'prohibit-password))) + %base-services)))) + +;; Operating system for x86 servers using BIOS boot mode. + +(define %hetzner-os-x86 + (operating-system + (inherit %hetzner-os-arm) + (host-name "guix-x86") + (bootloader + (bootloader-configuration + (bootloader grub-bootloader) + (targets (list "/dev/sda")) + (terminal-outputs '(console)))) + (initrd-modules + (cons "virtio_scsi" %base-initrd-modules)) + (file-systems + (cons (file-system + (mount-point "/") + (device "/dev/sda1") + (type "ext4")) + %base-file-systems)))) + +(define (operating-system-authorize os) + "Authorize the OS with the public signing key of the current machine." + (if (file-exists? %public-key-file) + (operating-system + (inherit os) + (services + (modify-services (operating-system-user-services os) + (guix-service-type + config => (guix-configuration + (inherit config) + (authorized-keys + (cons* + (local-file %public-key-file) + (guix-configuration-authorized-keys config)))))))) + (raise (formatted-message (G_ "no signing key '~a'. \ +Have you run 'guix archive --generate-key'?") + %public-key-file)))) + +(define (operating-system-root-file-system-type os) + "Return the root file system type of the operating system OS." + (let ((root-fs (find (lambda (file-system) + (equal? "/" (file-system-mount-point file-system))) + (operating-system-file-systems os)))) + (if (file-system? root-fs) + (file-system-type root-fs) + (raise (formatted-message + (G_ "could not determine root file system type")))))) + + +;;; +;;; Helper functions. +;;; + +(define (escape-backticks str) + "Escape all backticks in STR." + (string-replace-substring str "`" "\\`")) + +(define (format-query-param param) + "Format the query PARAM as a string." + (string-append (uri-encode (format #f "~a" (car param))) "=" + (uri-encode (format #f "~a" (cdr param))))) + +(define (format-query-params params) + "Format the query PARAMS as a string." + (if (> (length params) 0) + (string-append + "?" + (string-join + (map format-query-param params) + "&")) + "")) + + + +;;; +;;; Hetzner API response. +;;; + +(define-record-type* hetzner-api-response + make-hetzner-api-response hetzner-api-response? hetzner-api-response + (body hetzner-api-response-body) + (headers hetzner-api-response-headers) + (status hetzner-api-response-status)) + +(define (hetzner-api-response-meta response) + "Return the meta information of the Hetzner API response." + (assoc-ref (hetzner-api-response-body response) "meta")) + +(define (hetzner-api-response-pagination response) + "Return the meta information of the Hetzner API response." + (assoc-ref (hetzner-api-response-meta response) "pagination")) + +(define (hetzner-api-response-pagination-combine resource responses) + "Combine multiple Hetzner API pagination responses into a single response." + (if (positive? (length responses)) + (let* ((response (car responses)) + (pagination (hetzner-api-response-pagination response)) + (total-entries (assoc-ref pagination "total_entries"))) + (hetzner-api-response + (inherit response) + (body `(("meta" + ("pagination" + ("last_page" . 1) + ("next_page" . null) + ("page" . 1) + ("per_page" . ,total-entries) + ("previous_page" . null) + ("total_entries" . ,total-entries))) + (,resource . ,(append-map + (lambda (body) + (vector->list (assoc-ref body resource))) + (map hetzner-api-response-body responses))))))) + (raise (formatted-message + (G_ "Expected a list of Hetzner API responses"))))) + +(define (hetzner-api-response-read port) + "Read the Hetzner API response from PORT." + (let* ((response (read-response port)) + (body (read-response-body response))) + (hetzner-api-response + (body (json-string->scm (bytevector->string body "UTF-8"))) + (headers (response-headers response)) + (status (response-code response))))) + +(define (hetzner-api-response-validate-status response expected) + "Raise an error if the HTTP status code of RESPONSE is not in EXPECTED." + (when (not (member (hetzner-api-response-status response) expected)) + (raise (formatted-message + (G_ "Unexpected HTTP status code: ~a, expected: ~a~%~a") + (hetzner-api-response-status response) + expected + (hetzner-api-response-body response))))) + + + +;;; +;;; Hetzner API request. +;;; + +(define-record-type* hetzner-api-request + make-hetzner-api-request hetzner-api-request? hetzner-api-request + (body hetzner-api-request-body (default *unspecified*)) + (headers hetzner-api-request-headers (default '())) + (method hetzner-api-request-method (default 'GET)) + (params hetzner-api-request-params (default '())) + (url hetzner-api-request-url)) + +(define (hetzner-api-request-uri request) + "Return the URI object of the Hetzner API request." + (let ((params (hetzner-api-request-params request))) + (string->uri (string-append (hetzner-api-request-url request) + (format-query-params params))))) + +(define (hetzner-api-request-body-bytevector request) + "Return the body of the Hetzner API REQUEST as a bytevector." + (let* ((body (hetzner-api-request-body request)) + (string (if (unspecified? body) "" (scm->json-string body)))) + (string->bytevector string "UTF-8"))) + +(define (hetzner-api-request-write port request) + "Write the Hetzner API REQUEST to PORT." + (let* ((body (hetzner-api-request-body-bytevector request)) + (request (build-request + (hetzner-api-request-uri request) + #:method (hetzner-api-request-method request) + #:version '(1 . 1) + #:headers (cons* `(Content-Length + . ,(number->string + (if (unspecified? body) + 0 (bytevector-length body)))) + (hetzner-api-request-headers request)) + #:port port)) + (request (write-request request port))) + (unless (unspecified? body) + (write-request-body request body)) + (force-output (request-port request)))) + +(define* (hetzner-api-request-send request #:key (expected (list 200 201))) + "Send the Hetzner API REQUEST via HTTP." + (let ((port (open-socket-for-uri (hetzner-api-request-uri request)))) + (hetzner-api-request-write port request) + (let ((response (hetzner-api-response-read port))) + (close-port port) + (hetzner-api-response-validate-status response expected) + response))) + +(define (hetzner-api-request-next-params request) + "Return the pagination params for the next page of the REQUEST." + (let* ((params (hetzner-api-request-params request)) + (page (or (assoc-ref params "page") 1))) + (map (lambda (param) + (if (equal? "page" (car param)) + (cons (car param) (+ page 1)) + param)) + params))) + +(define (hetzner-api-request-paginate request) + "Fetch all pages of the REQUEST via pagination and return all responses." + (let* ((response (hetzner-api-request-send request)) + (pagination (hetzner-api-response-pagination response)) + (next-page (assoc-ref pagination "next_page"))) + (if (number? next-page) + (cons response + (hetzner-api-request-paginate + (hetzner-api-request + (inherit request) + (params (hetzner-api-request-next-params request))))) + (list response)))) + + + +;;; +;;; Hetzner API. +;;; + +(define-record-type* hetzner-api + make-hetzner-api hetzner-api? hetzner-api + (auth-token hetzner-api-auth-token ; string + (default (%hetzner-api-token))) + (base-url hetzner-api-base-url ; string + (default "https://api.hetzner.cloud/v1"))) + +(define (hetzner-api-authorization-header api) + "Return the authorization header the Hetzner API." + (format #f "Bearer ~a" (hetzner-api-auth-token api))) + +(define (hetzner-api-default-headers api) + "Returns the default headers of the Hetzner API." + `((user-agent . "Guix Deploy") + (Accept . "application/json") + (Authorization . ,(hetzner-api-authorization-header api)) + (Content-Type . "application/json"))) + +(define (hetzner-api-url api path) + "Append PATH to the base url of the Hetzner API." + (string-append (hetzner-api-base-url api) path)) + +(define (hetzner-api-delete api path) + "Delelte the resource at PATH with the Hetzner API." + (hetzner-api-request-send + (hetzner-api-request + (headers (hetzner-api-default-headers api)) + (method 'DELETE) + (url (hetzner-api-url api path))))) + +(define* (hetzner-api-list api path resources #:key (params '())) + "Fetch all objects of RESOURCE from the Hetzner API." + (assoc-ref (hetzner-api-response-body + (hetzner-api-response-pagination-combine + resources (hetzner-api-request-paginate + (hetzner-api-request + (url (hetzner-api-url api path)) + (headers (hetzner-api-default-headers api)) + (params (cons '("page" . 1) params)))))) + resources)) + +(define* (hetzner-api-post api path #:key (body *unspecified*)) + "Send a POST request to the Hetzner API at PATH using BODY." + (hetzner-api-response-body + (hetzner-api-request-send + (hetzner-api-request + (body body) + (method 'POST) + (url (hetzner-api-url api path)) + (headers (hetzner-api-default-headers api)))))) + +(define* (hetzner-api-actions api . options) + "Get actions from the Hetzner API." + (apply hetzner-api-list api "/actions" "actions" options)) + +(define* (hetzner-api-action-wait api action #:optional (status "success")) + "Wait until the ACTION has reached STATUS on the Hetzner API." + (let ((id (assoc-ref action "id"))) + (let loop () + (let ((actions (hetzner-api-actions api #:params `(("id" . ,id))))) + (cond + ((zero? (length actions)) + (raise (formatted-message (G_ "server action '~a' not found") id))) + ((not (= 1 (length actions))) + (raise (formatted-message + (G_ "expected one server action, but got '~a'") + (length actions)))) + ((string= status (assoc-ref (car actions) "status")) + (car actions)) + (else + (sleep 5) + (loop))))))) + +(define* (hetzner-api-locations api . options) + "Get deployment locations from the Hetzner API." + (apply hetzner-api-list api "/locations" "locations" options)) + +(define (hetzner-api-server-create api server) + "Create a server on the Hetzner API." + (hetzner-api-post api "/servers" #:body server)) + +(define (hetzner-api-server-delete api server) + "Delete the SERVER on the Hetzner API." + (hetzner-api-delete api (hetzner-server-path server))) + +(define* (hetzner-api-server-enable-rescue-system + api server #:key (ssh-keys '()) (type "linux64")) + "Enable the rescue system for SERVER on the Hetzner API." + (let ((ssh-keys (apply vector (map hetzner-ssh-key-id ssh-keys)))) + (hetzner-api-post api (hetzner-server-path server "/actions/enable_rescue") + #:body `(("ssh_keys" . ,ssh-keys) + ("type" . ,type))))) + +(define* (hetzner-api-servers api . options) + "Get servers from the Hetzner API." + (apply hetzner-api-list api "/servers" "servers" options)) + +(define (hetzner-api-server-power-on api server) + "Send a power on request for SERVER to the Hetzner API." + (hetzner-api-post api (hetzner-server-path server "/actions/poweron"))) + +(define (hetzner-api-server-power-off api server) + "Send a power off request for SERVER to the Hetzner API." + (hetzner-api-post api (hetzner-server-path server "/actions/poweroff"))) + +(define (hetzner-api-server-reboot api server) + "Send a reboot request for SERVER to the Hetzner API." + (hetzner-api-post api (hetzner-server-path server "/actions/reboot"))) + +(define (hetzner-api-ssh-key-create api ssh-key) + "Create the SSH key on the Hetzner API." + (hetzner-api-post api "/ssh_keys" #:body ssh-key)) + +(define* (hetzner-api-ssh-keys api . options) + "Get SSH keys from the Hetzner API." + (apply hetzner-api-list api "/ssh_keys" "ssh_keys" options)) + +(define* (hetzner-api-server-types api . options) + "Get server types from the Hetzner API." + (apply hetzner-api-list api "/server_types" "server_types" options)) + + + +;;; +;;; Hetzner SSH key. +;;; + +(define (hetzner-ssh-key-id ssh-key) + "Return the id of the SSH-KEY." + (assoc-ref ssh-key "id")) + + + +;;; +;;; Hetzner server. +;;; + +(define* (hetzner-server-path server #:optional (path "")) + "Return the PATH of the Hetzner SERVER." + (format #f "/servers/~a~a" (assoc-ref server "id") path)) + +(define (hetzner-server-type server) + "Return the type of the Hetzner SERVER." + (assoc-ref server "server_type")) + +(define (hetzner-server-architecture server) + "Return the architecture of the Hetzner SERVER." + (assoc-ref (hetzner-server-type server) "architecture")) + +(define (hetzner-server-public-ipv4 server) + "Return the public IPv4 address of the SERVER." + (and-let* ((public-net (assoc-ref server "public_net")) + (network (assoc-ref public-net "ipv4"))) + (assoc-ref network "ip"))) + +(define (hetzner-server-system server) + "Return the Guix system architecture of the Hetzner SERVER." + (match (hetzner-server-architecture server) + ("arm" "aarch64-linux") + ("x86" "x86_64-linux"))) + + +;;; +;;; Hetzner configuration. +;;; + +(define-record-type* hetzner-configuration + make-hetzner-configuration hetzner-configuration? this-hetzner-configuration + (api hetzner-configuration-api ; + (default (hetzner-api))) + (allow-downgrades? hetzner-configuration-allow-downgrades? ; boolean + (default #f)) + (authorize? hetzner-configuration-authorize? ; boolean + (default #t)) + (build-locally? hetzner-configuration-build-locally? ; boolean + (default #t)) + (delete? hetzner-configuration-delete? ; boolean + (default #f)) + (enable-ipv6? hetzner-configuration-enable-ipv6? ; boolean + (default #t)) + (labels hetzner-configuration-labels ; list of strings + (default '())) + (location hetzner-configuration-location ; #f | string + (default "fsn1")) + (networks hetzner-configuration-networks ; list of integers + (default '())) + (server-type hetzner-configuration-server-type ; string + (default "cx42")) + (ssh-key hetzner-configuration-ssh-key)) ; string + +(define (hetzner-configuration-public-net config) + "Return the public network configuration of a server for CONFIG." + `(("enable_ipv6" . ,(hetzner-configuration-enable-ipv6? config)))) + +(define (hetzner-configuration-ssh-key-fingerprint config) + "Return the SSH public key fingerprint of CONFIG as a string." + (and-let* ((file-name (hetzner-configuration-ssh-key config)) + (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 (hetzner-configuration-ssh-key-public config) + "Return the SSH public key of CONFIG as a string." + (and-let* ((ssh-key (hetzner-configuration-ssh-key config)) + (public-key (public-key-from-file ssh-key))) + (format #f "ssh-~a ~a" (get-key-type public-key) + (public-key->string public-key)))) + + +;;; +;;; Hetzner Machine. +;;; + +(define (hetzner-machine-delegate target) + "Return the delagate machine that uses SSH for deployment." + (let* ((config (machine-configuration target)) + (server (hetzner-machine-server target)) + ;; Get the operating system WITHOUT the provenance service to avoid a + ;; duplicate symlink conflict in the store. + (os ((@@ (gnu machine) %machine-operating-system) target))) + (machine + (inherit target) + (operating-system + (if (hetzner-configuration-authorize? config) + (operating-system-authorize os) + os)) + (environment managed-host-environment-type) + (configuration + (machine-ssh-configuration + (allow-downgrades? (hetzner-configuration-allow-downgrades? config)) + (authorize? (hetzner-configuration-authorize? config)) + (build-locally? (hetzner-configuration-build-locally? config)) + (host-name (hetzner-server-public-ipv4 server)) + (identity (hetzner-configuration-ssh-key config)) + (system (hetzner-server-system server))))))) + +(define (hetzner-machine-location machine) + "Find the location of MACHINE on the Hetzner API." + (let* ((config (machine-configuration machine)) + (location (hetzner-configuration-location config))) + (find (lambda (type) + (equal? location (assoc-ref type "name"))) + (hetzner-api-locations + (hetzner-configuration-api config) + #:params `(("name" . ,location)))))) + +(define (hetzner-machine-server-type machine) + "Find the server type of MACHINE on the Hetzner API." + (let* ((config (machine-configuration machine)) + (server-type (hetzner-configuration-server-type config))) + (find (lambda (type) + (equal? server-type (assoc-ref type "name"))) + (hetzner-api-server-types + (hetzner-configuration-api config) + #:params `(("name" . ,server-type)))))) + +(define (hetzner-machine-validate-auth-token machine) + "Validate the Hetzner API authentication token of MACHINE." + (let* ((config (machine-configuration machine)) + (api (hetzner-configuration-api config))) + (unless (hetzner-api-auth-token api) + (raise (formatted-message + (G_ "No Hetzner Cloud access token was provided. \ +This may be fixed by setting the environment variable GUIX_HETZNER_API_TOKEN +to one procured from \ +https://docs.hetzner.com/cloud/api/getting-started/generating-api-token")))))) + +(define (hetzner-machine-validate-configuration-type machine) + "Raise an error if MACHINE's configuration is not an instance of +." + (let ((config (machine-configuration machine)) + (environment (environment-type-name (machine-environment machine)))) + (unless (and config (hetzner-configuration? config)) + (raise (formatted-message (G_ "unsupported machine configuration '~a' \ +for environment of type '~a'") + config + environment))))) + +(define (hetzner-machine-validate-server-type machine) + "Raise an error if the server type of MACHINE is not supported." + (unless (hetzner-machine-server-type machine) + (let* ((config (machine-configuration machine)) + (api (hetzner-configuration-api config))) + (raise (formatted-message + (G_ "Server type '~a' not supported~%~%\ +Available server types:~%~%~a") + (hetzner-configuration-server-type config) + (string-join + (map (lambda (type) + (format #f " - ~a: ~a, ~a ~a cores, ~a GB mem, ~a GB disk" + (colorize-string (assoc-ref type "name") + (color BOLD)) + (assoc-ref type "architecture") + (assoc-ref type "cores") + (assoc-ref type "cpu_type") + (assoc-ref type "memory") + (assoc-ref type "disk"))) + (hetzner-api-server-types api)) + "\n")))))) + +(define (hetzner-machine-validate-location machine) + "Raise an error if the location of MACHINE is not supported." + (unless (hetzner-machine-location machine) + (let* ((config (machine-configuration machine)) + (api (hetzner-configuration-api config))) + (raise (formatted-message + (G_ "Server location '~a' not supported~%~%\ +Available locations:~%~%~a") + (hetzner-configuration-location config) + (string-join + (map (lambda (location) + (format #f " - ~a: ~a, ~a" + (colorize-string (assoc-ref location "name") + (color BOLD)) + (assoc-ref location "description") + (assoc-ref location "country"))) + (hetzner-api-locations api)) + "\n")))))) + +(define (hetzner-machine-validate machine) + "Validate the Hetzner MACHINE." + (hetzner-machine-validate-configuration-type machine) + (hetzner-machine-validate-auth-token machine) + (hetzner-machine-validate-location machine) + (hetzner-machine-validate-server-type machine)) + +(define (hetzner-machine-bootstrap-os-form machine server) + "Return the form to bootstrap an operating system on SERVER." + (let* ((os (machine-operating-system machine)) + (system (hetzner-server-system server)) + (arm? (equal? "arm" (hetzner-server-architecture server))) + (x86? (equal? "x86" (hetzner-server-architecture server))) + (root-fs-type (operating-system-root-file-system-type os))) + `(operating-system + (host-name ,(operating-system-host-name os)) + (timezone "Etc/UTC") + (bootloader (bootloader-configuration + (bootloader ,(cond (arm? 'grub-efi-bootloader) + (x86? 'grub-bootloader))) + (targets ,(cond (arm? '(list "/boot/efi")) + (x86? '(list "/dev/sda")))) + (terminal-outputs '(console)))) + (initrd-modules (append + ,(cond (arm? '(list "sd_mod" "virtio_scsi")) + (x86? '(list "virtio_scsi"))) + %base-initrd-modules)) + (file-systems ,(cond + (arm? `(cons* (file-system + (mount-point "/") + (device "/dev/sda1") + (type ,root-fs-type)) + (file-system + (mount-point "/boot/efi") + (device "/dev/sda15") + (type "vfat")) + %base-file-systems)) + (x86? `(cons* (file-system + (mount-point "/") + (device "/dev/sda1") + (type ,root-fs-type)) + %base-file-systems)))) + (services + (cons* (service dhcp-client-service-type) + (service openssh-service-type + (openssh-configuration + (openssh openssh-sans-x) + (permit-root-login 'prohibit-password))) + %base-services))))) + +(define (rexec-verbose session cmd) + "Execute a command CMD on the remote side and print output. Return two +values: list of output lines returned by CMD and its exit code." + (let* ((channel (open-remote-input-pipe session cmd)) + (result (let loop ((line (read-line channel)) + (result '())) + (if (eof-object? line) + (reverse result) + (begin + (display line) + (newline) + (loop (read-line channel) + (cons line result)))))) + (exit-status (channel-get-exit-status channel))) + (close channel) + (values result exit-status))) + +(define (hetzner-machine-ssh-key machine) + "Find the SSH key for MACHINE on the Hetzner API." + (let* ((config (machine-configuration machine)) + (fingerprint (hetzner-configuration-ssh-key-fingerprint config))) + (find (lambda (server) + (equal? (assoc-ref server "fingerprint") fingerprint)) + (hetzner-api-ssh-keys + (hetzner-configuration-api config) + #:params `(("fingerprint" . ,fingerprint)))))) + +(define (hetzner-machine-ssh-key-create machine) + "Create the SSH key for MACHINE on the Hetzner API." + (let ((name (machine-display-name machine))) + (format #t "creating ssh key for '~a'...\n" name) + (let* ((config (machine-configuration machine)) + (api (hetzner-configuration-api config)) + (body (hetzner-api-ssh-key-create + (hetzner-configuration-api config) + `(("name" . ,(machine-display-name machine)) + ("name" . + ,(hetzner-configuration-ssh-key-fingerprint config)) + ("public_key" . + ,(hetzner-configuration-ssh-key-public config)) + ("labels" . ,(hetzner-configuration-labels config)))))) + (format #t "successfully created ssh key for '~a'\n" name) + (assoc-ref body "ssh_key")))) + +(define (hetzner-machine-server machine) + "Find the Hetzner server for MACHINE." + (let ((config (machine-configuration machine))) + (find (lambda (server) + (equal? (machine-display-name machine) + (assoc-ref server "name"))) + (hetzner-api-servers + (hetzner-configuration-api config) + #:params `(("name" . ,(machine-display-name machine))))))) + +(define (hetzner-machine-create-server machine) + "Create the Hetzner server for MACHINE." + (let* ((config (machine-configuration machine)) + (name (machine-display-name machine)) + (server-type (hetzner-configuration-server-type config))) + (format #t "creating '~a' server for '~a'...\n" server-type name) + (let* ((ssh-key (hetzner-machine-ssh-key machine)) + (api (hetzner-configuration-api config)) + (body (hetzner-api-server-create + api + `(("image" . "debian-11") + ("labels" . ,(hetzner-configuration-labels config)) + ("name" . ,(machine-display-name machine)) + ("public_net" . ,(hetzner-configuration-public-net config)) + ("location" . ,(hetzner-configuration-location config)) + ("server_type" . + ,(hetzner-configuration-server-type config)) + ("ssh_keys" . ,(vector (hetzner-ssh-key-id ssh-key))) + ("start_after_create" . #f)))) + (server (assoc-ref body "server")) + (architecture (hetzner-server-architecture server))) + (hetzner-api-action-wait api (assoc-ref body "action")) + (format #t "successfully created '~a' ~a server for '~a'\n" + server-type architecture name) + server))) + +(define (wait-for-ssh address ssh-key) + "Block until a SSH session can be made as 'root' with SSH-KEY at ADDRESS." + (format #t "connecting via SSH to '~a' using '~a'...\n" address ssh-key) + (let loop () + (catch #t + (lambda () + (open-ssh-session address #:user "root" #:identity ssh-key + #:stricthostkeycheck #f)) + (lambda args + (let ((msg (cadr args))) + (if (formatted-message? msg) + (format #t "~a\n" + (string-trim-right + (apply format #f + (formatted-message-string msg) + (formatted-message-arguments msg)) + #\newline)) + (format #t "~a" args)) + (sleep 5) + (loop)))))) + +(define (hetzner-machine-wait-for-ssh machine) + "Wait for SSH connection to be established with the specified machine." + (let ((server (hetzner-machine-server machine))) + (wait-for-ssh (hetzner-server-public-ipv4 server) + (hetzner-configuration-ssh-key + (machine-configuration machine))))) + +(define (hetzner-machine-authenticate-host machine) + "Add the host key of MACHINE to the list of known hosts." + (let ((ssh-session (hetzner-machine-wait-for-ssh machine))) + (write-known-host! ssh-session))) + +(define (hetzner-machine-enable-rescue-system machine server) + "Enable the rescue system on the Hetzner SERVER for MACHINE." + (let* ((name (machine-display-name machine)) + (config (machine-configuration machine)) + (api (hetzner-configuration-api config)) + (ssh-keys (list (hetzner-machine-ssh-key machine)))) + (format #t "enabling rescue system on '~a'...\n" name) + (let ((body (hetzner-api-server-enable-rescue-system + api server #:ssh-keys ssh-keys))) + (hetzner-api-action-wait api (assoc-ref body "action")) + (format #t "successfully enabled rescue system on '~a'\n" name) + body))) + +(define (hetzner-machine-power-on machine server) + "Power on the Hetzner SERVER for MACHINE." + (let* ((name (machine-display-name machine)) + (config (machine-configuration machine)) + (api (hetzner-configuration-api config))) + (format #t "powering on server for '~a'...\n" name) + (let ((body (hetzner-api-server-power-on api server))) + (hetzner-api-action-wait api (assoc-ref body "action")) + (format #t "successfully powered on server for '~a'\n" name) + body))) + +(define (hetzner-machine-ssh-run-script ssh-session name content) + (let ((sftp-session (make-sftp-session ssh-session))) + (rexec ssh-session (format #f "rm -f ~a" name)) + (rexec ssh-session (format #f "mkdir -p ~a" (dirname name))) + (call-with-remote-output-file + sftp-session name + (lambda (port) + (display content port))) + (sftp-chmod sftp-session name 755) + (receive (lines exit-code) + (rexec-verbose ssh-session (format #f "~a 2>&1" name)) + (if (zero? exit-code) + lines + (raise (formatted-message + (G_ "failed to run script '~a' on machine, exit code: '~a'") + name exit-code)))))) + +(define (hetzner-machine-rescue-install-os machine ssh-session server) + (let ((name (machine-display-name machine)) + (os (hetzner-machine-bootstrap-os-form machine server))) + (format #t "installing guix operating system on '~a'...\n" name) + (hetzner-machine-ssh-run-script + ssh-session "/tmp/guix/deploy/hetzner-machine-rescue-install-os" + (format #f "#!/usr/bin/env bash +set -eo pipefail +mount /dev/sda1 /mnt +mkdir -p /mnt/boot/efi +mount /dev/sda15 /mnt/boot/efi + +mkdir --parents /mnt/root/.ssh +chmod 700 /mnt/root/.ssh +cp /root/.ssh/authorized_keys /mnt/root/.ssh/authorized_keys +chmod 600 /mnt/root/.ssh/authorized_keys + +cat > /tmp/guix/deploy/hetzner-os.scm << EOF +(use-modules (gnu) (guix utils)) +(use-package-modules ssh) +(use-service-modules base networking ssh) +(use-system-modules linux-initrd) +~a +EOF +cat /tmp/guix/deploy/hetzner-os.scm +guix system init --verbosity=2 /tmp/guix/deploy/hetzner-os.scm /mnt" + (escape-backticks (format #f "~y" os)))) + (format #t "successfully installed guix operating system on '~a'\n" name))) + +(define (hetzner-machine-reboot machine server) + "Reboot the Hetzner SERVER for MACHINE." + (let* ((name (machine-display-name machine)) + (config (machine-configuration machine)) + (api (hetzner-configuration-api config))) + (format #t "rebooting server for '~a'...\n" name) + (let ((body (hetzner-api-server-reboot api server))) + (hetzner-api-action-wait api (assoc-ref body "action")) + (format #t "successfully rebooted server for '~a'\n" name) + body))) + +(define (hetzner-machine-rescue-partition machine ssh-session) + "Setup the partitions of the Hetzner server for MACHINE using SSH-SESSION." + (let* ((name (machine-display-name machine)) + (os (machine-operating-system machine)) + (root-fs-type (operating-system-root-file-system-type os))) + (format #t "setting up partitions on '~a'...\n" name) + (hetzner-machine-ssh-run-script + ssh-session "/tmp/guix/deploy/hetzner-machine-rescue-partition" + (format #f "#!/usr/bin/env bash +set -eo pipefail +growpart /dev/sda 1 || true +~a +fdisk -l /dev/sda" + (cond + ((equal? "btrfs" root-fs-type) + (format #f "mkfs.btrfs -L ~a -f /dev/sda1" root-label)) + ((equal? "ext4" root-fs-type) + (format #f "mkfs.ext4 -L ~a -F /dev/sda1" root-label)) + (else (raise (formatted-message + (G_ "unsupported root file system type '~a'") + root-fs-type)))))) + (format #t "successfully setup partitions on '~a'\n" name))) + +(define (hetzner-machine-rescue-install-packages machine ssh-session) + "Install packages on the Hetzner server for MACHINE using SSH-SESSION." + (let ((name (machine-display-name machine))) + (format #t "installing rescue system packages on '~a'...\n" name) + (hetzner-machine-ssh-run-script + ssh-session "/tmp/guix/deploy/hetzner-machine-rescue-install-packages" + (format #f "#!/usr/bin/env bash +set -eo pipefail +apt-get update +apt-get install guix cloud-initramfs-growroot --assume-yes")) + (format #t "successfully installed rescue system packages on '~a'\n" name))) + +(define (hetzner-machine-delete machine server) + "Delete the Hetzner server for MACHINE." + (let* ((name (machine-display-name machine)) + (config (machine-configuration machine)) + (api (hetzner-configuration-api config))) + (format #t "deleting server for '~a'...\n" name) + (let ((body (hetzner-api-server-delete api server))) + (hetzner-api-action-wait api (assoc-ref body "action")) + (format #t "successfully deleted server for '~a'\n" name) + body))) + +(define (hetzner-machine-provision machine) + "Provision a server for MACHINE on the Hetzner Cloud service." + (with-exception-handler + (lambda (exception) + (let ((config (machine-configuration machine)) + (server (hetzner-machine-server machine))) + (when (and server (hetzner-configuration-delete? config)) + (hetzner-machine-delete machine server)) + (raise-exception exception))) + (lambda () + (let ((server (hetzner-machine-create-server machine))) + (hetzner-machine-enable-rescue-system machine server) + (hetzner-machine-power-on machine server) + (let ((ssh-session (hetzner-machine-wait-for-ssh machine))) + (hetzner-machine-rescue-install-packages machine ssh-session) + (hetzner-machine-rescue-partition machine ssh-session) + (hetzner-machine-rescue-install-os machine ssh-session server) + (hetzner-machine-reboot machine server) + (sleep 5) + (hetzner-machine-authenticate-host machine)))) + #:unwind? #t)) + + +;;; +;;; Remote evaluation. +;;; + +(define (hetzner-remote-eval machine exp) + "Internal implementation of 'machine-remote-eval' for MACHINE instances with +an environment type of 'hetzner-environment-type'." + (hetzner-machine-validate machine) + (unless (hetzner-machine-server machine) + (raise (formatted-message + (G_ "machine '~a' not provisioned on the Hetzner Cloud service") + (machine-display-name machine)))) + (machine-remote-eval (hetzner-machine-delegate machine) exp)) + + + +;;; +;;; System deployment. +;;; + +(define (deploy-hetzner machine) + "Internal implementation of 'deploy-machine' for 'machine' instances with an +environment type of 'hetzner-environment-type'." + (hetzner-machine-validate machine) + (unless (hetzner-machine-ssh-key machine) + (hetzner-machine-ssh-key-create machine)) + (unless (hetzner-machine-server machine) + (hetzner-machine-provision machine)) + (deploy-machine (hetzner-machine-delegate machine))) + + + +;;; +;;; Roll-back. +;;; + +(define (roll-back-hetzner machine) + "Internal implementation of 'roll-back-machine' for MACHINE instances with an +environment type of 'hetzner-environment-type'." + (hetzner-machine-validate machine) + (roll-back-machine (hetzner-machine-delegate machine))) + + + +;;; +;;; Environment type. +;;; + +(define hetzner-environment-type + (environment-type + (machine-remote-eval hetzner-remote-eval) + (deploy-machine deploy-hetzner) + (roll-back-machine roll-back-hetzner) + (name 'hetzner-environment-type) + (description "Provisioning of virtual machine servers on the Hetzner Cloud +service."))) diff --git a/guix/ssh.scm b/guix/ssh.scm index ae506df14c..196a92e813 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -103,7 +103,8 @@ (define* (open-ssh-session host #:key user port identity host-key (compression %compression) (timeout 3600) - (connection-timeout 10)) + (connection-timeout 10) + (stricthostkeycheck #t)) "Open an SSH session for HOST and return it. IDENTITY specifies the file name of a private key to use for authenticating with the host. When USER, PORT, or IDENTITY are #f, use default values or whatever '~/.ssh/config' @@ -137,7 +138,8 @@ (define* (open-ssh-session host #:key user port identity ;; Speed up RPCs by creating sockets with ;; TCP_NODELAY. - #:nodelay #t))) + #:nodelay #t + #:stricthostkeycheck stricthostkeycheck))) ;; Honor ~/.ssh/config. (session-parse-config! session) @@ -149,13 +151,14 @@ (define* (open-ssh-session host #:key user port identity (authenticate-server* session host-key) ;; Authenticate against ~/.ssh/known_hosts. - (match (authenticate-server session) - ('ok #f) - (reason - (raise (formatted-message (G_ "failed to authenticate \ + (when stricthostkeycheck + (match (authenticate-server session) + ('ok #f) + (reason + (raise (formatted-message (G_ "failed to authenticate \ server at '~a': ~a") - (session-get session 'host) - reason))))) + (session-get session 'host) + reason)))))) ;; Use public key authentication, via the SSH agent if it's available. (match (userauth-public-key/auto! session) base-commit: 831b94a1efcea8f793afc949b5123a6235c9bb1a -- 2.47.1