tribes/guix-tribes
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Compare commits

merge into: tribes/guix-tribes:supertest-dev-cluster-pubsub-linear
Branches Tags
tribes/guix-tribes:master tribes/guix-tribes:kexec-installer tribes/guix-tribes:supertest-dev tribes/guix-tribes:supertest-dev-cluster-pubsub-linear tribes/guix-tribes:fix/compile-bundled-tribes-ui tribes/guix-tribes:keyring
..
pull from: tribes/guix-tribes:keyring
Branches Tags
tribes/guix-tribes:kexec-installer tribes/guix-tribes:master tribes/guix-tribes:supertest-dev tribes/guix-tribes:supertest-dev-cluster-pubsub-linear tribes/guix-tribes:fix/compile-bundled-tribes-ui tribes/guix-tribes:keyring

2 Commits
supertest-dev-cluster-pubsub-linear .. keyring

Author SHA1 Message Date
self d7fa902ab3 build: add supertest dev key to keyring 
Add the public key used to sign the supertest-dev channel branch for explicit test/dev rollout iteration.
 2026-04-30 11:30:06 +02:00
self dca3656c11 Add key for Steffen Beyer. 2026-04-16 23:13:43 +02:00
48 changed files with 643 additions and 6410 deletions
Expand all files Collapse all files
.guix-authorizations
-10
View File
@@ -1,10 +0,0 @@
;; This file, which is best viewed as -*- Scheme -*-, lists the OpenPGP keys
;; currently authorized to sign commits in this repository.
(authorizations
(version 0)
(("6688 9153 C51C 4613 A493 A525 2F0D FD14 EF99 DAC3"
(name "steffen"))
("F29B A6DA 96E5 EC29 FDDE D994 8F4F 75B3 B19D 4784"
(name "tribes-supertest-dev"))))
.guix-channel
-6
View File
@@ -1,6 +0,0 @@
;; This is a Guix channel.
(channel
(version 0)
(keyring-reference "keyring")
(url "https://git.teralink.net/tribes/guix-tribes.git"))
README.md
+5 -12
View File
@@ -42,19 +42,12 @@ Current development status:
3. A QEMU Phase-0 system with encrypted root now boots unattended through
Clevis/Tang and reaches a login prompt.
For pinned bootstrap usage, generate a `channels.scm` that combines the pinned
upstream Guix channel with this repository's current commit.
For pinned bootstrap usage, generate a `channels.scm` that combines upstream
Guix with this repository's current commit.
Two checked-in channel files serve different purposes:
- `pins/base-channels.sexp`: upstream Guix pin only, used for `guix pull -C`
and related bootstrap tooling
- `pins/legion-channels.sexp`: Legion/builder default channel set, containing
the pinned upstream Guix channel plus the default `tribes` channel metadata
Refresh the upstream Guix pin intentionally with
`./scripts/update-base-channels-pin`, then update `pins/legion-channels.sexp`
to keep its `guix` entry aligned.
The deployment scripts default to the checked-in base-channel lock at
`pins/base-channels.sexp`. Refresh that lock intentionally with
`./scripts/update-base-channels-pin`.
The current Legion kexec image path is based on:
docs/LOCAL_CONTROL_API.md
-222
View File
@@ -1,222 +0,0 @@
# Tribes local-control API
The local-control broker is a small Guile daemon listening on a Unix-domain
socket. It fronts every operator action that a Tribes deployment can take on
its own host:
- **resolve** a `SystemTarget` into a build plan.
- **prepare** a build (pull channels + `guix system build`) without
activating it.
- **commit** a previously-prepared generation (`guix system
switch-generation`).
- **rollback** to a retained store path or, failing that, rebuild from a
plan and switch.
- **abort** an in-flight job.
- inspect **status** and **generations**.
This document specifies the wire schema. The BEAM client at
`tribes/lib/tribes/local_control.ex` should be updated to match it.
## Transport
- HTTP/1.1 over a Unix-domain socket. The path is configurable via
`TRIBES_LOCAL_CONTROL_SOCKET` (default `/var/run/tribes/local-control.sock`).
- Permissions: socket owned by `root:tribes`, mode `0660`.
- Request bodies are JSON (`Content-Type: application/json`).
- Responses are JSON.
## Concurrency model
The broker runs a single POSIX worker thread. The HTTP request thread is
never blocked on a long-running Guix call: any operation that may exceed
about a second (`prepare`, `commit`, `rollback`) is enqueued on the worker
and returns `202 Accepted` immediately. The caller then polls
`GET /v1/deployment/status` for completion.
There is at most one job in flight at any time. A new submission with the
same `plan_hash` as the running job is **idempotent**: the broker returns
the in-flight snapshot rather than queuing a duplicate. A submission with a
different `plan_hash` while another job runs returns `409 busy`.
## Endpoints
### `GET /v1/deployment` and `GET /v1/deployment/status`
Returns a status snapshot. Polling interval recommendation: 1 s during an
active job, with linear back-off to 5 s after the first minute of polling.
Snapshot fields:
- `schemaVersion` — string, currently `"2"`.
- `ok` — boolean.
- `status` — high-level state. One of:
`idle | queued | running | pulling | building | switching | completed |
failed | aborted`.
- `phase` — fine-grained phase identical to `status` for in-flight jobs;
`ready` after a successful `prepare`, `active` after a successful
`commit`/`rollback`.
- `job_id` — opaque identifier of the in-flight or last-completed job.
`"job-N"` where N is monotonic for the broker process lifetime.
- `plan_hash` — the plan hash this job is operating on.
- `started_at`, `last_event_at` — RFC 3339 timestamps.
- `store_path` — the deployment target's `/gnu/store/...-system` path:
the prepared store path after `prepare`, or the selected profile store path
after `commit`/`rollback`.
- `selectedSystem` — canonical `/gnu/store/...-system` path currently selected
by `/var/guix/profiles/system`.
- `runningSystem` — canonical `/gnu/store/...-system` path currently exposed by
`/run/current-system`.
- `generation_number` — the system profile generation number.
- `gc_pinned` — boolean. `true` when the broker holds a GC root via
`--root=` so the prepared system is not collected before a `commit`.
- `built_at`, `activated_at` — RFC 3339 timestamps when present.
- `code` — typed error code on failure (see *Error taxonomy*).
- `reason` — human-readable error message on failure.
- `plugins` — array of plugin names in the deployed plan.
### `GET /v1/deployment/generations`
Returns the list of recorded generations in newest-first order. Each entry:
```json
{
"store_path": "/gnu/store/...-system",
"generation_number": 42,
"plan_hash": "plan-abcd...",
"status": "active" | "ready" | "superseded",
"gc_pinned": true,
"built_at": "2026-04-25T13:01:02Z",
"activated_at": "2026-04-25T13:01:42Z"
}
```
### `POST /v1/deployment/resolve`
Synchronous. Body: a `SystemTarget` JSON object. Response:
- `200` with `{ "schemaVersion": "2", "ok": true, "plan": { ... } }` on
success. The `plan` object includes a `plan_hash` and is suitable for
feeding into `prepare`.
- `409` with the resolver error envelope on capability/manifest/trust
failures.
### `POST /v1/deployment/prepare`
Asynchronous. Body: a plan object containing `plan_hash` and
`resolved_plugins`.
- `202` with `{ "schemaVersion": "2", "status": "queued", "job_id": "...",
"plan_hash": "...", "started_at": "..." }` on accept (or on idempotent
re-submit of the running job).
- `409` with `{ "ok": false, "status": "busy", "reason": "deployment already in
progress", "job_id": "...", "plan_hash": "...", ... }` when another
plan is already in flight.
- `400` on validation error.
The job pulls channels, runs `guix system build --root=...`, registers the
resulting GC root, and records a `ready` generation. The final snapshot is
visible at `GET /v1/deployment/status`.
### `POST /v1/deployment/commit`
Asynchronous. Body: `{ "plan_hash": "..." }`.
- `202` on accept. The job switches the system profile to the
previously-prepared generation, then re-runs activation and Guix's normal
Shepherd service-definition upgrade step inside the pulled/current Guix
profile used for the prepare build. Activation runs with `GUIX_NEW_SYSTEM`
set to the selected generation so `/run/current-system` follows the
profile. Like upstream `guix system reconfigure`, this does not imply
that every already-running service process was restarted. Tribes may then
schedule an asynchronous `tribes` service restart as part of higher-level
rollout convergence, while `tribes-local-control` self-update remains a
separate deferred concern. On success the snapshot reaches `phase:
"active"` with `status: "completed"`.
- `409` if no generation is prepared for that `plan_hash`. The snapshot's
error code is `generation_not_prepared`.
- `409 busy` if another job is in flight.
### `POST /v1/deployment/rollback`
Asynchronous. Body:
```json
{
"store_path": "/gnu/store/...-system",
"plan": { ...optional fallback plan... }
}
```
The broker walks these cases in order:
1. The requested `store_path` is the selected system → just record the
activation, no build, no switch.
2. We have a recorded local-control generation number for that `store_path`
→ switch to it directly.
3. The `store_path` appears in Guix's system profile links
(`/var/guix/profiles/system-*-link`), even if local-control did not record
it → switch to that profile generation directly. This covers the installed
baseline generation used by emergency/public rollback.
4. The store path is gone but `plan` is supplied → re-prepare and commit.
If none apply the snapshot reports `code: "rollback_infeasible"`.
Current limitation: rollback does not run core/plugin down migrations. The
public Tribes admin rollback flow currently omits the fallback `plan` on
purpose so explicit rollback to a baseline generation cannot replay the rollout
being rolled back.
### `POST /v1/deployment/abort`
Synchronous. Marks the in-flight job as aborted and writes a snapshot with
`status: "aborted"`. (v1: does not yet SIGTERM a running helper subprocess —
the operation completes when the helper next checks back in.)
## Error taxonomy
Every failed operation returns a `code` matching one of these tokens:
- `channel_untrusted` — channel references a signer not in the
`TrustedSigner` table.
- `signature_invalid` — a channel's commit signature failed verification.
- `channel_commit_unreachable` — the configured commit cannot be fetched
from the channel URL.
- `missing_capability` — a plugin requires a capability that no other
plugin provides.
- `capability_cycle` — the plugin capability graph contains a cycle.
- `duplicate_plugin` — the system target lists the same plugin twice.
- `manifest_invalid` — a requested plugin name is unknown to the channel
registry.
- `host_api_mismatch` — the resolved plan needs a host API version the
node cannot honour.
- `migration_target_conflict` — two plugins disagree about a migration
target version.
- `build_failed` — `guix system build` returned non-zero.
- `switch_failed` — `guix system switch-generation` returned non-zero.
- `rollback_infeasible` — the broker cannot reach the requested store
path by either retained generation or rebuild.
- `helper_crashed` — `tribes-guix-helper` exited without emitting a
structured terminal frame.
- `busy` — another job is in flight; the request was rejected.
- `invalid_request` — payload missed a required field or violated a limit.
## Helper protocol (internal)
The broker spawns `tribes-guix-helper` for every long operation and parses
its stdout as NDJSON. The helper emits one of:
```json
{"event":"phase","phase":"pulling","ts":"..."}
{"event":"phase","phase":"building","ts":"...","derivation":"/gnu/store/..."}
{"event":"done","store_path":"/gnu/store/...","generation_number":42,"ts":"..."}
{"event":"error","code":"channel_commit_unreachable","message":"...","details":{...},"ts":"..."}
```
The broker uses the last `event: "phase"` frame to update its snapshot in
real time, and the final `done` or `error` frame to compute the operation
result. If the helper exits without a terminal frame the broker synthesizes
`{ "code": "helper_crashed", "details": { "exit_status": N, "signal": S } }`.
This protocol is not part of the public API; it exists so the broker can
stay small while still surfacing typed errors instead of regex-parsing
`guix` stderr.
examples/legion-phase1-system.sexp
-1
View File
@@ -13,7 +13,6 @@
(nbde system initrd)
(nbde system mapped-devices)
(tribes config host)
(tribes services lego)
(tribes system installer))
(define host-config-path
nbde/services/tang.scm
+1 -2
View File
@@ -23,8 +23,7 @@
(define (tang-activation config)
#~(begin
(use-modules (guix build utils)
(ice-9 ftw))
(use-modules (guix build utils))
(let ((key-directory #$(tang-configuration-key-directory config))
(keygen (string-append
#$(tang-configuration-package config)
pins/legion-channels.sexp
-22
View File
@@ -1,22 +0,0 @@
(list
(channel
(name 'guix)
(url "https://git.teralink.net/tribes/guix-fork.git")
(branch "master")
;; Guix v1.5.0
(commit
"6f9c3cd1761f0a3f8b70223cb0e0f47e29582d90")
(introduction
(make-channel-introduction
"6f9c3cd1761f0a3f8b70223cb0e0f47e29582d90"
(openpgp-fingerprint
"6688 9153 C51C 4613 A493 A525 2F0D FD14 EF99 DAC3"))))
(channel
(name 'tribes)
(url "https://git.teralink.net/tribes/guix-tribes.git")
(branch "master")
(introduction
(make-channel-introduction
"607c69a5c1662acca07ad72c3e18646c73500856"
(openpgp-fingerprint
"6688 9153 C51C 4613 A493 A525 2F0D FD14 EF99 DAC3")))))
scripts/compare-system-generations.scm
-18
View File
@@ -1,18 +0,0 @@
#!/usr/bin/env guile
!#
(define-module (scripts compare-system-generations)
#:use-module (ice-9 match)
#:use-module (srfi srfi-13)
#:use-module (tribes diagnostics system-generations))
(define (script-invocation? argv)
(match argv
((program . _)
(and (string? program)
(or (string=? program "compare-system-generations.scm")
(string-suffix? "/compare-system-generations.scm" program))))
(_ #f)))
(when (script-invocation? (command-line))
(compare-system-generations-main (cdr (command-line))))
scripts/update-plugin-pin
-437
View File
@@ -1,437 +0,0 @@
#!/usr/bin/env perl
use strict;
use warnings;
use Cwd qw(abs_path);
use File::Basename qw(dirname);
use File::Spec;
use File::Temp qw(tempdir tempfile);
use Getopt::Long qw(GetOptionsFromArray);
use IPC::Open3 qw(open3);
use JSON::PP qw(decode_json encode_json);
use Symbol qw(gensym);
sub usage {
print <<'EOF';
Usage: update-plugin-pin [options] plugin [rev]
Pin a Tribes external plugin and refresh fixed-output hashes.
PLUGIN is the manifest/plugin name. REV defaults to "master" resolved from the
plugin checkout. The plugin manifest.json is the source of truth for plugin
name, version, provides, and requires metadata. By default the script expects
the plugin checkout at ../tribes-plugin-$PLUGIN and the Guix plugin file at
tribes/plugins/$PLUGIN.scm relative to the guix-tribes checkout.
Options:
--plugin-repo PATH Local plugin git checkout
--plugin-file PATH Guix plugin definition file to update
--tribes-repo PATH Local Tribes git checkout used for the host plugin API
--tribes-rev REV Tribes commit/rev for host API hashing (default: current guix-tribes pin)
--guix-repo PATH Local guix-tribes checkout
--pguix-host HOST SSH host used for Guix builds and hashing
-h, --help Show this help
EOF
}
sub fail {
die "@_\n";
}
sub read_file {
my ($path) = @_;
open my $fh, '<', $path or fail("Failed to read $path: $!");
local $/;
return <$fh>;
}
sub write_file {
my ($path, $content) = @_;
open my $fh, '>', $path or fail("Failed to write $path: $!");
print {$fh} $content or fail("Failed to write $path: $!");
close $fh or fail("Failed to close $path: $!");
}
sub command_exists {
my ($command) = @_;
for my $dir (split /:/, ($ENV{PATH} // '')) {
my $path = File::Spec->catfile($dir, $command);
return 1 if -x $path;
}
return 0;
}
sub require_tool {
my ($tool) = @_;
command_exists($tool) or fail("Missing required tool: $tool");
}
sub run_capture {
my (@cmd) = @_;
my $err = gensym();
my $pid = open3(undef, my $out, $err, @cmd);
local $/;
my $stdout = <$out> // '';
my $stderr = <$err> // '';
waitpid($pid, 0);
my $output = $stdout . $stderr;
my $status = $? >> 8;
return ($status, $output);
}
sub run_checked {
my (@cmd) = @_;
system(@cmd) == 0 or fail("Command failed: @cmd");
}
sub trim {
my ($value) = @_;
$value =~ s/^\s+//;
$value =~ s/\s+$//;
return $value;
}
sub scheme_string_list {
my (@values) = @_;
return '(' . join(' ', map { encode_json($_) } @values) . ')';
}
sub replace_once {
my ($text_ref, $pattern, $replacement, $label) = @_;
my $count = ($$text_ref =~ s/$pattern/$replacement/s);
$count == 1 or fail("failed to update $label");
}
sub update_plugin_definition_header {
my ($text_ref, $plugin_name, $package_name, $version) = @_;
my @lines = split /\n/, $$text_ref, -1;
my ($definition_start, $name_index, $version_index);
for my $i (0 .. $#lines) {
if (!defined $definition_start) {
if ($lines[$i] =~ /\(tribes-plugin-definition\b/) {
$definition_start = $i;
}
next;
}
if (!defined $name_index) {
if ($lines[$i] =~ /^\s*\(name "\Q$plugin_name\E"\)$/) {
$name_index = $i;
}
next;
}
if ($lines[$i] =~ /^\s*\(package-name "[^"]+"\)$/) {
next;
}
if ($lines[$i] =~ /^\s*\(version "[^"]+"\)$/) {
$version_index = $i;
last;
}
last if $lines[$i] =~ /^\s*\(/;
}
defined $name_index && defined $version_index
or fail('failed to update plugin definition version');
my ($indent) = ($lines[$version_index] =~ /^(\s*)/);
splice(
@lines,
$name_index + 1,
$version_index - $name_index,
qq(${indent}(package-name "$package_name")),
qq(${indent}(version "$version")),
);
$$text_ref = join("\n", @lines);
}
my $local_tmp = '';
my $remote_tmp = '';
my @argv = @ARGV;
my %opts = (
pguix_host => 'pguix',
);
GetOptionsFromArray(
\@argv,
'plugin-repo=s' => \$opts{plugin_repo},
'plugin-file=s' => \$opts{plugin_file},
'tribes-repo=s' => \$opts{tribes_repo},
'tribes-rev=s' => \$opts{tribes_rev},
'guix-repo=s' => \$opts{guix_repo},
'pguix-host=s' => \$opts{pguix_host},
'h|help' => \$opts{help},
) or do {
usage();
exit 1;
};
if ($opts{help}) {
usage();
exit 0;
}
my $plugin = shift @argv;
defined $plugin && length $plugin or do {
usage();
exit 1;
};
my $rev = shift(@argv) // 'master';
@argv == 0 or do {
usage();
exit 1;
};
my $script_dir = abs_path(dirname($0));
my $default_guix_repo = abs_path(File::Spec->catdir($script_dir, '..'));
my $default_tribes_repo = abs_path(File::Spec->catdir($default_guix_repo, '..', 'tribes'));
my $guix_repo = $opts{guix_repo} ? abs_path($opts{guix_repo}) : $default_guix_repo;
my $tribes_repo = $opts{tribes_repo} ? abs_path($opts{tribes_repo}) : $default_tribes_repo;
my $plugin_repo =
$opts{plugin_repo}
? abs_path($opts{plugin_repo})
: abs_path(File::Spec->catdir($guix_repo, '..', "tribes-plugin-$plugin"));
my $plugin_file =
$opts{plugin_file}
? abs_path($opts{plugin_file})
: File::Spec->catfile($guix_repo, 'tribes', 'plugins', "$plugin.scm");
my $source_file = File::Spec->catfile($guix_repo, 'tribes', 'packages', 'source.scm');
my $plugin_package_name = "tribes-plugin-$plugin";
-d File::Spec->catdir($plugin_repo, '.git') or fail("Plugin repo not found: $plugin_repo");
-d File::Spec->catdir($tribes_repo, '.git') or fail("Tribes repo not found: $tribes_repo");
-f $plugin_file or fail("Plugin file not found: $plugin_file");
-f $source_file or fail("guix-tribes source file not found: $source_file");
require_tool($_) for qw(env git rsync ssh tar perl);
my ($status, $commit_output) = run_capture('git', '-C', $plugin_repo, 'rev-parse', "$rev\^\{commit\}");
$status == 0 or fail(trim($commit_output));
my $commit = trim($commit_output);
my $tribes_rev = $opts{tribes_rev};
if (!defined $tribes_rev || $tribes_rev eq '') {
my $source_text = read_file($source_file);
$source_text =~ /\(define %tribes-commit\s+"([^"]+)"\)/
or fail("Failed to resolve %tribes-commit from $source_file");
$tribes_rev = $1;
}
($status, my $host_commit_output) =
run_capture('git', '-C', $tribes_repo, 'rev-parse', "$tribes_rev\^\{commit\}");
$status == 0 or fail(trim($host_commit_output));
my $host_commit = trim($host_commit_output);
$local_tmp = tempdir('plugin-pin.XXXXXX', TMPDIR => 1, CLEANUP => 0);
END {
if (defined $remote_tmp && $remote_tmp ne '') {
system('ssh', $opts{pguix_host}, "rm -rf '$remote_tmp'");
}
if (defined $local_tmp && $local_tmp ne '' && -d $local_tmp) {
system('rm', '-rf', $local_tmp);
}
}
my $plugin_source_dir = File::Spec->catdir($local_tmp, 'plugin-source');
my $tribes_source_dir = File::Spec->catdir($local_tmp, 'tribes-source');
mkdir $plugin_source_dir or fail("Failed to create $plugin_source_dir: $!");
mkdir $tribes_source_dir or fail("Failed to create $tribes_source_dir: $!");
my $plugin_tar = File::Spec->catfile($local_tmp, 'plugin-source.tar');
my $tribes_tar = File::Spec->catfile($local_tmp, 'tribes-source.tar');
run_checked('git', '-C', $plugin_repo, 'archive', '--output', $plugin_tar, $commit);
run_checked('git', '-C', $tribes_repo, 'archive', '--output', $tribes_tar, $host_commit);
run_checked('tar', '-xf', $plugin_tar, '-C', $plugin_source_dir);
run_checked('tar', '-xf', $tribes_tar, '-C', $tribes_source_dir);
my $manifest_file = File::Spec->catfile($plugin_source_dir, 'manifest.json');
-f $manifest_file or fail("Plugin manifest not found at $manifest_file");
my $manifest = decode_json(read_file($manifest_file));
for my $key (qw(name version provides requires)) {
exists $manifest->{$key} or fail("manifest missing required key: $key");
}
ref($manifest->{provides}) eq 'ARRAY'
&& !grep { ref($_) || !defined($_) } @{ $manifest->{provides} }
or fail('manifest provides must be a list of strings');
ref($manifest->{requires}) eq 'ARRAY'
&& !grep { ref($_) || !defined($_) } @{ $manifest->{requires} }
or fail('manifest requires must be a list of strings');
my $plugin_name = $manifest->{name};
my $version = $manifest->{version};
my $provides_joined = join("\037", @{ $manifest->{provides} });
my $requires_joined = join("\037", @{ $manifest->{requires} });
$plugin_name eq $plugin or fail("Plugin manifest name mismatch: expected $plugin, got $plugin_name");
($status, my $remote_tmp_output) = run_capture('ssh', $opts{pguix_host}, 'mktemp -d /tmp/plugin-pin.XXXXXX');
$status == 0 or fail(trim($remote_tmp_output));
$remote_tmp = trim($remote_tmp_output);
run_checked('rsync', '-az', '--delete', '--exclude', '.git', "$guix_repo/", "$opts{pguix_host}:$remote_tmp/guix-tribes/");
run_checked('rsync', '-az', '--delete', "$plugin_source_dir/", "$opts{pguix_host}:$remote_tmp/plugin-source/");
run_checked('rsync', '-az', '--delete', "$tribes_source_dir/", "$opts{pguix_host}:$remote_tmp/tribes-source/");
($status, my $source_hash_output) =
run_capture('ssh', $opts{pguix_host}, "guix hash -rx '$remote_tmp/plugin-source'");
$status == 0 or fail(trim($source_hash_output));
my $source_hash = trim($source_hash_output);
$source_hash =~ tr/\r//d;
sub remote_run_scheme {
my ($name, $body) = @_;
my ($fh, $local_path) = tempfile("$name.XXXXXX", DIR => $local_tmp, SUFFIX => '.scm');
print {$fh} $body or fail("Failed to write $local_path: $!");
close $fh or fail("Failed to close $local_path: $!");
run_checked('rsync', '-az', $local_path, "$opts{pguix_host}:$remote_tmp/$name.scm");
my ($exit, $output) =
run_capture('ssh', $opts{pguix_host}, "guix build -L '$remote_tmp/guix-tribes' -f '$remote_tmp/$name.scm' --no-grafts 2>&1");
return $output;
}
sub extract_hash {
my ($output) = @_;
my $hash;
for my $line (split /\n/, $output) {
if ($line =~ /\b(?:got|actual hash):\s*([0-9a-z]{52})/) {
$hash = $1;
}
}
defined $hash or fail("Failed to extract hash from build output.");
return $hash;
}
my $dummy_hash = '0' x 52;
my $host_setup_gexp = <<"EOF";
#~(begin
(let ((host-root (string-append work "/tribes")))
(when (file-exists? host-root)
(delete-file-recursively host-root))
(copy-recursively #+(local-file "$remote_tmp/tribes-source" #:recursive? #t)
host-root
#:follow-symlinks? #t)
(invoke "chmod" "-R" "u+w" host-root)))
EOF
my $mix_output = remote_run_scheme(
'mix-deps',
<<"EOF"
(use-modules (guix gexp) (tribes packages mix))
(fetch-mix-deps
(local-file "$remote_tmp/plugin-source" #:recursive? #t)
#:name "$plugin_package_name-mix-deps"
#:version "$version"
#:sha256 "$dummy_hash"
#:setup-gexp $host_setup_gexp)
EOF
);
my $mix_hash = extract_hash($mix_output);
my $npm_hash = '';
if (-f File::Spec->catfile($plugin_source_dir, 'assets', 'package-lock.json')) {
my $npm_output = remote_run_scheme(
'npm-deps',
<<"EOF"
(use-modules (guix gexp) (tribes packages mix))
(fetch-npm-deps
(local-file "$remote_tmp/plugin-source" #:recursive? #t)
#:name "$plugin_package_name-npm-deps"
#:version "$version"
#:sha256 "$dummy_hash"
#:assets-dir "assets"
#:setup-gexp $host_setup_gexp)
EOF
);
$npm_hash = extract_hash($npm_output);
}
my $text = read_file($plugin_file);
my @candidates;
for my $candidate ($plugin, ($plugin =~ tr/_/-/r)) {
push @candidates, $candidate unless grep { $_ eq $candidate } @candidates;
}
my ($symbol_base) =
grep { $text =~ /\(define %\Q$_\E-commit\s+"[^"]+"\)/ } @candidates;
defined $symbol_base
or fail("failed to locate plugin symbol prefix for '$plugin' in $plugin_file");
replace_once(
\$text,
qr/\(define %\Q$symbol_base\E-commit\s+"[^"]+"\)/,
qq((define %$symbol_base-commit\n "$commit")),
"%$symbol_base-commit",
);
replace_once(
\$text,
qr/\(git-version "[^"]+" %\Q$symbol_base\E-revision %\Q$symbol_base\E-commit\)/,
qq((git-version "$version" %$symbol_base-revision %$symbol_base-commit)),
"%$symbol_base-version",
);
replace_once(
\$text,
qr/\(define %\Q$symbol_base\E-source-sha256\s+"[^"]+"\)/,
qq((define %$symbol_base-source-sha256\n "$source_hash")),
"%$symbol_base-source-sha256",
);
replace_once(
\$text,
qr/\(define %\Q$symbol_base\E-mix-deps-sha256\s+"[^"]+"\)/,
qq((define %$symbol_base-mix-deps-sha256\n "$mix_hash")),
"%$symbol_base-mix-deps-sha256",
);
my $npm_replacement =
$npm_hash ne ''
? qq((define %$symbol_base-npm-deps-sha256\n "$npm_hash"))
: qq((define %$symbol_base-npm-deps-sha256\n #f));
replace_once(
\$text,
qr/\(define %\Q$symbol_base\E-npm-deps-sha256\s+(?:"[^"]+"|#f)\)/,
$npm_replacement,
"%$symbol_base-npm-deps-sha256",
);
update_plugin_definition_header(\$text, $plugin_name, $plugin_package_name, $version);
replace_once(
\$text,
qr/\(provides '\([^)]*\)\)/,
"(provides '" . scheme_string_list(@{ $manifest->{provides} }) . ')',
'plugin provides',
);
replace_once(
\$text,
qr/\(requires '\([^)]*\)\)/,
"(requires '" . scheme_string_list(@{ $manifest->{requires} }) . ')',
'plugin requires',
);
write_file($plugin_file, $text);
print "Updated $plugin_file\n";
print "plugin: $plugin\n";
print "commit: $commit\n";
print "host tribes commit: $host_commit\n";
print "version: $version\n";
print "source sha256: $source_hash\n";
print "mix deps sha256: $mix_hash\n";
print "npm deps sha256: $npm_hash\n" if $npm_hash ne '';
print 'provides: ', join(',', @{ $manifest->{provides} }), "\n";
print 'requires: ', join(',', @{ $manifest->{requires} }), "\n";
steffen-EF99DAC3.key
+14
View File
@@ -0,0 +1,14 @@
-----BEGIN PGP PUBLIC KEY BLOCK-----
mDMEacubSBYJKwYBBAHaRw8BAQdAlGsOYDcpiGOfRwmjDEB0KEp9XNjfBAcR3TOI
GI+jIhm0LlN0ZWZmZW4gQmV5ZXIgKFRyaWJlcykgPHN0ZWZmZW5AdHJpYmUtb25l
Lm9yZz6IlgQTFgoAPhYhBGaIkVPFHEYTpJOlJS8N/RTvmdrDBQJpy5tIAhsDBQkJ
ZgGABQsJCAcCBhUKCQgLAgQWAgMBAh4BAheAAAoJEC8N/RTvmdrD04QBAKfQTru5
1kk0YxnFLpp/wWmsJ8YX28odRnlteiCdRx/oAP9Td+henY2KTB1iGRRYIg32VhZv
kD6o1an/4Fss1AhEBLg4BGnLm0gSCisGAQQBl1UBBQEBB0BoCoPuntEJY9J3orzk
ZclASyEzJPez7PX+IC8XYbXXLQMBCAeIfgQYFgoAJhYhBGaIkVPFHEYTpJOlJS8N
/RTvmdrDBQJpy5tIAhsMBQkJZgGAAAoJEC8N/RTvmdrDXdkBANpXjZ7YTVd7N875
+isrMvslgNdBE/ohyaGfbJNERghkAQCSxeNUona8KmbH3+sFI4vz6Pl4HQtRhJ+m
8ujbi8xFCw==
=KoLi
-----END PGP PUBLIC KEY BLOCK-----
tests/tribes-deploy-current-guix.scm
-108
View File
@@ -1,108 +0,0 @@
(define-module (tests tribes-deploy-current-guix)
#:use-module (ice-9 textual-ports)
#:use-module (guix build utils)
#:use-module (srfi srfi-64)
#:use-module (tribes deploy current-guix)
#:export (run-tests))
(define *fixture-counter* 0)
(define (delete-directory-if-present path)
(when (false-if-exception (lstat path))
(delete-file-recursively path)))
(define (fresh-root)
(set! *fixture-counter* (+ *fixture-counter* 1))
(let ((root (string-append "/tmp/tribes-current-guix-test-"
(number->string *fixture-counter*))))
(delete-directory-if-present root)
(mkdir-p root)
root))
(define (write-executable path text)
(mkdir-p (dirname path))
(call-with-output-file path
(lambda (port)
(display text port)))
(chmod path #o555)
path)
(define-syntax-rule (with-env ((name value) ...) body ...)
(let ((saved (list (cons name (getenv name)) ...)))
(dynamic-wind
(lambda ()
(if value (setenv name value) (unsetenv name)) ...)
(lambda () body ...)
(lambda ()
(for-each
(lambda (entry)
(let ((key (car entry))
(saved-value (cdr entry)))
(if saved-value
(setenv key saved-value)
(unsetenv key))))
saved)))))
(define (run-tests)
(test-begin "tribes-deploy-current-guix")
(let* ((root (fresh-root))
(home (string-append root "/home"))
(pulled (string-append home "/.config/guix/current/bin/guix")))
(write-executable pulled "#!/bin/sh\nexit 0\n")
(with-env (("HOME" home)
("PATH" "/no-such-path"))
(test-equal "current-guix-binary prefers pulled profile"
pulled
(current-guix-binary))))
(let* ((root (fresh-root))
(home (string-append root "/home"))
(bin (string-append root "/bin"))
(path-guix (string-append bin "/guix"))
(expected-guix (if (file-exists? system-guix-binary)
system-guix-binary
path-guix)))
(write-executable path-guix "#!/bin/sh\nexit 0\n")
(with-env (("HOME" home)
("PATH" bin))
(test-equal "current-guix-binary falls back after pulled profile"
expected-guix
(current-guix-binary))))
(with-env (("GUILE_LOAD_PATH" "bad-load")
("GUILE_LOAD_COMPILED_PATH" "bad-compiled")
("GUIX_PACKAGE_PATH" "bad-package"))
(let ((inside
(call-with-clean-guix-environment
(lambda ()
(list (getenv "GUILE_LOAD_PATH")
(getenv "GUILE_LOAD_COMPILED_PATH")
(getenv "GUIX_PACKAGE_PATH"))))))
(test-equal "clean Guix environment unsets wrapper paths"
'(#f #f #f)
inside)
(test-equal "clean Guix environment restores wrapper paths"
'("bad-load" "bad-compiled" "bad-package")
(list (getenv "GUILE_LOAD_PATH")
(getenv "GUILE_LOAD_COMPILED_PATH")
(getenv "GUIX_PACKAGE_PATH")))))
(let* ((root (fresh-root))
(profile (string-append root "/.config/guix/current"))
(guix (string-append profile "/bin/guix"))
(module (string-append profile
"/share/guile/site/3.0/tribes/example.scm")))
(write-executable guix "#!/bin/sh\nexit 0\n")
(mkdir-p (dirname module))
(call-with-output-file module
(lambda (port) (display ";; fixture\n" port)))
(with-env (("HOME" root)
("PATH" (string-append profile "/bin")))
(test-equal "current-guix-module-file resolves under selected profile"
module
(current-guix-module-file "tribes/example.scm"))))
(test-end "tribes-deploy-current-guix"))
(run-tests)
tests/tribes-deploy-executor.scm
+4 -114
View File
@@ -1,36 +1,8 @@
(define-module (tests tribes-deploy-executor)
#:use-module (srfi srfi-64)
#:use-module (tribes deploy executor)
#:use-module (tribes deploy plan)
#:export (run-tests))
(define valid-signer
'(("id" . "signer-1")
("fingerprint" . "0123456789ABCDEF0123456789ABCDEF01234567")
("enabled" . #t)))
(define valid-channel
'(("id" . "guix-tribes")
("channel_id" . "guix-tribes")
("url" . "https://git.example.test/guix-tribes.git")
("branch" . "main")
("commit" . "abc123")
("position" . 10)
("allowed_signer_ids" . ("signer-1"))
("introduction" . (("commit" . "intro123")
("fingerprint" . "0123456789ABCDEF0123456789ABCDEF01234567")))))
(define valid-target
`(("trusted_signers" . (,valid-signer))
("channels" . (,valid-channel))
("plugins" . ((("plugin_name" . "aether")
("channel_id" . "guix-tribes")
("enabled" . #t))))))
(define (error-code result)
(let ((error (json-ref result "error")))
(and (json-object? error) (json-ref error "code"))))
(define (run-tests)
(test-begin "tribes-deploy-executor")
@@ -38,14 +10,16 @@
'()
(deployment-request-plugins
'(("schemaVersion" . "1")
("action" . "apply"))))
("action" . "apply")
("deploymentProfile" . (("schemaVersion" . "1"))))))
(test-equal "deployment request plugins preserve names"
'("aether")
(deployment-request-plugins
'(("schemaVersion" . "1")
("action" . "apply")
("plugins" . ("aether")))))
("deploymentProfile" . (("schemaVersion" . "1")
("plugins" . ("aether")))))))
(test-equal "host config plugins are updated in tribes block"
'(("schemaVersion" . "1")
@@ -59,88 +33,4 @@
("edge" . (("certificateName" . "tribes"))))
'("aether")))
(test-equal "system target plugin names include only enabled plugins"
'("aether")
(system-target-plugin-names
'(("plugins" . ((("plugin_name" . "aether")
("enabled" . #t))
(("plugin_name" . "disabled")
("enabled" . #f)))))))
(test-assert "legacy plans without resolved channel metadata still pull"
(plan-requires-pull? '(("plan_hash" . "legacy"))))
(test-assert "plans with an explicit empty channel delta skip pull"
(not (plan-requires-pull?
'(("plan_hash" . "plugin-only")
("resolved_channels" . #())))))
(test-assert "plans with resolved channel changes still pull"
(plan-requires-pull?
'(("plan_hash" . "channel-update")
("resolved_channels" . #((("name" . "guix-tribes")))))))
(test-equal "resolve-target emits channel-aware plugin package refs"
'("aether")
(let* ((plan (resolve-target valid-target))
(hash-value (json-ref plan "plan_hash"))
(resolved-plugins
(let ((plugins (json-ref plan "resolved_plugins")))
(if (vector? plugins) (vector->list plugins) plugins)))
(aether (and (pair? resolved-plugins) (car resolved-plugins)))
(package-ref (and (json-object? aether) (json-ref aether "package_ref"))))
(test-assert "plan hash is present" (string? hash-value))
(test-equal "channel commit is propagated to package ref"
"abc123"
(json-ref package-ref "commit"))
(let* ((channels (json-ref plan "resolved_channels"))
(channel (and (vector? channels) (> (vector-length channels) 0)
(vector-ref channels 0))))
(test-equal "channel branch is preserved in resolved plan"
"main"
(json-ref channel "branch"))
(test-equal "channel introduction is preserved in resolved plan"
"intro123"
(json-ref (json-ref channel "introduction") "commit")))
(test-equal "registry version is used"
"0.1.0"
(json-ref package-ref "version"))
(plan-plugins plan)))
(test-equal "resolve-target rejects duplicate plugin requests"
"duplicate_plugin"
(error-code
(resolve-target
`(("trusted_signers" . (,valid-signer))
("channels" . (,valid-channel))
("plugins" . ((("plugin_name" . "aether") ("enabled" . #t))
(("plugin_name" . "aether") ("enabled" . #t))))))))
(test-equal "resolve-target rejects unknown plugins"
"manifest_invalid"
(error-code
(resolve-target
`(("trusted_signers" . (,valid-signer))
("channels" . (,valid-channel))
("plugins" . ((("plugin_name" . "missing-plugin")
("channel_id" . "guix-tribes")
("enabled" . #t))))))))
(test-equal "resolve-target rejects untrusted channels"
"channel_untrusted"
(error-code
(resolve-target
'(("trusted_signers" . ())
("channels" . ((("id" . "guix-tribes")
("channel_id" . "guix-tribes")
("url" . "https://git.example.test/guix-tribes.git")
("commit" . "abc123")
("position" . 10)
("allowed_signer_ids" . ("signer-1"))
("introduction" . (("commit" . "intro123")
("fingerprint" . "0123456789ABCDEF0123456789ABCDEF01234567"))))))
("plugins" . ((("plugin_name" . "aether")
("channel_id" . "guix-tribes")
("enabled" . #t))))))))
(test-end "tribes-deploy-executor"))
tests/tribes-deploy-operations.scm
-465
View File
@@ -1,465 +0,0 @@
(define-module (tests tribes-deploy-operations)
#:use-module (ice-9 ftw)
#:use-module (ice-9 textual-ports)
#:use-module (guix build utils)
#:use-module (json)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-13)
#:use-module (srfi srfi-64)
#:use-module (tribes deploy config)
#:use-module (tribes deploy executor)
#:use-module (tribes deploy guix-helper)
#:use-module (tribes deploy json)
#:use-module (tribes deploy operations)
#:use-module (tribes deploy plan)
#:use-module (tribes deploy state)
#:export (run-tests))
(define *fixture-counter* 0)
(define plan-a
'(("plan_hash" . "plan-a")
("resolved_plugins" . ((("name" . "aether"))))))
(define plan-b
'(("plan_hash" . "plan-b")
("resolved_plugins" . ((("name" . "aether"))))))
(define plan-without-channel-delta
'(("plan_hash" . "plan-without-channel-delta")
("resolved_channels" . #())
("resolved_plugins" . ((("name" . "supertest"))))))
(define plan-with-channel-delta
'(("plan_hash" . "plan-with-channel-delta")
("resolved_channels" . #((("channel_id" . "guix-tribes")
("url" . "https://git.example.test/guix-tribes.git")
("branch" . "dev")
("commit" . "abc123")
("introduction" . (("commit" . "intro123")
("fingerprint" . "0123456789ABCDEF0123456789ABCDEF01234567")))
("position" . 0))))
("resolved_plugins" . ((("name" . "supertest"))))))
(define (delete-if-present path)
(when (false-if-exception (lstat path))
(delete-file path)))
(define (delete-directory-if-present path)
(when (false-if-exception (lstat path))
(delete-file-recursively path)))
(define (ensure-directory path) (mkdir-p path))
(define (fresh-root)
(set! *fixture-counter* (+ *fixture-counter* 1))
(let ((root (string-append "/tmp/tribes-operations-test-"
(number->string *fixture-counter*))))
(delete-directory-if-present root)
(ensure-directory root)
root))
(define (helper-success-result payload)
((@@ (tribes deploy guix-helper) helper-success) payload '()))
(define (helper-failure-result code message)
((@@ (tribes deploy guix-helper) helper-failure) code message '() '()))
;; Build a fake helper backend that imitates the broker's view of the world.
;; The build step writes a fake store-path symlink so the broker can
;; canonicalize the GC root link the way the real helper would.
(define* (make-fake-helper fixture #:key (diverge-running? #f))
(let ((build-count 0)
(pull-count 0)
(switch-count 0)
(store-directory (assq-ref fixture 'store-directory))
(profiles-directory (assq-ref fixture 'profiles-directory))
(system-profile-link (assq-ref fixture 'system-profile-link))
(current-system-link (assq-ref fixture 'current-system-link)))
(let ((backend
(make-helper-backend
(lambda (_cfg _on-frame)
(set! pull-count (+ pull-count 1))
(helper-success-result
'(("event" . "done") ("phase" . "pulling"))))
(lambda (_cfg root-link _on-frame)
(set! build-count (+ build-count 1))
(let ((store-path
(string-append store-directory "/system-"
(number->string build-count))))
(ensure-directory store-path)
(delete-if-present root-link)
(symlink store-path root-link)
(helper-success-result
`(("event" . "done")
("store_path" . ,store-path)))))
(lambda (_cfg generation-number _on-frame)
(let* ((generation-link
(string-append profiles-directory
"/system-"
(number->string generation-number)
"-link"))
(store-path (false-if-exception
(canonicalize-path generation-link))))
(cond
((and store-path (file-exists? store-path))
(set! switch-count (+ switch-count 1))
(delete-if-present system-profile-link)
(symlink generation-link system-profile-link)
(unless diverge-running?
(delete-if-present current-system-link)
(symlink generation-link current-system-link))
(helper-success-result
`(("event" . "done")
("generation_number" . ,generation-number))))
(else
(helper-failure-result
"switch_failed"
"fake helper: missing store path"))))))))
(values backend
(lambda () build-count)
(lambda () pull-count)
(lambda () switch-count)))))
(define (write-json-file path payload)
(call-with-output-file path
(lambda (port)
(scm->json (json-ready payload) port))))
(define (read-text-file path)
(call-with-input-file path get-string-all))
(define (make-fixture)
(let* ((root (fresh-root))
(deploy-directory (string-append root "/deploy"))
(etc-directory (string-append root "/etc/tribes"))
(profiles-directory (string-append root "/profiles"))
(store-directory (string-append root "/store"))
(current-system-directory (string-append root "/current-system"))
(host-config-file (string-append etc-directory "/host-config.json"))
(channels-file (string-append etc-directory "/channels.scm"))
(current-config-file (string-append current-system-directory
"/configuration.scm"))
(current-system-link (string-append root "/run-current-system"))
(system-profile-link (string-append profiles-directory "/system")))
(ensure-directory deploy-directory)
(ensure-directory etc-directory)
(ensure-directory profiles-directory)
(ensure-directory store-directory)
(ensure-directory current-system-directory)
(write-json-file host-config-file
'(("schemaVersion" . "1")
("tribes" . (("host" . "example.test")
("plugins" . ())))))
(call-with-output-file channels-file
(lambda (port) (display "()\n" port)))
(call-with-output-file current-config-file
(lambda (port) (display ";; test config\n" port)))
`((root . ,root)
(deploy-directory . ,deploy-directory)
(host-config-file . ,host-config-file)
(channels-file . ,channels-file)
(current-config-file . ,current-config-file)
(current-system-link . ,current-system-link)
(system-profile-link . ,system-profile-link)
(system-profile-directory . ,profiles-directory)
(profiles-directory . ,profiles-directory)
(store-directory . ,store-directory))))
(define (fixture->config fixture)
(deploy-config
(deploy-directory (assq-ref fixture 'deploy-directory))
(host-config-file (assq-ref fixture 'host-config-file))
(channels-file (assq-ref fixture 'channels-file))
(current-config-file (assq-ref fixture 'current-config-file))
(current-system-link (assq-ref fixture 'current-system-link))
(system-profile-link (assq-ref fixture 'system-profile-link))
(system-profile-directory (assq-ref fixture 'system-profile-directory))
(helper-binary "fake-helper-not-used")))
(define (no-frame _) #t)
(define rollback-herd-command
(@@ (tribes deploy operations) rollback-herd-command))
(define (write-executable path content)
(call-with-output-file path
(lambda (port) (display content port)))
(chmod path #o755))
(define (with-fake-rollback-herd fixture thunk)
(let* ((herd (string-append (assq-ref fixture 'root) "/fake-herd"))
(log-file (string-append (assq-ref fixture 'root) "/herd.log")))
(write-executable
herd
(string-append "#!/bin/sh\n"
"printf '%s\\n' \"$*\" >> " log-file "\n"
"exit 0\n"))
(parameterize ((rollback-herd-command herd))
(thunk))))
(define (find-generation-by-plan-hash generations plan-hash)
(find (lambda (generation)
(equal? (json-ref generation "plan_hash") plan-hash))
generations))
(define (seed-profile-generation! fixture generation-number store-name)
(let* ((store-path (string-append (assq-ref fixture 'store-directory)
"/" store-name))
(generation-link (string-append (assq-ref fixture 'profiles-directory)
"/system-"
(number->string generation-number)
"-link")))
(ensure-directory store-path)
(delete-if-present generation-link)
(symlink store-path generation-link)
store-path))
(define (run-tests)
(test-begin "tribes-deploy-operations")
(let* ((fixture (make-fixture))
(state (make-state-store (fixture->config fixture))))
(call-with-values (lambda () (make-fake-helper fixture))
(lambda (helper get-builds get-pulls get-switches)
(let* ((prepare-1 (prepare-plugins! state helper
(plan-plugins plan-a)
(plan-hash plan-a)
no-frame))
(prepare-2 (prepare-plugins! state helper
(plan-plugins plan-a)
(plan-hash plan-a)
no-frame)))
(test-equal "prepare returns ready"
"ready"
(json-ref prepare-1 "status"))
(test-equal "prepare is idempotent on plan_hash"
1 (get-builds))
(test-equal "idempotent prepare reuses generation number"
(json-ref prepare-1 "generation_number")
(json-ref prepare-2 "generation_number"))
(test-equal "prepare does not switch generations"
0 (get-switches))
(let* ((commit (commit-plan! state helper (plan-hash plan-a)
no-frame))
(generations (state-store-read-generations state))
(generation-a (find-generation-by-plan-hash
generations (plan-hash plan-a))))
(test-equal "commit switches after prepare"
"healthy" (json-ref commit "status"))
(test-equal "commit triggers one switch"
1 (get-switches))
(test-equal "active generation matches prepared store path"
(json-ref prepare-1 "store_path")
(state-store-running-system-path state))
(test-equal "generation is marked active after commit"
"active" (json-ref generation-a "status")))))))
(let* ((fixture (make-fixture))
(state (make-state-store (fixture->config fixture))))
(call-with-values (lambda () (make-fake-helper fixture))
(lambda (helper get-builds get-pulls get-switches)
(let ((prepared (prepare-plugins! state helper
(plan-plugins plan-without-channel-delta)
(plan-hash plan-without-channel-delta)
no-frame
#:pull-required?
(plan-requires-pull?
plan-without-channel-delta))))
(test-equal "prepare skips pull for plans with no channel delta"
"ready"
(json-ref prepared "status"))
(test-equal "no-channel-delta prepare does not pull"
0 (get-pulls))
(test-equal "no-channel-delta prepare still builds"
1 (get-builds))
(test-equal "no-channel-delta prepare does not switch"
0 (get-switches))))))
(let* ((fixture (make-fixture))
(state (make-state-store (fixture->config fixture)))
(channels-file (assq-ref fixture 'channels-file)))
(call-with-output-file channels-file
(lambda (port)
(display "(list\n (channel\n (name 'guix)\n (url \"https://git.example.test/guix.git\")\n (branch \"master\")\n (commit \"guix-commit\")))\n" port)))
(call-with-values (lambda () (make-fake-helper fixture))
(lambda (helper get-builds get-pulls get-switches)
(let* ((_prepared (prepare-plugins! state helper
(plan-plugins plan-with-channel-delta)
(plan-hash plan-with-channel-delta)
no-frame
#:plan plan-with-channel-delta
#:pull-required?
(plan-requires-pull?
plan-with-channel-delta)))
(channels-text (read-text-file channels-file)))
(test-assert "prepare preserves base guix channel"
(string-contains channels-text "guix-commit"))
(test-assert "prepare writes rollout channel branch"
(string-contains channels-text "(branch \"dev\")"))
(test-assert "prepare writes rollout channel commit"
(string-contains channels-text "(commit \"abc123\")"))
(test-assert "prepare writes rollout channel introduction"
(string-contains channels-text "intro123"))
(test-equal "channel-delta prepare pulls"
1 (get-pulls))))))
(let* ((fixture (make-fixture))
(state (make-state-store (fixture->config fixture))))
(with-fake-rollback-herd
fixture
(lambda ()
(call-with-values (lambda () (make-fake-helper fixture))
(lambda (helper get-builds get-pulls get-switches)
(let* ((prepared-a (prepare-plugins! state helper (plan-plugins plan-a)
(plan-hash plan-a) no-frame))
(_ca (commit-plan! state helper (plan-hash plan-a) no-frame))
(_pb (prepare-plugins! state helper (plan-plugins plan-b)
(plan-hash plan-b) no-frame))
(_cb (commit-plan! state helper (plan-hash plan-b) no-frame))
(rollback (rollback-store-path! state helper
(json-ref prepared-a "store_path")
#f no-frame)))
(test-equal "direct rollback succeeds for retained generation"
"healthy" (json-ref rollback "status"))
(test-equal "direct rollback does not rebuild"
2 (get-builds))
(test-equal "direct rollback performs a third switch"
3 (get-switches))
(test-equal "rolled back system points at prior store path"
(json-ref prepared-a "store_path")
(state-store-running-system-path state))))))))
(let* ((fixture (make-fixture))
(state (make-state-store (fixture->config fixture)))
(baseline-store-path (seed-profile-generation! fixture 1 "baseline-system"))
(system-profile-link (assq-ref fixture 'system-profile-link))
(current-system-link (assq-ref fixture 'current-system-link)))
(delete-if-present system-profile-link)
(symlink (string-append (assq-ref fixture 'profiles-directory)
"/system-1-link")
system-profile-link)
(delete-if-present current-system-link)
(symlink (string-append (assq-ref fixture 'profiles-directory)
"/system-1-link")
current-system-link)
(with-fake-rollback-herd
fixture
(lambda ()
(call-with-values (lambda () (make-fake-helper fixture))
(lambda (helper get-builds get-pulls get-switches)
(let* ((_prepared (prepare-plugins! state helper (plan-plugins plan-a)
(plan-hash plan-a) no-frame))
(_commit (commit-plan! state helper (plan-hash plan-a) no-frame))
(rollback (rollback-store-path! state helper baseline-store-path
#f no-frame)))
(test-equal "rollback can switch to an unrecorded Guix profile generation"
"healthy" (json-ref rollback "status"))
(test-equal "profile-generation rollback does not rebuild"
1 (get-builds))
(test-equal "profile-generation rollback performs the second switch"
2 (get-switches))
(test-equal "profile-generation rollback returns to the baseline store path"
baseline-store-path
(state-store-running-system-path state))))))))
(let* ((fixture (make-fixture))
(state (make-state-store (fixture->config fixture))))
(with-fake-rollback-herd
fixture
(lambda ()
(call-with-values (lambda () (make-fake-helper fixture))
(lambda (helper get-builds get-pulls get-switches)
(let* ((prepared-a (prepare-plugins! state helper (plan-plugins plan-a)
(plan-hash plan-a) no-frame))
(_ca (commit-plan! state helper (plan-hash plan-a) no-frame))
(_pb (prepare-plugins! state helper (plan-plugins plan-b)
(plan-hash plan-b) no-frame))
(_cb (commit-plan! state helper (plan-hash plan-b) no-frame))
(_drop (delete-directory-if-present
(json-ref prepared-a "store_path")))
(rollback (rollback-store-path! state helper
(json-ref prepared-a "store_path")
plan-a no-frame))
(generation-a (find-generation-by-plan-hash
(state-store-read-generations state)
(plan-hash plan-a))))
(test-equal "rollback rebuilds from plan when store path is gone"
"healthy" (json-ref rollback "status"))
(test-equal "rebuild fallback performs a third build"
3 (get-builds))
(test-equal "rebuild fallback performs a third switch"
3 (get-switches))
(test-assert "rebuild fallback records a new active generation"
(> (json-ref generation-a "generation_number") 1))
(test-assert "rebuild fallback activates a new store path"
(not (string=? (state-store-running-system-path state)
(json-ref prepared-a "store_path"))))))))))
(let* ((fixture (make-fixture))
(state (make-state-store (fixture->config fixture))))
(with-fake-rollback-herd
fixture
(lambda ()
(call-with-values (lambda () (make-fake-helper fixture))
(lambda (helper get-builds get-pulls get-switches)
(let* ((prepared-a (prepare-plugins! state helper (plan-plugins plan-a)
(plan-hash plan-a) no-frame))
(_ca (commit-plan! state helper (plan-hash plan-a) no-frame))
(_drop (delete-directory-if-present
(json-ref prepared-a "store_path")))
(rollback (rollback-store-path! state helper
(json-ref prepared-a "store_path")
#f no-frame)))
(test-equal "rollback without a retained store path or plan is infeasible"
"rollback_infeasible" (json-ref rollback "code"))))))))
(let* ((fixture (make-fixture))
(state (make-state-store (fixture->config fixture)))
(current-system-link (assq-ref fixture 'current-system-link))
(old-running (string-append (assq-ref fixture 'store-directory)
"/running-before-commit")))
(ensure-directory old-running)
(delete-if-present current-system-link)
(symlink old-running current-system-link)
(call-with-values (lambda () (make-fake-helper fixture #:diverge-running? #t))
(lambda (helper get-builds get-pulls get-switches)
(let* ((prepared (prepare-plugins! state helper (plan-plugins plan-a)
(plan-hash plan-a) no-frame))
(commit (commit-plan! state helper (plan-hash plan-a) no-frame)))
(test-equal "commit reports selected store path even if running link lags"
(json-ref prepared "store_path")
(json-ref commit "store_path"))
(test-equal "commit exposes selected system separately"
(json-ref prepared "store_path")
(json-ref commit "selectedSystem"))
(test-equal "commit preserves divergent running system for diagnostics"
old-running
(json-ref commit "runningSystem"))))))
(call-with-values (lambda () (resolve-deployment '()))
(lambda (status payload)
(test-equal "resolve-deployment wraps successful plans with 200"
200 status)
(test-assert "resolve-deployment success response is ok"
(equal? (json-ref payload "ok") #t))
(test-assert "resolve-deployment success response contains a plan"
(json-object? (json-ref payload "plan")))
(test-assert "resolve-deployment success plan has a hash"
(string? (json-ref (json-ref payload "plan") "plan_hash")))))
(call-with-values
(lambda ()
(resolve-deployment
'(("plugins" . ((("plugin_name" . "aether") ("enabled" . #t))
(("plugin_name" . "aether") ("enabled" . #t)))))))
(lambda (status payload)
(test-equal "resolve-deployment returns 409 for explicit resolver errors"
409 status)
(test-assert "resolve-deployment conflict payload is an explicit resolver error"
(and (equal? (json-ref payload "ok") #f)
(json-object? (json-ref payload "error"))))))
(test-end "tribes-deploy-operations"))
(run-tests)
tests/tribes-diagnostics-system-generations.scm
-75
View File
@@ -1,75 +0,0 @@
(define-module (tests tribes-diagnostics-system-generations)
#:use-module (srfi srfi-13)
#:use-module (srfi srfi-64)
#:use-module (tribes diagnostics system-generations)
#:export (run-tests))
(define emit-json
(@@ (tribes diagnostics system-generations) emit-json))
(define system-reference-section
(@@ (tribes diagnostics system-generations) system-reference-section))
(define service-diff
(@@ (tribes diagnostics system-generations) service-diff))
(define path->store-item
(@@ (tribes diagnostics system-generations) path->store-item))
(define (json-ref object key)
(let ((entry (assoc key object)))
(and entry (cdr entry))))
(define (mkdir-if-missing path)
(unless (file-exists? path)
(mkdir path)))
(define (run-tests)
(test-begin "tribes-diagnostics-system-generations")
(test-equal "top-level store item is queryable"
"/gnu/store/00000000000000000000000000000000-example"
(path->store-item "/gnu/store/00000000000000000000000000000000-example"))
(test-equal "store subpath is not queried as a store item"
#f
(path->store-item "/gnu/store/00000000000000000000000000000000-system/profile"))
(let* ((root (string-append "/tmp/tribes-diagnostics-system-generations-"
(number->string (getpid))))
(old-system (string-append root "/old-system"))
(new-system (string-append root "/new-system"))
(old-profile (string-append old-system "/profile"))
(new-profile (string-append new-system "/profile")))
(mkdir-if-missing root)
(mkdir-if-missing old-system)
(mkdir-if-missing new-system)
(mkdir-if-missing old-profile)
(mkdir-if-missing new-profile)
(let* ((section (system-reference-section "profile" old-profile new-profile #t))
(direct (json-ref section "directReferences"))
(closure (json-ref section "fullClosure")))
(test-assert "non-store profile subpaths report that references were skipped"
(equal? (json-ref direct "skipped") #t))
(test-equal "non-store profile subpaths explain why direct refs were skipped"
"path is not a top-level Guix store item"
(json-ref direct "reason"))
(test-assert "non-store profile subpaths skip closure refs too"
(equal? (json-ref closure "skipped") #t))))
(let* ((service '(("name" . "console-font-tty1")
("provisions" . ("console-font-tty1"))
("requirements" . ())
("oneShot" . #t)
("autoStart" . #t)
("file" . "/gnu/store/00000000000000000000000000000000-console-font")))
(report `(("services" . ,(service-diff (list service) (list service)))))
(output (with-output-to-string
(lambda ()
(emit-json report #t)))))
(test-assert "pretty JSON handles unchanged service arrays"
(string-contains output "\"unchanged\"")))
(test-end "tribes-diagnostics-system-generations"))
(run-tests)
tests/tribes-system-node.scm
-69
View File
@@ -1,69 +0,0 @@
(define-module (tests tribes-system-node)
#:use-module (gnu services)
#:use-module (guix gexp)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-13)
#:use-module (srfi srfi-64)
#:use-module (tribes services tribes)
#:use-module (tribes services vinyl)
#:use-module (tribes system node)
#:export (run-tests))
(define node-module (resolve-module '(tribes system node)))
(define edge-cache-vcl-text (module-ref node-module 'edge-cache-vcl-text))
(define edge-cache-vcl (module-ref node-module 'edge-cache-vcl))
(define edge-services (module-ref node-module 'edge-services))
(define (contains? haystack needle)
(and (string-contains haystack needle) #t))
(define (run-tests)
(test-begin "tribes-system-node")
(let ((vcl (edge-cache-vcl-text (tribes-edge-configuration)
(tribes-configuration))))
(test-assert "edge cache backend uses short connect timeout"
(contains? vcl ".connect_timeout = 1s;"))
(test-assert "edge cache backend uses bounded first-byte timeout"
(contains? vcl ".first_byte_timeout = 5s;"))
(test-assert "edge cache retries only GET/HEAD 5xx backend responses"
(contains? vcl
"if ((bereq.method == \"GET\" || bereq.method == \"HEAD\") &&\n beresp.status >= 500 && beresp.status <= 599 &&\n bereq.retries < 5)"))
(test-assert "edge cache retries only GET/HEAD backend errors"
(contains? vcl
"sub vcl_backend_error {\n if ((bereq.method == \"GET\" || bereq.method == \"HEAD\") &&\n bereq.retries < 5)"))
(test-assert "edge cache does not cache exhausted 5xx responses"
(contains? vcl
"if (beresp.status >= 500 && beresp.status <= 599) {\n set beresp.uncacheable = true;\n set beresp.ttl = 0s;"))
(test-assert "edge cache keeps unsafe methods as pass-through"
(contains? vcl
"if (req.method != \"GET\" && req.method != \"HEAD\") {\n return (pass);"))
(let ((rendered (edge-cache-vcl (tribes-edge-configuration)
(tribes-configuration))))
(test-equal "edge cache renders expected VCL file name"
"tribes-edge-cache.vcl"
(plain-file-name rendered))
(test-equal "edge cache renders expected VCL file content"
vcl
(plain-file-content rendered))))
(let* ((config (tribes-node-configuration
(tribes (tribes-configuration
(host "example.invalid")))
(edge (tribes-edge-configuration
(certificate-email "ops@example.invalid")))))
(services (edge-services config))
(vinyl-service (find (lambda (service)
(eq? (service-kind service) vinyl-service-type))
services))
(edge-vinyl (find (lambda (config)
(string=? (vinyl-configuration-name config)
"tribes-edge"))
(service-value vinyl-service))))
(test-equal "edge vinyl permits five graceful retries"
'((max_retries . 5))
(vinyl-configuration-parameters edge-vinyl)))
(test-end "tribes-system-node"))
(run-tests)
tribes/config/system-facts.scm
-134
View File
@@ -1,134 +0,0 @@
(define-module (tribes config system-facts)
#:use-module (guix records)
#:use-module (srfi srfi-1)
#:export (tribes-system-facts
tribes-system-facts?
tribes-system-facts-host-name
tribes-system-facts-interface
tribes-system-facts-boot-mode
tribes-system-facts-bootloader-targets
tribes-system-facts-boot-partition-uuid
tribes-system-facts-boot-partition-file-system-type
tribes-system-facts-efi-partition-uuid
tribes-system-facts-efi-partition-file-system-type
tribes-system-facts-root-luks-uuid
tribes-system-facts-root-mapper-name
tribes-system-facts-root-file-system-type
tribes-system-facts-authorized-keys-file
tribes-system-facts-local-boot-key-file
tribes-system-facts-tang-port
tribes-system-facts-initrd-network-timeout-seconds
tribes-system-facts-enable-bbr?
json-scm->tribes-system-facts))
(define-record-type* <tribes-system-facts>
tribes-system-facts make-tribes-system-facts
tribes-system-facts?
(host-name tribes-system-facts-host-name)
(interface tribes-system-facts-interface)
(boot-mode tribes-system-facts-boot-mode
(default "bios"))
(bootloader-targets tribes-system-facts-bootloader-targets)
(boot-partition-uuid tribes-system-facts-boot-partition-uuid)
(boot-partition-file-system-type tribes-system-facts-boot-partition-file-system-type
(default "ext4"))
(efi-partition-uuid tribes-system-facts-efi-partition-uuid
(default #f))
(efi-partition-file-system-type tribes-system-facts-efi-partition-file-system-type
(default "vfat"))
(root-luks-uuid tribes-system-facts-root-luks-uuid)
(root-mapper-name tribes-system-facts-root-mapper-name
(default "cryptroot"))
(root-file-system-type tribes-system-facts-root-file-system-type
(default "ext4"))
(authorized-keys-file tribes-system-facts-authorized-keys-file
(default "/etc/tribes/root-authorized_keys"))
(local-boot-key-file tribes-system-facts-local-boot-key-file
(default "/etc/legion/nbde/local-boot.key"))
(tang-port tribes-system-facts-tang-port
(default 7654))
(initrd-network-timeout-seconds
tribes-system-facts-initrd-network-timeout-seconds
(default 20))
(enable-bbr? tribes-system-facts-enable-bbr?
(default #t)))
(define (json-object? value)
(and (list? value) (every pair? value)))
(define (json-ref object key)
(and (json-object? object)
(let ((entry (assoc key object)))
(and entry (cdr entry)))))
(define (json-string-ref object key)
(let ((value (json-ref object key)))
(and (string? value) value)))
(define (json-integer-ref object key)
(let ((value (json-ref object key)))
(and (integer? value) value)))
(define (json-bool-ref object key)
(let ((value (json-ref object key)))
(and (boolean? value) value)))
(define (json-string-list-ref object key)
(let ((value (json-ref object key)))
(cond
((vector? value)
(let ((items (vector->list value)))
(and (every string? items) items)))
((list? value)
(and (every string? value) value))
(else #f))))
(define (required-string object key)
(or (json-string-ref object key)
(error "missing required string field" key)))
(define (required-string-list object key)
(or (json-string-list-ref object key)
(error "missing required string list field" key)))
(define (optional-string object key default)
(or (json-string-ref object key) default))
(define (optional-integer object key default)
(or (json-integer-ref object key) default))
(define (optional-bool object key default)
(let ((value (json-ref object key)))
(if (boolean? value) value default)))
(define (json-scm->tribes-system-facts payload)
(unless (json-object? payload)
(error "system facts must be a JSON object"))
(unless (equal? (json-string-ref payload "schemaVersion") "1")
(error "unsupported system facts schema version"
(json-ref payload "schemaVersion")))
(tribes-system-facts
(host-name (required-string payload "hostName"))
(interface (required-string payload "interface"))
(boot-mode (optional-string payload "bootMode" "bios"))
(bootloader-targets (required-string-list payload "bootloaderTargets"))
(boot-partition-uuid (required-string payload "bootPartitionUuid"))
(boot-partition-file-system-type
(optional-string payload "bootPartitionFileSystemType" "ext4"))
(efi-partition-uuid (json-string-ref payload "efiPartitionUuid"))
(efi-partition-file-system-type
(optional-string payload "efiPartitionFileSystemType" "vfat"))
(root-luks-uuid (required-string payload "rootLuksUuid"))
(root-mapper-name (optional-string payload "rootMapperName" "cryptroot"))
(root-file-system-type
(optional-string payload "rootFileSystemType" "ext4"))
(authorized-keys-file
(optional-string payload "authorizedKeysFile"
"/etc/tribes/root-authorized_keys"))
(local-boot-key-file
(optional-string payload "localBootKeyFile"
"/etc/legion/nbde/local-boot.key"))
(tang-port (optional-integer payload "tangPort" 7654))
(initrd-network-timeout-seconds
(optional-integer payload "initrdNetworkTimeoutSeconds" 20))
(enable-bbr? (optional-bool payload "enableBbr" #t))))
tribes/deploy/cli.scm
-129
View File
@@ -1,129 +0,0 @@
(define-module (tribes deploy cli)
#:use-module (ice-9 format)
#:use-module (ice-9 match)
#:use-module (json)
#:use-module (srfi srfi-1)
#:use-module (tribes deploy config)
#:use-module (tribes deploy guix-helper)
#:use-module (tribes deploy json)
#:use-module (tribes deploy operations)
#:use-module (tribes deploy plan)
#:use-module (tribes deploy state)
#:use-module (tribes deploy worker)
#:export (cli-main))
;; ---------------------------------------------------------------------------
;; CLI transport. The CLI is a one-shot process: every command constructs
;; its own state-store and runs synchronously, no worker thread. Each
;; command emits a single JSON document on stdout and exits non-zero on
;; failure so shell pipelines can branch on the result.
(define (json-print payload)
(scm->json (json-ready payload) (current-output-port))
(newline))
(define (require-root)
(unless (string=? (or (getenv "USER") "") "root")
(format (current-error-port) "tribes-deploy-exec must run as root.~%")
(exit 1)))
(define (ensure-managed-file path)
(unless (file-exists? path)
(format (current-error-port) "missing managed file: ~a~%" path)
(exit 1)))
(define (no-frame _) #t)
(define (default-state)
(make-state-store (deploy-config-from-environment)))
(define (default-helper)
(default-helper-backend))
;; ---------------------------------------------------------------------------
;; Subcommand implementations.
(define (status-command)
(json-print (state-store-read-status (default-state))))
(define (resolve-command target-path)
(ensure-managed-file target-path)
(let ((target (read-json-file target-path)))
(call-with-values (lambda () (resolve-deployment target))
(lambda (_status payload)
(json-print payload)))))
(define (prepare-command plan-path)
(require-root)
(ensure-managed-file plan-path)
(let* ((state (default-state))
(helper (default-helper))
(plan (read-json-file plan-path))
(plugins (plan-plugins plan))
(plan-hash-value (plan-hash plan)))
(when (state-store-active? state)
(json-print
(failure-payload "deployment already in progress"
#:code "busy"
#:plan-hash plan-hash-value))
(exit 1))
(let ((payload (prepare-plugins! state helper plugins
plan-hash-value no-frame
#:pull-required?
(plan-requires-pull? plan))))
(json-print payload)
(unless (equal? (json-ref payload "ok") #t) (exit 1)))))
(define (commit-command plan-hash-value)
(require-root)
(let* ((state (default-state))
(helper (default-helper))
(payload (commit-plan! state helper plan-hash-value no-frame)))
(json-print payload)
(unless (equal? (json-ref payload "ok") #t) (exit 1))))
(define (rollback-command store-path maybe-plan-path)
(require-root)
(let* ((state (default-state))
(helper (default-helper))
(plan (and maybe-plan-path
(begin (ensure-managed-file maybe-plan-path)
(read-json-file maybe-plan-path))))
(payload (rollback-store-path! state helper store-path plan
no-frame)))
(json-print payload)
(unless (equal? (json-ref payload "ok") #t) (exit 1))))
(define (generations-command)
(json-print (list-generations-payload (default-state))))
(define (abort-command)
(require-root)
(let ((state (default-state)))
(json-print (abort-prepare! state #f))))
(define (print-usage port)
(format port
"Usage: tribes-deploy-exec status~%")
(format port " | resolve <target.json>~%")
(format port " | prepare <plan.json>~%")
(format port " | commit <plan_hash>~%")
(format port " | rollback <store_path> [--plan <plan.json>]~%")
(format port " | generations~%")
(format port " | abort~%"))
(define (cli-main args)
(match args
(("status") (status-command))
(("resolve" target-path) (resolve-command target-path))
(("prepare" plan-path) (prepare-command plan-path))
(("commit" plan-hash-value) (commit-command plan-hash-value))
(("rollback" store-path "--plan" plan-path)
(rollback-command store-path plan-path))
(("rollback" store-path)
(rollback-command store-path #f))
(("generations") (generations-command))
(("abort") (abort-command))
(_
(print-usage (current-error-port))
(exit 1))))
tribes/deploy/config.scm
-194
View File
@@ -1,194 +0,0 @@
(define-module (tribes deploy config)
#:use-module (guix records)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:export (deploy-config
deploy-config?
this-deploy-config
deploy-config-deploy-directory
deploy-config-status-file
deploy-config-generations-file
deploy-config-host-config-file
deploy-config-channels-file
deploy-config-current-config-file
deploy-config-current-system-link
deploy-config-system-profile-link
deploy-config-system-profile-directory
deploy-config-control-socket-file
deploy-config-control-group
deploy-config-helper-binary
deploy-config-guix-binary
deploy-config-bootstrap-guix
deploy-config-runner
deploy-config-max-request-bytes
deploy-config-max-plugin-count
deploy-config-max-plugin-name-length
default-deploy-config
deploy-config-from-environment
deploy-config-write-to-port
deploy-config-read))
;; ---------------------------------------------------------------------------
;; <deploy-config>: a single record threading every path, binary and limit
;; through the broker. Used by both transports and by the worker.
(define-record-type* <deploy-config>
deploy-config make-deploy-config
deploy-config?
this-deploy-config
(deploy-directory deploy-config-deploy-directory
(default "/var/lib/tribes/deploy"))
(status-file deploy-config-status-file
(thunked)
(default
(string-append (deploy-config-deploy-directory
this-deploy-config)
"/status.json")))
(generations-file deploy-config-generations-file
(thunked)
(default
(string-append (deploy-config-deploy-directory
this-deploy-config)
"/generations.json")))
(host-config-file deploy-config-host-config-file
(default "/etc/tribes/host-config.json"))
(channels-file deploy-config-channels-file
(default "/etc/tribes/channels.scm"))
(current-config-file deploy-config-current-config-file
(default "/etc/config.scm"))
(current-system-link deploy-config-current-system-link
(default "/run/current-system"))
(system-profile-link deploy-config-system-profile-link
(default "/var/guix/profiles/system"))
(system-profile-directory deploy-config-system-profile-directory
(default "/var/guix/profiles"))
(control-socket-file deploy-config-control-socket-file
(default "/var/run/tribes/local-control.sock"))
(control-group deploy-config-control-group
(default "tribes"))
(helper-binary deploy-config-helper-binary
(default #f))
(guix-binary deploy-config-guix-binary
(default #f))
(bootstrap-guix deploy-config-bootstrap-guix
(default "/run/current-system/profile/bin/guix"))
(runner deploy-config-runner
(default #f))
(max-request-bytes deploy-config-max-request-bytes
(default 16384))
(max-plugin-count deploy-config-max-plugin-count
(default 64))
(max-plugin-name-length deploy-config-max-plugin-name-length
(default 128)))
(define (default-deploy-config)
(deploy-config))
;; ---------------------------------------------------------------------------
;; Environment-driven construction. The broker is started by Shepherd with
;; a small set of TRIBES_* vars; everything else falls back to defaults.
(define (env-or env-name fallback)
(or (getenv env-name) fallback))
(define (env-int env-name fallback)
(let ((value (getenv env-name)))
(or (and value (string->number value)) fallback)))
(define* (deploy-config-from-environment #:key
(defaults (default-deploy-config)))
"Build a <deploy-config> from environment variables, falling back to
DEFAULTS' fields when a variable is unset."
(deploy-config
(inherit defaults)
(deploy-directory
(env-or "TRIBES_DEPLOY_DIRECTORY"
(deploy-config-deploy-directory defaults)))
(host-config-file
(env-or "TRIBES_HOST_CONFIG_FILE"
(deploy-config-host-config-file defaults)))
(channels-file
(env-or "TRIBES_CHANNELS_FILE"
(deploy-config-channels-file defaults)))
(current-config-file
(env-or "TRIBES_CURRENT_CONFIG_FILE"
(deploy-config-current-config-file defaults)))
(control-socket-file
(env-or "TRIBES_LOCAL_CONTROL_SOCKET"
(deploy-config-control-socket-file defaults)))
(control-group
(env-or "TRIBES_LOCAL_CONTROL_GROUP"
(deploy-config-control-group defaults)))
(helper-binary
(env-or "TRIBES_GUIX_HELPER"
(deploy-config-helper-binary defaults)))
(guix-binary
(env-or "TRIBES_GUIX"
(deploy-config-guix-binary defaults)))
(bootstrap-guix
(env-or "TRIBES_BOOTSTRAP_GUIX"
(deploy-config-bootstrap-guix defaults)))
(max-request-bytes
(env-int "TRIBES_MAX_REQUEST_BYTES"
(deploy-config-max-request-bytes defaults)))))
;; ---------------------------------------------------------------------------
;; Optional: serialize a config as a sexp file at activation time so that the
;; broker is reproducible from /etc/tribes/local-control.conf. Currently
;; unused — the env-driven path is enough for the launcher.
(define (config->sexp config)
`((deploy-directory . ,(deploy-config-deploy-directory config))
(host-config-file . ,(deploy-config-host-config-file config))
(channels-file . ,(deploy-config-channels-file config))
(current-config-file . ,(deploy-config-current-config-file config))
(control-socket-file . ,(deploy-config-control-socket-file config))
(control-group . ,(deploy-config-control-group config))
(helper-binary . ,(deploy-config-helper-binary config))
(bootstrap-guix . ,(deploy-config-bootstrap-guix config))
(max-request-bytes . ,(deploy-config-max-request-bytes config))
(max-plugin-count . ,(deploy-config-max-plugin-count config))
(max-plugin-name-length . ,(deploy-config-max-plugin-name-length config))))
(define (deploy-config-write-to-port config port)
(write (config->sexp config) port)
(newline port))
(define (sexp-ref alist key default)
(let ((entry (assq key alist)))
(if entry (cdr entry) default)))
(define* (deploy-config-read path #:key (defaults (default-deploy-config)))
"Read PATH (sexp) and return a <deploy-config>, falling back to DEFAULTS'
fields for any missing keys."
(let ((sexp (call-with-input-file path read)))
(deploy-config
(inherit defaults)
(deploy-directory
(sexp-ref sexp 'deploy-directory
(deploy-config-deploy-directory defaults)))
(host-config-file
(sexp-ref sexp 'host-config-file
(deploy-config-host-config-file defaults)))
(channels-file
(sexp-ref sexp 'channels-file
(deploy-config-channels-file defaults)))
(current-config-file
(sexp-ref sexp 'current-config-file
(deploy-config-current-config-file defaults)))
(control-socket-file
(sexp-ref sexp 'control-socket-file
(deploy-config-control-socket-file defaults)))
(control-group
(sexp-ref sexp 'control-group
(deploy-config-control-group defaults)))
(helper-binary
(sexp-ref sexp 'helper-binary
(deploy-config-helper-binary defaults)))
(bootstrap-guix
(sexp-ref sexp 'bootstrap-guix
(deploy-config-bootstrap-guix defaults)))
(max-request-bytes
(sexp-ref sexp 'max-request-bytes
(deploy-config-max-request-bytes defaults))))))
tribes/deploy/current-guix-worker.scm
-91
View File
@@ -1,91 +0,0 @@
(define-module (tribes deploy current-guix-worker)
#:use-module (gnu system)
#:use-module (guix derivations)
#:use-module (guix gexp)
#:use-module (guix monads)
#:use-module (guix scripts system reconfigure)
#:use-module (guix store)
#:use-module (ice-9 match)
#:use-module (srfi srfi-13)
#:export (current-guix-worker-main
post-switch-activate-and-upgrade!))
;; This module is intentionally executed through
;; /root/.config/guix/current/bin/guix repl, not by the packaged
;; tribes-command wrapper. It may import Guix/GNU modules and lower/realize
;; gexps because the current Guix profile owns the channel checkout that built
;; the target system generation.
(define-syntax-rule (save-load-path-excursion body ...)
(let ((path %load-path)
(compiled-path %load-compiled-path))
(dynamic-wind
(lambda () #t)
(lambda () body ...)
(lambda ()
(set! %load-path path)
(set! %load-compiled-path compiled-path)))))
(define (local-eval exp)
"Evaluate EXP, a G-Expression, in-place."
(mlet* %store-monad ((lowered (lower-gexp exp))
(_ (built-derivations (lowered-gexp-inputs lowered))))
(save-load-path-excursion
(set! %load-path (lowered-gexp-load-path lowered))
(set! %load-compiled-path (lowered-gexp-load-compiled-path lowered))
(return (primitive-eval (lowered-gexp-sexp lowered))))))
(define (activate-generation! generation-path)
(let ((activate (and generation-path
(string-append generation-path "/activate"))))
(unless (and (string? generation-path)
(file-exists? generation-path)
(string? activate)
(file-exists? activate))
(error "selected generation missing activation script" generation-path))
(setenv "GUIX_NEW_SYSTEM" generation-path)
(primitive-load activate)))
(define (load-operating-system config-file)
(unless (and (string? config-file) (file-exists? config-file))
(error "configuration file does not exist" config-file))
(let ((os (primitive-load config-file)))
(unless (operating-system? os)
(error "configuration did not evaluate to an operating-system" config-file))
os))
(define (upgrade-live-services! config-file)
(let ((os (load-operating-system config-file)))
(with-store store
(run-with-store store
(mbegin %store-monad
(upgrade-shepherd-services local-eval os)
(return #t))))))
(define (post-switch-activate-and-upgrade! generation-path config-file)
(parameterize ((current-output-port (current-error-port))
(current-warning-port (%make-void-port "w")))
(activate-generation! generation-path)
(upgrade-live-services! config-file)))
(define (usage)
(format (current-error-port)
"Usage: current-guix-worker.scm post-switch-activate-and-upgrade GENERATION CONFIG~%")
(exit 64))
(define (current-guix-worker-main args)
(match args
(("post-switch-activate-and-upgrade" generation-path config-file)
(post-switch-activate-and-upgrade! generation-path config-file))
(_ (usage))))
(define (script-invocation? argv)
(match argv
((program . _)
(and (string? program)
(or (string=? program "current-guix-worker.scm")
(string-suffix? "/current-guix-worker.scm" program))))
(_ #f)))
(when (script-invocation? (command-line))
(current-guix-worker-main (cdr (command-line))))
tribes/deploy/current-guix.scm
-98
View File
@@ -1,98 +0,0 @@
(define-module (tribes deploy current-guix)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-13)
#:export (pulled-guix-binary
system-guix-binary
current-guix-binary
bootstrap-guix-binary
current-guix-profile-root
current-guix-module-file
call-with-clean-guix-environment
run-current-guix-repl-script))
;; Lightweight helpers for invoking the Guix profile that owns the active
;; channel checkout. Runtime Tribes programs may be built against a packaged
;; Guix for bootstrapping, but any operation that evaluates Guix systems,
;; services, gexps, or packages must be delegated to this current profile so it
;; sees the same module universe as `guix system build'.
(define (home-directory) (or (getenv "HOME") "/root"))
(define (pulled-guix-binary)
(string-append (home-directory) "/.config/guix/current/bin/guix"))
(define system-guix-binary "/run/current-system/profile/bin/guix")
(define (path-directories)
(string-split (or (getenv "PATH") "") #\:))
(define (guix-on-path)
(search-path (path-directories) "guix"))
(define (current-guix-binary)
(cond
((file-exists? (pulled-guix-binary)) (pulled-guix-binary))
((file-exists? system-guix-binary) system-guix-binary)
(else (or (guix-on-path) "guix"))))
(define (bootstrap-guix-binary)
(if (file-exists? system-guix-binary)
system-guix-binary
(current-guix-binary)))
(define (guix-profile-root guix)
(and (string? guix)
(absolute-file-name? guix)
(string-suffix? "/bin/guix" guix)
(dirname (dirname guix))))
(define (current-guix-profile-root)
(or (guix-profile-root (current-guix-binary))
(error "cannot infer Guix profile root" (current-guix-binary))))
(define (current-guix-module-file relative-path)
(let ((path (string-append (current-guix-profile-root)
"/share/guile/site/3.0/"
relative-path)))
(unless (file-exists? path)
(error "current Guix profile does not provide required module file"
path))
path))
(define %guix-environment-variables
;; These are intentionally unset for child Guix commands. The command from
;; /root/.config/guix/current sets up its own load paths; inheriting the
;; tribes-command wrapper paths would reintroduce packaged Guix modules.
'("GUILE_LOAD_PATH"
"GUILE_LOAD_COMPILED_PATH"
"GUIX_PACKAGE_PATH"))
(define (call-with-clean-guix-environment thunk)
(let ((saved (map (lambda (name) (cons name (getenv name)))
%guix-environment-variables)))
(dynamic-wind
(lambda ()
(for-each unsetenv %guix-environment-variables))
thunk
(lambda ()
(for-each
(match-lambda
((name . #f) (unsetenv name))
((name . value) (setenv name value)))
saved)))))
(define (normalize-status status)
(cond
((and (integer? status) (zero? status)) 0)
((integer? status) (or (status:exit-val status) 1))
(else 1)))
(define (run-current-guix-repl-script script args)
"Run SCRIPT under the current Guix profile's `guix repl'. Return a process
exit code."
(call-with-clean-guix-environment
(lambda ()
(normalize-status
(apply system* (current-guix-binary)
(append (list "repl" "-q" "--" script) args))))))
tribes/deploy/entry.scm
-22
View File
@@ -1,22 +0,0 @@
(define-module (tribes deploy entry)
#:use-module (ice-9 match)
#:use-module (tribes deploy cli)
#:use-module (tribes deploy http)
#:export (main))
;; ---------------------------------------------------------------------------
;; Single dispatch entry used by all three transport binaries. The wrapper
;; program-files in (tribes packages cli) call (main 'http), (main 'cli) or
;; (main 'shell).
(define (main mode)
(case mode
((http)
(run-local-control-server))
((cli)
(cli-main (cdr (command-line))))
((shell)
;; "tribes" UI shell — currently a thin wrapper that prints status.
(cli-main (list "status")))
(else
(error "tribes deploy entry: unknown mode" mode))))
tribes/deploy/executor.scm
+51 -326
View File
@@ -1,333 +1,58 @@
(define-module (tribes deploy executor)
#:use-module (srfi srfi-1)
#:use-module (ice-9 match)
#:use-module (ice-9 textual-ports)
#:use-module (json)
#:use-module (guix packages)
#:use-module (tribes deploy json)
#:use-module (tribes deploy plan)
#:use-module (tribes packages plugins)
#:use-module (tribes plugins registry)
#:re-export (json-object?
json-ref
json-string-list-ref
deployment-request-plugins
host-config-with-plugins
system-target-plugin-names
plan-plugins
plan-hash)
#:export (resolve-target))
#:export (deployment-request-plugins
host-config-with-plugins
json-object?
json-ref
json-string-list-ref))
(define %host-capabilities
'("admin_ui@1"
"ash@1"
"auth@1"
"ecto@1"
"nostr_relay@1"
"nostr_sync@1"
"phoenix@1"
"pubsub@1"))
(define (json-object? value)
(and (list? value) (every pair? value)))
(define (remove-item value items)
(filter (lambda (item) (not (equal? item value))) items))
(define (json-ref object key)
(and (json-object? object)
(let ((entry (assoc key object)))
(and entry (cdr entry)))))
(define (string-prefix? prefix value)
(and (string? prefix)
(string? value)
(<= (string-length prefix) (string-length value))
(string=? prefix (substring value 0 (string-length prefix)))))
(define (string-contains? value needle)
(let ((value-length (string-length value))
(needle-length (string-length needle)))
(let loop ((idx 0))
(cond
((> (+ idx needle-length) value-length) #f)
((string=? (substring value idx (+ idx needle-length)) needle) #t)
(else (loop (+ idx 1)))))))
(define (channel-id channel)
(or (json-ref channel "channel_id")
(json-ref channel "channelId")
(json-ref channel "id")))
(define (channel-url channel)
(or (json-ref channel "url") ""))
(define (channel-commit channel)
(or (json-ref channel "commit") ""))
(define (channel-branch channel)
(or (json-ref channel "branch") "master"))
(define (channel-position channel)
(let ((value (json-ref channel "position")))
(if (integer? value) value 0)))
(define (channel-allowed-signer-ids channel)
(or (json-string-list-ref channel "allowed_signer_ids")
(json-string-list-ref channel "allowedSignerIds")
'()))
(define (channel-introduction channel)
(let ((value (json-ref channel "introduction")))
(if (json-object? value) value '())))
(define (enabled-trusted-signers target)
(filter
(lambda (signer)
(and (json-object? signer)
(let ((enabled (json-bool-ref signer "enabled")))
(if (boolean? enabled) enabled #t))))
(or (json-list-ref target "trusted_signers")
(json-list-ref target "trustedSigners")
'())))
(define (trusted-signer-ids signers)
(filter-map (lambda (signer) (json-ref signer "id")) signers))
(define (trusted-signer-fingerprints signers)
(filter-map (lambda (signer) (json-ref signer "fingerprint")) signers))
(define (duplicates values)
(let loop ((remaining values) (seen '()) (dups '()))
(match remaining
(() (reverse dups))
((value . rest)
(if (member value seen)
(loop rest seen
(if (member value dups) dups (cons value dups)))
(loop rest (cons value seen) dups))))))
(define (resolver-error code message details)
`(("ok" . #f)
("error" . (("code" . ,code)
("message" . ,message)
("details" . ,details)))))
(define (resolver-error-object? value)
(and (json-object? value)
(equal? (json-ref value "ok") #f)
(json-object? (json-ref value "error"))))
(define (enabled-channels target)
(sort (filter json-object? (or (json-list-ref target "channels") '()))
(lambda (left right)
(< (channel-position left) (channel-position right)))))
(define (channel->resolved channel)
`(("channel_id" . ,(channel-id channel))
("url" . ,(channel-url channel))
("branch" . ,(channel-branch channel))
("commit" . ,(channel-commit channel))
("introduction" . ,(channel-introduction channel))
("position" . ,(channel-position channel))))
(define (default-plugin-channel channels)
(or (find (lambda (channel)
(string-contains? (channel-url channel) "guix-tribes"))
channels)
(and (pair? channels) (car channels))))
(define (requested-enabled-plugins target)
(filter (lambda (plugin)
(and (json-object? plugin)
(plugin-entry-enabled? plugin)
(string? (plugin-entry-name plugin))))
(or (json-list-ref target "plugins") '())))
(define (plugin-definition name)
(guix-tribes-plugin-definition-by-name name))
(define (definition-name definition)
(tribes-plugin-definition-name definition))
(define (definition-package-name definition)
(tribes-plugin-definition-package-name definition))
(define (definition-version definition)
(tribes-plugin-definition-version definition))
(define (definition-provides definition)
(tribes-plugin-definition-provides definition))
(define (definition-requires definition)
(tribes-plugin-definition-requires definition))
(define (provider-definitions capability)
(filter (lambda (definition)
(member capability
(definition-provides definition)))
guix-tribes-plugin-definitions))
(define (plugin-definition-dependencies definition)
(let loop ((caps (definition-requires definition))
(deps '()))
(match caps
(() (reverse deps))
((capability . rest)
(cond
((member capability %host-capabilities)
(loop rest deps))
(else
(let ((providers
(filter (lambda (provider)
(not (string=? (definition-name provider)
(definition-name definition))))
(provider-definitions capability))))
(match providers
(() (resolver-error
"missing_capability"
"required capability has no provider"
`(("plugin" . ,(definition-name definition))
("capability" . ,capability))))
((provider)
(loop rest
(if (member (definition-name provider) deps)
deps
(cons (definition-name provider) deps))))
(_
(loop rest
(if (member (definition-name (car providers)) deps)
deps
(cons (definition-name (car providers)) deps))))))))))))
(define (resolve-plugin-names requested-names)
(let ((resolved '())
(visiting '())
(error-result #f))
(define (visit name)
(unless (or error-result (member name resolved))
(if (member name visiting)
(set! error-result
(resolver-error
"capability_cycle"
"plugin capability graph has a cycle"
`(("cycle" . ,(reverse (cons name visiting))))))
(let ((definition (plugin-definition name)))
(if (not definition)
(set! error-result
(resolver-error
"manifest_invalid"
"requested plugin is not known to the channel registry"
`(("plugin" . ,name))))
(begin
(set! visiting (cons name visiting))
(let ((dependencies (plugin-definition-dependencies definition)))
(if (resolver-error-object? dependencies)
(set! error-result dependencies)
(for-each visit dependencies)))
(set! visiting (remove-item name visiting))
(unless error-result
(set! resolved (append resolved (list name)))))))))
resolved)
(for-each visit requested-names)
(if error-result error-result resolved)))
(define (channel-trust-error channels trusted-signers)
(let* ((signer-ids (trusted-signer-ids trusted-signers))
(fingerprints (trusted-signer-fingerprints trusted-signers))
(untrusted
(find
(lambda (channel)
(let* ((allowed (channel-allowed-signer-ids channel))
(introduction (channel-introduction channel))
(fingerprint (json-ref introduction "fingerprint")))
(or (any (lambda (signer-id) (not (member signer-id signer-ids))) allowed)
(and (string? fingerprint)
(not (member fingerprint fingerprints))))))
channels)))
(and untrusted
(resolver-error
"channel_untrusted"
"channel references signers not present in TrustedSigner"
`(("channel_id" . ,(channel-id untrusted))
("allowed_signer_ids" . ,(channel-allowed-signer-ids untrusted))
("introduction" . ,(channel-introduction untrusted)))))))
(define (plugin-name-duplicates target)
(duplicates (map plugin-entry-name (requested-enabled-plugins target))))
(define (plugin-request-channel plugin channels)
(let ((explicit-channel-id (plugin-entry-channel-id plugin)))
(or (and explicit-channel-id
(find (lambda (channel)
(equal? (channel-id channel) explicit-channel-id))
channels))
(default-plugin-channel channels))))
(define (package-ref channel definition)
`(("package" . ,(definition-package-name definition))
("version" . ,(definition-version definition))
("commit" . ,(if channel (channel-commit channel) ""))))
(define (extra-package-refs channel definition)
(map (lambda (package)
`(("name" . ,(package-name package))
("channel_id" . ,(and channel (channel-id channel)))
("version" . ,(package-version package))))
(tribes-external-plugin-extra-packages
(tribes-plugin-definition-external-plugin definition))))
(define (resolved-plugin plugin-name channels requested-plugins)
(let* ((definition (plugin-definition plugin-name))
(request-entry
(find (lambda (plugin)
(string=? (plugin-entry-name plugin) plugin-name))
requested-plugins))
(channel (and request-entry
(plugin-request-channel request-entry channels))))
`(("name" . ,plugin-name)
("channel_id" . ,(and channel (channel-id channel)))
("package_ref" . ,(package-ref channel definition))
("migration_target_version" . #f)
("migrations_dir" . "priv/repo/migrations")
("destructive_rollback_migrations" . #()))))
(define (resolved-extra-packages plugin-names channels requested-plugins)
(append-map
(lambda (plugin-name)
(let* ((definition (plugin-definition plugin-name))
(request-entry
(find (lambda (plugin)
(string=? (plugin-entry-name plugin) plugin-name))
requested-plugins))
(channel (and request-entry
(plugin-request-channel request-entry channels))))
(extra-package-refs channel definition)))
plugin-names))
(define (resolve-target target)
(let* ((channels (enabled-channels target))
(requested-plugins (requested-enabled-plugins target))
(trusted-signers (enabled-trusted-signers target))
(requested-names (map plugin-entry-name requested-plugins))
(duplicate-plugin-names (plugin-name-duplicates target))
(trust-error (channel-trust-error channels trusted-signers)))
(define (json-string-list-ref object key)
(let ((value (json-ref object key)))
(cond
((not (null? duplicate-plugin-names))
(resolver-error
"duplicate_plugin"
"duplicate plugin names requested"
`(("plugins" . ,duplicate-plugin-names))))
(trust-error trust-error)
((vector? value)
(let ((items (vector->list value)))
(and (every string? items) items)))
((list? value)
(and (every string? value) value))
(else #f))))
(define (assoc-set object key value)
(let loop ((remaining object) (result '()) (updated? #f))
(cond
((null? remaining)
(reverse
(if updated?
result
(cons (cons key value) result))))
((equal? (caar remaining) key)
(loop (cdr remaining)
(cons (cons key value) result)
#t))
(else
(let ((resolved-names (resolve-plugin-names requested-names)))
(if (resolver-error-object? resolved-names)
resolved-names
(let* ((resolved-channels (map channel->resolved channels))
(resolved-plugins
(map (lambda (name)
(resolved-plugin name channels requested-plugins))
resolved-names))
(resolved-extra-packages
(resolved-extra-packages resolved-names channels requested-plugins))
(base-plan
`(("plan_schema_version" . "1")
("resolved_channels" . ,(list->vector resolved-channels))
("resolved_plugins" . ,(list->vector resolved-plugins))
("resolved_extra_packages" . ,(list->vector resolved-extra-packages))
("core_migration_target" . #f)
("core_destructive_rollback_migrations" . #())
("closure_estimate_bytes" . #f))))
(assoc-set base-plan "plan_hash" (string-plan-hash base-plan)))))))))
(loop (cdr remaining)
(cons (car remaining) result)
updated?)))))
(define (deployment-request-plugins request)
(let* ((deployment-profile (json-ref request "deploymentProfile"))
(plugins (and (json-object? deployment-profile)
(json-string-list-ref deployment-profile "plugins"))))
(or plugins '())))
(define (host-config-with-plugins host-config plugin-names)
(unless (json-object? host-config)
(error "host config must be a JSON object"))
(let ((tribes-config (json-ref host-config "tribes")))
(unless (json-object? tribes-config)
(error "host config is missing tribes object"))
(assoc-set host-config
"tribes"
(assoc-set tribes-config "plugins" plugin-names))))
tribes/deploy/guix-helper.scm
-192
View File
@@ -1,192 +0,0 @@
(define-module (tribes deploy guix-helper)
#:use-module (ice-9 match)
#:use-module (ice-9 popen)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 textual-ports)
#:use-module (rnrs bytevectors)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (tribes deploy config)
#:use-module (tribes deploy json)
#:export (helper-result?
helper-result-ok?
helper-result-payload
helper-result-code
helper-result-message
helper-result-details
helper-result-frames
make-helper-backend
helper-backend?
helper-backend-pull
helper-backend-build
helper-backend-switch
default-helper-backend
run-pull!
run-build!
run-switch!
parse-helper-frame
consume-helper-output))
;; ---------------------------------------------------------------------------
;; <helper-result> — outcome of a tribes-guix-helper invocation. Successful
;; runs carry the final "done" frame's payload; failures carry a typed error
;; code per CONTRACTS.md §5.
(define-record-type <helper-result>
(%make-helper-result ok? payload code message details frames)
helper-result?
(ok? helper-result-ok?)
(payload helper-result-payload)
(code helper-result-code)
(message helper-result-message)
(details helper-result-details)
(frames helper-result-frames))
(define (helper-success payload frames)
(%make-helper-result #t payload #f #f #f frames))
(define (helper-failure code message details frames)
(%make-helper-result #f #f code message details frames))
;; ---------------------------------------------------------------------------
;; Frame parsing. Each line of helper stdout is either a JSON object with an
;; "event" key, or noise (logged but not interpreted).
(define (parse-helper-frame line)
"Parse LINE (a string) as an NDJSON frame. Returns the parsed alist on
success, #f on parse failure or non-object payloads."
(call-with-values
(lambda () (parse-json-string line))
(lambda (payload error)
(and (not error)
(json-object? payload)
payload))))
(define (consume-helper-output port on-frame)
"Read NDJSON frames from PORT until EOF. Calls ON-FRAME with each parsed
frame as a side effect (e.g. status updates). Returns the list of frames in
the order received."
(let loop ((frames '()))
(let ((line (read-line port)))
(cond
((eof-object? line) (reverse frames))
(else
(let ((trimmed (string-trim-both line)))
(cond
((string-null? trimmed) (loop frames))
(else
(let ((frame (parse-helper-frame trimmed)))
(cond
(frame
(on-frame frame)
(loop (cons frame frames)))
(else
;; Pass non-JSON lines through to stderr so operators can
;; still see helper output during debugging.
(format (current-error-port) "helper: ~a~%" trimmed)
(loop frames))))))))))))
(define (frame-event frame) (json-ref frame "event"))
(define (last-event-frame frames)
(find (lambda (frame)
(member (frame-event frame) '("done" "error")))
(reverse frames)))
(define (interpret-frames frames exit-status signal)
"Map the final frame to a <helper-result>. If the helper crashed without
emitting a structured terminal frame, synthesize a helper_crashed failure."
(match (last-event-frame frames)
(#f
(helper-failure
"helper_crashed"
"tribes-guix-helper terminated without a structured result frame"
`(("exit_status" . ,exit-status)
("signal" . ,signal))
frames))
(frame
(cond
((string=? (frame-event frame) "done")
(helper-success frame frames))
(else
(helper-failure
(or (json-ref frame "code") "helper_crashed")
(or (json-ref frame "message") "tribes-guix-helper reported failure")
(or (json-ref frame "details") '())
frames))))))
;; ---------------------------------------------------------------------------
;; Subprocess driver. open-pipe* + line-based parsing; the caller supplies
;; a frame callback so it can update its status snapshot in real time.
(define (helper-binary-or-error config)
(or (deploy-config-helper-binary config)
(error "TRIBES_GUIX_HELPER not configured")))
(define (status->exit-and-signal status)
(cond
((not (integer? status)) (values 1 #f))
(else
(let ((exit-status (status:exit-val status))
(term-sig (status:term-sig status)))
(values (or exit-status 1) term-sig)))))
(define* (run-helper config args #:key (on-frame (lambda (_) #t)))
"Spawn (deploy-config-helper-binary CONFIG) with ARGS, parse NDJSON frames
from stdout, and return a <helper-result>. ON-FRAME is invoked with each
parsed frame so the worker can stream phase updates."
(let* ((binary (helper-binary-or-error config))
(command (cons binary args))
;; LC_ALL=C keeps fallback (non-structured) Guix error text stable.
(port (apply open-pipe* OPEN_READ command)))
(let* ((frames (consume-helper-output port on-frame))
(status (close-pipe port)))
(call-with-values
(lambda () (status->exit-and-signal status))
(lambda (exit-status signal)
(interpret-frames frames exit-status signal))))))
;; ---------------------------------------------------------------------------
;; High-level entry points. The helper's own argv mirrors these:
;; tribes-guix-helper pull <channels-file>
;; tribes-guix-helper build <config-file> <system-profile-link> <root-link>
;; tribes-guix-helper switch <generation-number> <config-file> <system-profile-link>
(define* (run-pull! config #:key (on-frame (lambda (_) #t)))
(run-helper config
(list "pull" (deploy-config-channels-file config))
#:on-frame on-frame))
(define* (run-build! config root-link #:key (on-frame (lambda (_) #t)))
(run-helper config
(list "build"
(deploy-config-current-config-file config)
(deploy-config-system-profile-link config)
root-link)
#:on-frame on-frame))
(define* (run-switch! config generation-number #:key (on-frame (lambda (_) #t)))
(run-helper config
(list "switch"
(number->string generation-number)
(deploy-config-current-config-file config)
(deploy-config-system-profile-link config))
#:on-frame on-frame))
;; ---------------------------------------------------------------------------
;; Helper backend — the interface operations.scm depends on. The default
;; backend dispatches to the tribes-guix-helper subprocess; tests can supply
;; a fake backend with canned results.
(define-record-type <helper-backend>
(make-helper-backend pull build switch)
helper-backend?
(pull helper-backend-pull) ;; (config on-frame) -> <helper-result>
(build helper-backend-build) ;; (config root-link on-frame) -> result
(switch helper-backend-switch)) ;; (config gen-number on-frame) -> result
(define (default-helper-backend)
(make-helper-backend
(lambda (config on-frame) (run-pull! config #:on-frame on-frame))
(lambda (config root on-frame) (run-build! config root #:on-frame on-frame))
(lambda (config gen on-frame) (run-switch! config gen #:on-frame on-frame))))
tribes/deploy/handlers.scm
-144
View File
@@ -1,144 +0,0 @@
(define-module (tribes deploy handlers)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (srfi srfi-1)
#:use-module (tribes deploy config)
#:use-module (tribes deploy json)
#:use-module (tribes deploy operations)
#:use-module (tribes deploy plan)
#:use-module (tribes deploy state)
#:use-module (tribes deploy worker)
#:export (handle-status
handle-generations
handle-resolve
handle-prepare
handle-commit
handle-rollback
handle-abort
error-payload
validate-resolve-input
validate-prepare-input
validate-commit-input
validate-rollback-input))
;; ---------------------------------------------------------------------------
;; Validation — applied before dispatching to operations.scm.
(define %plugin-name-rx (make-regexp "^[A-Za-z0-9._@+-]+$"))
(define (plugin-name-valid? value cfg)
(let ((max-len (deploy-config-max-plugin-name-length cfg)))
(and (string? value)
(> (string-length value) 0)
(<= (string-length value) max-len)
(regexp-exec %plugin-name-rx value))))
(define (duplicates values)
(let loop ((rest values) (seen '()) (dups '()))
(match rest
(() (reverse dups))
((v . tail)
(cond
((member v seen)
(loop tail seen (if (member v dups) dups (cons v dups))))
(else (loop tail (cons v seen) dups)))))))
(define (validate-resolve-input payload)
(cond
((not (json-object-with-string-keys? payload))
"target payload must be a JSON object")
(else #f)))
(define (validate-prepare-input payload cfg)
(cond
((not (json-object-with-string-keys? payload))
"plan payload must be a JSON object")
((not (json-ref payload "plan_hash"))
"plan payload is missing plan_hash")
(else
(let ((plugins (or (json-list-ref payload "resolved_plugins")
(json-list-ref payload "resolvedPlugins")
'())))
(cond
((> (length plugins) (deploy-config-max-plugin-count cfg))
"too many plugins requested")
(else #f))))))
(define (validate-commit-input payload)
(cond
((not (json-object-with-string-keys? payload))
"commit payload must be a JSON object")
((not (or (json-ref payload "plan_hash")
(json-ref payload "planHash")))
"commit payload is missing plan_hash")
(else #f)))
(define (validate-rollback-input payload)
(cond
((not (json-object-with-string-keys? payload))
"rollback payload must be a JSON object")
((not (string? (or (json-ref payload "store_path")
(json-ref payload "storePath"))))
"rollback payload is missing store_path")
(else #f)))
(define (error-payload code reason . details)
`(("schemaVersion" . "2")
("ok" . #f)
("status" . "failed")
("code" . ,code)
("reason" . ,reason)
,@(if (pair? details)
`(("details" . ,(car details)))
'())))
;; ---------------------------------------------------------------------------
;; Per-route handlers. Each returns (values status-code payload).
(define (handle-status state worker)
(values 200 (current-status state worker)))
(define (handle-generations state)
(values 200 (list-generations-payload state)))
(define (handle-resolve payload)
(let ((err (validate-resolve-input payload)))
(cond
(err (values 400 (error-payload "invalid_request" err)))
(else (resolve-deployment payload)))))
(define (handle-prepare state worker helper payload)
(let* ((cfg (state-store-config state))
(err (validate-prepare-input payload cfg)))
(cond
(err (values 400 (error-payload "invalid_request" err)))
(else
(let ((plugins (plan-plugins payload))
(plan-hash-value (plan-hash payload)))
(submit-prepare! state worker helper plugins plan-hash-value
#:plan payload
#:pull-required?
(plan-requires-pull? payload)))))))
(define (handle-commit state worker helper payload)
(let ((err (validate-commit-input payload)))
(cond
(err (values 400 (error-payload "invalid_request" err)))
(else
(let ((plan-hash-value (or (json-ref payload "plan_hash")
(json-ref payload "planHash"))))
(submit-commit! state worker helper plan-hash-value))))))
(define (handle-rollback state worker helper payload)
(let ((err (validate-rollback-input payload)))
(cond
(err (values 400 (error-payload "invalid_request" err)))
(else
(let ((store-path (or (json-ref payload "store_path")
(json-ref payload "storePath")))
(plan (or (json-ref payload "plan")
(json-ref payload "target_plan"))))
(submit-rollback! state worker helper store-path plan))))))
(define (handle-abort state worker)
(values 200 (abort-prepare! state worker)))
tribes/deploy/helper-main.scm
-355
View File
@@ -1,355 +0,0 @@
(define-module (tribes deploy helper-main)
#:use-module (guix build utils)
#:use-module (ice-9 format)
#:use-module (ice-9 match)
#:use-module (ice-9 popen)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 regex)
#:use-module (ice-9 textual-ports)
#:use-module (json)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-71)
#:use-module (tribes deploy current-guix)
#:export (helper-main))
;; tribes-guix-helper logic. The wrapper program-file in
;; (tribes packages cli) only does (helper-main (cdr (command-line))).
;; Keeping the body here means it gets compiled to .go alongside the
;; other deploy modules and that the package definition stays small.
;; ----- frame helpers -------------------------------------------------------
(define (now-iso8601)
(date->string (time-utc->date (current-time time-utc) 0)
"~Y-~m-~dT~H:~M:~SZ"))
(define (emit-frame frame)
(scm->json frame (current-output-port))
(newline)
(force-output (current-output-port)))
(define (phase-frame phase . extras)
(emit-frame
(append `(("event" . "phase")
("phase" . ,phase)
("ts" . ,(now-iso8601)))
extras)))
(define (done-frame . extras)
(emit-frame
(append `(("event" . "done")
("ts" . ,(now-iso8601)))
extras)))
(define (error-frame code message details)
(emit-frame
`(("event" . "error")
("code" . ,code)
("message" . ,message)
("details" . ,details)
("ts" . ,(now-iso8601)))))
;; ----- Guix binary discovery ----------------------------------------------
(define system-herd "/run/current-system/profile/bin/herd")
(define default-system-profile "/var/guix/profiles/system")
(define (herd-binary)
(if (file-exists? system-herd) system-herd "herd"))
;; ----- subprocess capture --------------------------------------------------
;; Run a command, stream its output to stderr (so the broker can surface it
;; to operators) and return (values exit-status captured) where captured is
;; the joined stderr+stdout text — used to classify errors.
(define (capture-status command args)
(let* ((port (apply open-pipe* OPEN_READ
(cons command args)))
(lines (let loop ((acc '()))
(let ((line (read-line port)))
(cond
((eof-object? line) (reverse acc))
(else
(format (current-error-port) "~a~%" line)
(loop (cons line acc)))))))
(status (close-pipe port)))
(values (or (and (integer? status)
(status:exit-val status))
1)
(string-join lines "\n"))))
(define (capture-guix-status command args)
(call-with-clean-guix-environment
(lambda ()
(capture-status command args))))
;; ----- path helpers --------------------------------------------------------
(define (resolved-link-path path)
(or (false-if-exception (canonicalize-path path))
(and (file-exists? path)
(false-if-exception (readlink path)))
""))
(define (profile-generation-path profile)
(let ((target (false-if-exception (readlink profile))))
(cond
((not (string? target)) #f)
((absolute-file-name? target) target)
(else (string-append (dirname profile) "/" target)))))
(define %root-link-generation-rx (make-regexp "system-([0-9]+)-link$"))
(define default-host-config-file "/etc/tribes/host-config.json")
(define default-system-facts-file "/etc/tribes/system-facts.json")
(define default-deploy-directory "/var/lib/tribes/deploy")
(define (file->string path)
(call-with-input-file path get-string-all))
(define (json-file->scm path)
(call-with-input-file path json->scm))
(define (tribes-materialized-config-file? path)
(and (string? path)
(file-exists? path)
(let ((contents (file->string path)))
(and (text-contains? contents "tribes-operating-system-from-json-files")
(text-contains? contents default-host-config-file)
(text-contains? contents default-system-facts-file)))))
(define (root-link-snapshot-config-file root-link)
(let* ((base (or root-link ""))
(match (regexp-exec %root-link-generation-rx base))
(suffix (if match
(match:substring match 1)
(number->string (getpid)))))
(mkdir-p default-deploy-directory)
(string-append default-deploy-directory
"/configuration-"
suffix
".snapshot.scm")))
(define (write-config-snapshot! source-config-file root-link)
(let ((snapshot-file (root-link-snapshot-config-file root-link))
(host-config (json-file->scm default-host-config-file))
(system-facts (json-file->scm default-system-facts-file)))
(call-with-output-file snapshot-file
(lambda (port)
(display ";; Auto-generated immutable deployment snapshot.\n" port)
(display ";; Source config: " port)
(display source-config-file port)
(newline port)
(newline port)
(display "(use-modules (tribes system materialize)\n" port)
(display " (tribes config host)\n" port)
(display " (tribes config system-facts))\n\n" port)
(display "(tribes-host-configuration+system-facts->operating-system\n" port)
(display " (json-scm->tribes-host-configuration\n '" port)
(write host-config port)
(display ")\n" port)
(display " (json-scm->tribes-system-facts\n '" port)
(write system-facts port)
(display "))\n" port)))
snapshot-file))
(define (build-config-file-for-prepare source-config-file root-link)
(if (and (tribes-materialized-config-file? source-config-file)
(file-exists? default-host-config-file)
(file-exists? default-system-facts-file))
(write-config-snapshot! source-config-file root-link)
source-config-file))
(define (text-contains? haystack needle)
(and (string? haystack)
(string? needle)
(let* ((hl (string-length haystack))
(nl (string-length needle)))
(and (>= hl nl)
(let loop ((i 0))
(cond
((> (+ i nl) hl) #f)
((string=? (substring haystack i (+ i nl)) needle) #t)
(else (loop (+ i 1)))))))))
(define (classify-pull-error captured)
(cond
((text-contains? captured "signature") "signature_invalid")
((text-contains? captured "introduction") "channel_untrusted")
((text-contains? captured "no such commit") "channel_commit_unreachable")
((text-contains? captured "Couldn't find remote ref")
"channel_commit_unreachable")
(else "build_failed")))
;; ----- current Guix worker helpers ----------------------------------------
(define (activate-and-upgrade-with-current-guix! generation-path config-file)
"Activate GENERATION-PATH and upgrade Shepherd services in the current Guix
profile, i.e. the pulled channel environment used by `guix system build'."
(let ((script (current-guix-module-file
"tribes/deploy/current-guix-worker.scm")))
(call-with-values
(lambda ()
(capture-guix-status
(current-guix-binary)
(list "repl" "-q" "--"
script
"post-switch-activate-and-upgrade"
generation-path
config-file)))
(lambda (status captured)
(unless (zero? status)
(error "post-switch activation and service upgrade failed"
`((exit_status . ,status)
(output . ,captured))))))))
(define (schedule-tribes-restart!)
(let ((pid (primitive-fork)))
(cond
((zero? pid)
(let ((status (catch #t
(lambda ()
(sleep 1)
(system* (herd-binary) "restart" "tribes"))
(lambda _ 1))))
(primitive-exit (if (and (integer? status) (zero? status)) 0 1))))
(else pid))))
;; ----- subcommands ---------------------------------------------------------
(define (preferred-configuration-file profile-or-generation fallback)
(let ((preferred (and (string? profile-or-generation)
(not (string=? profile-or-generation ""))
(string-append profile-or-generation "/configuration.scm"))))
(cond
((and preferred (file-exists? preferred)) preferred)
((and (string? fallback) (file-exists? fallback)) fallback)
(else
(error "configuration file does not exist"
(or preferred fallback))))))
(define (cmd-pull channels-file)
(phase-frame "pulling")
(call-with-values
(lambda ()
(capture-guix-status (bootstrap-guix-binary)
(list "pull" "--allow-downgrades"
"-C" channels-file)))
(lambda (status captured)
(cond
((zero? status)
(done-frame)
(exit 0))
(else
(error-frame (classify-pull-error captured)
"guix pull failed"
`(("exit_status" . ,status)))
(exit status))))))
(define (cmd-build config-file system-profile-link root-link)
(phase-frame "building")
(let* ((effective-config-file
(preferred-configuration-file (or system-profile-link default-system-profile)
config-file))
(build-config-file
(build-config-file-for-prepare effective-config-file root-link)))
(call-with-values
(lambda ()
(capture-guix-status (current-guix-binary)
(list "system" "build"
"--save-provenance"
(string-append "--root=" root-link)
build-config-file)))
(lambda (status captured)
(cond
((zero? status)
(let ((store-path
(or (false-if-exception (canonicalize-path root-link))
(false-if-exception (readlink root-link))
"")))
(done-frame `("store_path" . ,store-path))
(exit 0)))
(else
(error-frame "build_failed"
"guix system build failed"
`(("exit_status" . ,status)))
(exit status)))))))
(define (cmd-switch generation-number config-file system-profile-link)
(phase-frame "switching")
(call-with-values
(lambda ()
(capture-guix-status (current-guix-binary)
(list "system" "switch-generation"
generation-number)))
(lambda (status captured)
(cond
((zero? status)
;; Keep the post-switch exception guard, but return a status code from
;; inside it rather than calling `exit' there. In Guile, `(exit 0)'
;; is implemented as a `quit' exception; catching all keys around the
;; success path would otherwise turn a successful switch into
;; `post-switch activation failed' with `quit: (0)'.
(exit
(catch #t
(lambda ()
(let* ((profile (or system-profile-link default-system-profile))
(generation-path (profile-generation-path profile))
(effective-config-file
(preferred-configuration-file generation-path config-file)))
(activate-and-upgrade-with-current-guix! generation-path
effective-config-file)
(let ((selected-store-path (resolved-link-path profile))
(running-store-path (resolved-link-path "/run/current-system"))
(generation-number-value (or (string->number generation-number) 0)))
(if (and (string? selected-store-path)
(not (string=? selected-store-path ""))
(string=? selected-store-path running-store-path))
(begin
(schedule-tribes-restart!)
(done-frame
`( "generation_number" . ,generation-number-value)
`( "store_path" . ,selected-store-path)
`( "selected_system" . ,selected-store-path)
`( "running_system" . ,running-store-path)
'("tribes_restart_scheduled" . #t))
0)
(begin
(error-frame
"switch_failed"
"selected and running systems diverged after activation"
`(("generation_number" . ,generation-number-value)
("selected_system" . ,selected-store-path)
("running_system" . ,running-store-path)))
1)))))
(lambda (key . args)
(error-frame "switch_failed"
"post-switch activation failed"
`(("exit_status" . ,status)
("exception" . ,(format #f "~a: ~s" key args))))
1))))
(else
(error-frame "switch_failed"
"guix system switch-generation failed"
`(("exit_status" . ,status)))
(exit status))))))
(define (usage)
(format (current-error-port)
"Usage: tribes-guix-helper pull <channels-file>~%")
(format (current-error-port)
" | build <config-file> <system-profile-link> <root-link>~%")
(format (current-error-port)
" | switch <generation-number> <config-file> <system-profile-link>~%")
(exit 64))
(define (helper-main args)
;; LC_ALL=C keeps Guix error output stable for fallback parsing.
(setenv "LC_ALL" "C")
(match args
(("pull" channels-file) (cmd-pull channels-file))
(("build" config-file system-profile-link root-link)
(cmd-build config-file system-profile-link root-link))
(("switch" generation-number config-file system-profile-link)
(cmd-switch generation-number config-file system-profile-link))
(_ (usage))))
tribes/deploy/http.scm
-182
View File
@@ -1,182 +0,0 @@
(define-module (tribes deploy http)
#:use-module (ice-9 format)
#:use-module (ice-9 match)
#:use-module (json)
#:use-module (rnrs bytevectors)
#:use-module (srfi srfi-1)
#:use-module (tribes deploy config)
#:use-module (tribes deploy guix-helper)
#:use-module (tribes deploy handlers)
#:use-module (tribes deploy json)
#:use-module (tribes deploy state)
#:use-module (tribes deploy worker)
#:use-module (web request)
#:use-module (web response)
#:use-module (web server)
#:use-module (web uri)
#:export (run-local-control-server
make-local-control-handler))
;; ---------------------------------------------------------------------------
;; HTTP transport. Routes are flat; long operations dispatch to the worker
;; thread which keeps the request thread free.
(define (json-string payload)
(call-with-output-string
(lambda (port)
(scm->json (json-ready payload) port))))
(define (json-response code payload)
(values
(build-response
#:code code
#:headers '((content-type . (application/json))))
(json-string payload)))
(define (json-request? request)
(match (request-content-type request)
(('application/json . _) #t)
(_ #f)))
(define (request-too-large? request body cfg)
(let ((max-bytes (deploy-config-max-request-bytes cfg)))
(or (let ((len (request-content-length request)))
(and len (> len max-bytes)))
(and body (> (bytevector-length body) max-bytes)))))
(define (with-json-body cfg request body proc)
(cond
((request-too-large? request body cfg)
(json-response
413
(error-payload "request_too_large"
"request body exceeds local control limit")))
((not (json-request? request))
(json-response
415
(error-payload "unsupported_media_type"
"local control requests must use application/json")))
(else
(call-with-values
(lambda () (parse-json-bytevector body))
(lambda (payload error)
(cond
(error (json-response 400 (error-payload "invalid_request" error)))
(else (proc payload))))))))
(define (route-table cfg state worker helper)
;; ((method . path) handler) where handler is a (request body) -> values.
`(((GET . "/v1/deployment")
. ,(lambda (_request _body)
(call-with-values (lambda () (handle-status state worker))
json-response)))
((GET . "/v1/deployment/status")
. ,(lambda (_request _body)
(call-with-values (lambda () (handle-status state worker))
json-response)))
((GET . "/v1/deployment/generations")
. ,(lambda (_request _body)
(call-with-values (lambda () (handle-generations state))
json-response)))
((POST . "/v1/deployment/resolve")
. ,(lambda (request body)
(with-json-body cfg request body
(lambda (payload)
(call-with-values
(lambda () (handle-resolve payload))
json-response)))))
((POST . "/v1/deployment/prepare")
. ,(lambda (request body)
(with-json-body cfg request body
(lambda (payload)
(call-with-values
(lambda () (handle-prepare state worker helper payload))
json-response)))))
((POST . "/v1/deployment/commit")
. ,(lambda (request body)
(with-json-body cfg request body
(lambda (payload)
(call-with-values
(lambda () (handle-commit state worker helper payload))
json-response)))))
((POST . "/v1/deployment/rollback")
. ,(lambda (request body)
(with-json-body cfg request body
(lambda (payload)
(call-with-values
(lambda () (handle-rollback state worker helper payload))
json-response)))))
((POST . "/v1/deployment/abort")
. ,(lambda (_request _body)
(call-with-values (lambda () (handle-abort state worker))
json-response)))))
(define (route-lookup table method path)
(find (lambda (entry)
(let ((key (car entry)))
(and (eq? (car key) method)
(string=? (cdr key) path))))
table))
(define (make-local-control-handler cfg state worker helper)
(let ((table (route-table cfg state worker helper)))
(lambda (request body)
(let* ((method (request-method request))
(path (uri-path (request-uri request)))
(entry (route-lookup table method path)))
(cond
(entry ((cdr entry) request body))
(else
(json-response
404
(error-payload "not_found"
(format #f "unsupported local control path: ~a" path)))))))))
;; ---------------------------------------------------------------------------
;; Socket setup. Same Unix-socket-with-group-permissions pattern as before.
(define (control-group-gid name)
(match (false-if-exception (getgrnam name))
(#f 0)
(group (group:gid group))))
(define (safe-delete-socket-file path)
(let ((details (false-if-exception (stat path))))
(when details
(cond
((eq? 'socket (stat:type details))
(delete-file path))
(else
(format (current-error-port)
"refusing to remove non-socket control path: ~a~%" path)
(exit 1))))))
(define (ensure-control-directory directory group)
(unless (file-exists? directory)
(mkdir directory #o755))
(chown directory 0 (control-group-gid group))
(chmod directory #o710))
(define (make-control-socket directory socket-file group)
(ensure-control-directory directory group)
(safe-delete-socket-file socket-file)
(let ((sock (socket PF_UNIX SOCK_STREAM 0)))
(bind sock AF_UNIX socket-file)
(chown socket-file 0 (control-group-gid group))
(chmod socket-file #o660)
sock))
(define* (run-local-control-server #:key (config (deploy-config-from-environment)))
(let* ((cfg config)
(state (make-state-store cfg))
(worker (make-worker cfg state))
(helper (default-helper-backend))
(socket-file (deploy-config-control-socket-file cfg))
(directory (dirname socket-file)))
(state-store-ensure-directory! state)
(run-server
(make-local-control-handler cfg state worker helper)
'http
(list #:socket
(make-control-socket directory socket-file
(deploy-config-control-group cfg))))))
tribes/deploy/json.scm
-164
View File
@@ -1,164 +0,0 @@
(define-module (tribes deploy json)
#:use-module (ice-9 match)
#:use-module (json)
#:use-module (rnrs bytevectors)
#:use-module (srfi srfi-1)
#:export (json-object?
json-object-with-string-keys?
json-ref
json-string-list-ref
json-list-ref
json-bool-ref
json-ready
read-json-file
write-json-file
atomic-write-json-file
parse-json-bytevector
parse-json-string))
;; ---------------------------------------------------------------------------
;; Predicates and accessors
;;
;; A JSON object is represented as an alist whose keys are strings.
;; A JSON array is represented as a vector. These conventions mirror what
;; guile-json-4 produces from json->scm and consumes from scm->json.
(define (json-object? value)
"True if VALUE is a JSON object (an alist; the empty alist counts)."
(and (list? value) (every pair? value)))
(define (json-object-with-string-keys? value)
"Strict variant: VALUE must be a non-empty alist with string keys. Used
where input validation must reject e.g. a stray array masquerading as an
object."
(and (list? value)
(pair? value)
(every (lambda (entry)
(and (pair? entry)
(string? (car entry))))
value)))
(define (json-ref object key)
"Look up KEY (a string) in OBJECT. Returns #f if OBJECT is not a JSON
object or KEY is missing."
(and (json-object? object)
(let ((entry (assoc key object)))
(and entry (cdr entry)))))
(define (json-list-ref object key)
"Look up KEY in OBJECT and coerce the value to a list. Accepts both
vector-shaped arrays (canonical) and list-shaped arrays (legacy callers)."
(let ((value (json-ref object key)))
(cond
((vector? value) (vector->list value))
((list? value) value)
(else #f))))
(define (json-string-list-ref object key)
"Look up KEY in OBJECT and coerce the value to a list of strings, or #f if
the value is missing or not a homogeneous string array."
(let ((value (json-ref object key)))
(cond
((vector? value)
(let ((items (vector->list value)))
(and (every string? items) items)))
((list? value)
(and (every string? value) value))
(else #f))))
(define (json-bool-ref object key)
"Look up KEY in OBJECT and return its boolean value, or #f if absent or
not a boolean. Distinguishing absent vs. literal #f requires (json-ref)."
(let ((value (json-ref object key)))
(and (boolean? value) value)))
;; ---------------------------------------------------------------------------
;; Encoding
;;
;; guile-json-4's scm->json conflates "list of pairs" with "list" and so
;; cannot tell an empty alist from an empty array. json-ready walks a value
;; and rewrites bare lists as vectors so that scm->json emits arrays. Alists
;; with string keys are preserved as objects.
(define (json-ready value)
"Recursively coerce VALUE so that scm->json emits the intended JSON
shape: alists with string keys become objects, all other lists become
arrays."
(cond
((vector? value)
(list->vector (map json-ready (vector->list value))))
((json-object-with-string-keys? value)
(map (lambda (entry)
(cons (car entry) (json-ready (cdr entry))))
value))
((list? value)
(list->vector (map json-ready value)))
(else value)))
;; ---------------------------------------------------------------------------
;; File I/O
(define (read-json-file path)
"Read PATH and parse it as JSON, returning a Scheme value."
(call-with-input-file path json->scm))
(define (write-json-file path payload)
"Write PAYLOAD to PATH as JSON. PAYLOAD is run through json-ready first."
(call-with-output-file path
(lambda (port)
(scm->json (json-ready payload) port))))
(define (atomic-write-json-file path payload)
"Atomically write PAYLOAD to PATH: write to a temp file in the same
directory, fsync, then rename into place. Crash-safe against torn writes."
(let* ((directory (or (and=> (string-rindex path #\/)
(lambda (idx) (substring path 0 idx)))
"."))
(base (or (and=> (string-rindex path #\/)
(lambda (idx) (substring path (+ idx 1))))
path))
(tmp (string-append directory "/." base ".tmp."
(number->string (getpid)))))
(call-with-output-file tmp
(lambda (port)
(scm->json (json-ready payload) port)
(force-output port)
;; Best-effort fsync; (fsync) is in (ice-9 fdes) on some Guile
;; builds. Fall back silently if unavailable.
(false-if-exception (fsync port))))
(rename-file tmp path)))
;; ---------------------------------------------------------------------------
;; Parsing untrusted input
(define (parse-json-bytevector body)
"Parse BODY (a bytevector or #f for empty) as JSON. Returns
(values payload #f) on success
(values #f reason-string) on failure
The empty-body case maps to the empty object '() so callers can handle
missing payloads uniformly."
(cond
((or (not body) (zero? (bytevector-length body)))
(values '() #f))
(else
(catch #t
(lambda ()
(values (call-with-input-string (utf8->string body) json->scm) #f))
(lambda (key . args)
(values #f
(string-append "invalid JSON payload: "
(symbol->string key))))))))
(define (parse-json-string str)
"Like parse-json-bytevector but takes a string."
(cond
((or (not str) (string-null? str))
(values '() #f))
(else
(catch #t
(lambda ()
(values (call-with-input-string str json->scm) #f))
(lambda (key . args)
(values #f
(string-append "invalid JSON payload: "
(symbol->string key))))))))
tribes/deploy/operations.scm
-597
View File
@@ -1,597 +0,0 @@
(define-module (tribes deploy operations)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (tribes deploy config)
#:use-module (tribes deploy guix-helper)
#:use-module (tribes deploy json)
#:use-module (tribes deploy plan)
#:use-module (tribes deploy state)
#:use-module (tribes deploy worker)
#:export (resolve-deployment
list-generations-payload
abort-prepare!
current-status
prepare-plugins!
commit-plan!
rollback-store-path!
submit-prepare!
submit-commit!
submit-rollback!
success-payload
failure-payload
from-helper-failure))
;; ---------------------------------------------------------------------------
;; Result shapers — one canonical place for the JSON envelopes returned to
;; HTTP and CLI callers.
(define* (success-payload status
store-path
plan-hash
generation-number
gc-pinned
#:key
built-at
activated-at
selected-system
running-system)
`(("schemaVersion" . "2")
("ok" . #t)
("status" . ,status)
("plan_hash" . ,plan-hash)
("store_path" . ,store-path)
("generation_number" . ,generation-number)
("gc_pinned" . ,gc-pinned)
,@(if selected-system `(("selectedSystem" . ,selected-system)) '())
,@(if running-system `(("runningSystem" . ,running-system)) '())
,@(if built-at `(("built_at" . ,built-at)) '())
,@(if activated-at `(("activated_at" . ,activated-at)) '())))
(define* (failure-payload reason
#:key
code
plan-hash
store-path
details)
`(("schemaVersion" . "2")
("ok" . #f)
("status" . "failed")
("reason" . ,reason)
,@(if code `(("code" . ,code)) '())
,@(if plan-hash `(("plan_hash" . ,plan-hash)) '())
,@(if store-path `(("store_path" . ,store-path)) '())
,@(if details `(("details" . ,details)) '())))
(define* (from-helper-failure result #:key plan-hash store-path)
(failure-payload (helper-result-message result)
#:code (helper-result-code result)
#:plan-hash plan-hash
#:store-path store-path
#:details (helper-result-details result)))
;; ---------------------------------------------------------------------------
;; resolve — pure, no I/O beyond reading the request. The resolver lives
;; in (tribes deploy executor), which transitively imports
;; (tribes packages plugins) and a large slice of the Guix package tree.
;; To keep the broker boot path small we resolve the entry point lazily,
;; the first time a /v1/deployment/resolve request actually lands.
(define %resolve-target
(delay
(module-ref (resolve-interface '(tribes deploy executor))
'resolve-target)))
(define (resolver-error-object? value)
(and (json-object? value)
(let ((ok-entry (assoc "ok" value))
(error-value (json-ref value "error")))
(and ok-entry
(eq? (cdr ok-entry) #f)
(json-object? error-value)))))
(define (resolve-deployment target)
(let ((result ((force %resolve-target) target)))
(if (resolver-error-object? result)
(values 409 result)
(values 200
`(("schemaVersion" . "2")
("ok" . #t)
("plan" . ,result))))))
;; ---------------------------------------------------------------------------
;; status / generations — flat reads.
(define (current-status state worker)
(cond
((and worker (not (worker-idle? worker)))
(worker-status worker))
(else
(state-store-read-status state))))
(define (list-generations-payload state)
`(("schemaVersion" . "2")
("ok" . #t)
("generations" . ,(state-store-read-generations state))))
(define (abort-prepare! state worker)
(state-store-write-status! state "aborted"
#:ok #t
#:reason "deployment aborted")
(when worker (worker-abort! worker))
`(("schemaVersion" . "2")
("ok" . #t)
("status" . "aborted")))
;; ---------------------------------------------------------------------------
;; prepare — synchronous entry, called from inside a worker job thunk.
;; ON-FRAME is called for every helper frame so the worker snapshot can be
;; refreshed in real time.
(define (record-host-config-update! state plugins)
(let* ((host-config-file (deploy-config-host-config-file
(state-store-config state)))
(host-config (read-json-file host-config-file))
(updated (host-config-with-plugins host-config plugins)))
(atomic-write-json-file host-config-file updated)))
(define (resolved-channel-url channel)
(or (json-ref channel "url") ""))
(define (resolved-channel-branch channel)
(or (json-ref channel "branch") "master"))
(define (resolved-channel-commit channel)
(or (json-ref channel "commit") ""))
(define (resolved-channel-introduction channel)
(let ((value (json-ref channel "introduction")))
(if (json-object? value) value '())))
(define (guix-channel-name channel)
'tribes)
(define (channel-form-name form)
(match form
(('channel fields ...)
(match (find (lambda (field)
(and (pair? field) (eq? (car field) 'name)))
fields)
(('name ('quote name)) name)
(('name name) name)
(_ #f)))
(_ #f)))
(define (existing-base-channel-forms channels-file)
(if (file-exists? channels-file)
(let ((form (false-if-exception
(call-with-input-file channels-file read))))
(match form
(('list forms ...)
(filter (lambda (form)
(not (eq? (channel-form-name form) 'tribes)))
forms))
(_ '())))
'()))
(define (write-scheme-string port value)
(write (or value "") port))
(define (write-channel-introduction port introduction)
(let ((commit (json-ref introduction "commit"))
(fingerprint (json-ref introduction "fingerprint")))
(when (and (string? commit) (string? fingerprint))
(display "\n (introduction\n (make-channel-introduction\n " port)
(write-scheme-string port commit)
(display "\n (openpgp-fingerprint\n " port)
(write-scheme-string port fingerprint)
(display ")))" port))))
(define (write-channel port channel)
(let ((commit (resolved-channel-commit channel))
(introduction (resolved-channel-introduction channel)))
(display " (channel\n (name '" port)
(display (guix-channel-name channel) port)
(display ")\n (url " port)
(write-scheme-string port (resolved-channel-url channel))
(display ")\n (branch " port)
(write-scheme-string port (resolved-channel-branch channel))
(display ")" port)
(unless (string=? commit "")
(display "\n (commit " port)
(write-scheme-string port commit)
(display ")" port))
(write-channel-introduction port introduction)
(display ")\n" port)))
(define (write-plan-channels! config plan)
(let ((channels (plan-resolved-channels plan)))
(when (and channels (not (null? channels)))
(let* ((channels-file (deploy-config-channels-file config))
(base-forms (existing-base-channel-forms channels-file)))
(call-with-output-file channels-file
(lambda (port)
(display "(list\n" port)
(for-each
(lambda (form)
(display " " port)
(write form port)
(newline port))
base-forms)
(for-each (lambda (channel) (write-channel port channel)) channels)
(display ")\n" port)))))))
(define (selected-system-path state)
(state-store-selected-system-path state))
(define (running-system-path state)
(state-store-running-system-path state))
(define* (prepare-plugins! state helper plugins plan-hash-value on-frame
#:key plan
(pull-required? #t))
(let* ((cfg (state-store-config state))
(existing (state-store-find-generation-by-plan-hash state plan-hash-value)))
(state-store-write-status! state "running"
#:plugins plugins
#:plan-hash plan-hash-value
#:phase "running")
(record-host-config-update! state plugins)
(when plan
(write-plan-channels! cfg plan))
(cond
;; Idempotency: if we already built this plan and the store path still
;; exists, just re-register the GC root and report ready.
((and existing
(integer? (json-ref existing "generation_number"))
(state-store-store-path-present? state (or (json-ref existing "store_path") "")))
(let* ((gen-number (json-ref existing "generation_number"))
(store-path (json-ref existing "store_path")))
(state-store-register-generation-root! state gen-number store-path)
(state-store-write-status! state "completed"
#:plugins plugins
#:plan-hash plan-hash-value
#:store-path store-path
#:selected-system (selected-system-path state)
#:running-system (running-system-path state)
#:phase "ready")
(success-payload "ready" store-path plan-hash-value gen-number #t
#:built-at (json-ref existing "built_at")
#:selected-system (selected-system-path state)
#:running-system (running-system-path state))))
(else
(let ((pull-result
(if pull-required?
(begin
(on-frame `(("event" . "phase") ("phase" . "pulling")))
((helper-backend-pull helper) cfg on-frame))
#f)))
(cond
((and pull-result (not (helper-result-ok? pull-result)))
(state-store-write-status! state "failed"
#:ok #f
#:plugins plugins
#:plan-hash plan-hash-value
#:reason (helper-result-message pull-result)
#:error-code (helper-result-code pull-result)
#:phase "failed")
(from-helper-failure pull-result #:plan-hash plan-hash-value))
(else
(let* ((gen-number (state-store-next-generation-number state))
(root-link (state-store-generation-link-path state gen-number)))
(on-frame `(("event" . "phase") ("phase" . "building")))
(let ((build-result
((helper-backend-build helper) cfg root-link on-frame)))
(cond
((not (helper-result-ok? build-result))
(state-store-write-status! state "failed"
#:ok #f
#:plugins plugins
#:plan-hash plan-hash-value
#:reason (helper-result-message build-result)
#:error-code (helper-result-code build-result)
#:phase "failed")
(from-helper-failure build-result #:plan-hash plan-hash-value))
(else
(let ((store-path
(or (json-ref (helper-result-payload build-result) "store_path")
(false-if-exception (canonicalize-path root-link))
(false-if-exception (readlink root-link))
"")))
(cond
((string=? store-path "")
(state-store-write-status! state "failed"
#:ok #f
#:plugins plugins
#:plan-hash plan-hash-value
#:reason "guix system build returned no store path"
#:error-code "build_failed"
#:phase "failed")
(failure-payload "guix system build returned no store path"
#:code "build_failed"
#:plan-hash plan-hash-value))
(else
(state-store-record-generation! state store-path
plan-hash-value
"ready"
#:generation-number gen-number
#:built-at #f
#:gc-pinned #t
#:plugins plugins)
(state-store-write-status! state "completed"
#:plugins plugins
#:plan-hash plan-hash-value
#:store-path store-path
#:selected-system (selected-system-path state)
#:running-system (running-system-path state)
#:phase "ready")
(success-payload "ready" store-path plan-hash-value
gen-number #t
#:built-at #f
#:selected-system (selected-system-path state)
#:running-system (running-system-path state))))))))))))))))
;; ---------------------------------------------------------------------------
;; commit — flips an already-prepared generation live.
(define (commit-plan! state helper plan-hash-value on-frame)
(let* ((cfg (state-store-config state))
(existing (state-store-find-generation-by-plan-hash state plan-hash-value)))
(cond
((not (and existing (integer? (json-ref existing "generation_number"))))
(failure-payload "generation_not_prepared"
#:code "generation_not_prepared"
#:plan-hash plan-hash-value))
(else
(on-frame `(("event" . "phase") ("phase" . "switching")))
(let* ((gen-number (json-ref existing "generation_number"))
(switch-result ((helper-backend-switch helper) cfg gen-number on-frame)))
(cond
((not (helper-result-ok? switch-result))
(state-store-write-status! state "failed"
#:ok #f
#:plan-hash plan-hash-value
#:reason (helper-result-message switch-result)
#:error-code "switch_failed"
#:phase "failed")
(from-helper-failure switch-result #:plan-hash plan-hash-value))
(else
(let* ((selected-store-path
(let ((path (selected-system-path state)))
(if (and (string? path)
(not (string=? path "unknown")))
path
(or (json-ref existing "store_path") "unknown"))))
(running-store-path (running-system-path state))
(active-generation-number
(or (state-store-current-generation-number state)
gen-number)))
(state-store-record-generation! state selected-store-path plan-hash-value
"active"
#:generation-number
active-generation-number
#:built-at (json-ref existing "built_at")
#:activated-at #f
#:gc-pinned #t
#:plugins
(or (json-string-list-ref existing "plugins") '()))
(state-store-activate-generation! state selected-store-path)
(state-store-write-status! state "completed"
#:plan-hash plan-hash-value
#:store-path selected-store-path
#:selected-system selected-store-path
#:running-system running-store-path
#:generation-number active-generation-number
#:phase "active")
(success-payload "healthy" selected-store-path plan-hash-value
active-generation-number
#t
#:built-at (json-ref existing "built_at")
#:activated-at #f
#:selected-system selected-store-path
#:running-system running-store-path)))))))))
;; ---------------------------------------------------------------------------
;; rollback — three cases:
;; 1. The requested store-path is already current → just record activation.
;; 2. We have a recorded generation number → switch to it.
;; 3. We have a plan to rebuild from → recurse via prepare+commit.
(define system-herd "/run/current-system/profile/bin/herd")
(define rollback-herd-command (make-parameter #f))
(define (current-herd-command)
(or (rollback-herd-command)
(if (file-exists? system-herd) system-herd "herd")))
(define (rollback-plugin-migrations!)
;; Rollback is destructive by definition for plugin uninstall/downgrade in
;; pre-release Tribes. Stop the app first so plugin code is not touching tables
;; while release helpers run down migrations from the currently selected
;; generation, then let the subsequent system switch restart the target app.
(let ((herd (current-herd-command)))
(system* herd "stop" "tribes")
(zero? (system* herd "start" "tribes-plugin-rollback-migrations"))))
(define (rollback-store-path! state helper store-path maybe-plan on-frame)
(let ((cfg (state-store-config state))
(selected-system (selected-system-path state))
(generation (or (state-store-find-generation-by-store-path state store-path)
(state-store-find-profile-generation-by-store-path state
store-path))))
(cond
((string=? store-path selected-system)
(state-store-activate-generation! state store-path)
(state-store-write-status! state "completed"
#:store-path store-path
#:selected-system store-path
#:running-system (running-system-path state)
#:generation-number
(or (and generation (json-ref generation "generation_number"))
(state-store-current-generation-number state))
#:phase "active")
(success-payload "healthy" store-path
(or (and generation (json-ref generation "plan_hash")) "")
(or (and generation (json-ref generation "generation_number"))
(state-store-current-generation-number state))
#t
#:activated-at #f
#:selected-system store-path
#:running-system (running-system-path state)))
((and generation (integer? (json-ref generation "generation_number")))
(if (not (rollback-plugin-migrations!))
(failure-payload "plugin_migration_rollback_failed"
#:code "plugin_migration_rollback_failed"
#:store-path store-path)
(let* ((target-plugins (or (json-string-list-ref generation "plugins") '()))
(_ (record-host-config-update! state target-plugins))
(gen-number (json-ref generation "generation_number"))
(switch-result ((helper-backend-switch helper) cfg gen-number on-frame)))
(cond
((helper-result-ok? switch-result)
(let* ((active-store-path
(let ((path (selected-system-path state)))
(if (and (string? path)
(not (string=? path "unknown")))
path
store-path)))
(running-store-path (running-system-path state))
(active-generation-number
(or (state-store-current-generation-number state)
(json-ref generation "generation_number"))))
(state-store-record-generation! state active-store-path
(or (json-ref generation "plan_hash") "")
"active"
#:generation-number
active-generation-number
#:built-at (json-ref generation "built_at")
#:activated-at #f
#:gc-pinned #t
#:plugins target-plugins)
(state-store-activate-generation! state active-store-path)
(state-store-write-status! state "completed"
#:store-path active-store-path
#:selected-system active-store-path
#:running-system running-store-path
#:plan-hash (json-ref generation "plan_hash")
#:generation-number active-generation-number
#:phase "active")
(success-payload "healthy" active-store-path
(or (json-ref generation "plan_hash") "")
active-generation-number
#t
#:activated-at #f
#:selected-system active-store-path
#:running-system running-store-path)))
(maybe-plan
(rollback-with-plan state helper maybe-plan on-frame))
(else
(failure-payload "rollback_infeasible"
#:code "rollback_infeasible"
#:store-path store-path))))))
(maybe-plan
(rollback-with-plan state helper maybe-plan on-frame))
(else
(failure-payload "rollback_infeasible"
#:code "rollback_infeasible"
#:store-path store-path)))))
(define (rollback-with-plan state helper plan on-frame)
(let* ((plan-hash-value (plan-hash plan))
(prepared (prepare-plugins! state helper (plan-plugins plan)
plan-hash-value on-frame
#:plan plan
#:pull-required?
(plan-requires-pull? plan))))
(if (equal? (json-ref prepared "ok") #t)
(commit-plan! state helper plan-hash-value on-frame)
prepared)))
;; ---------------------------------------------------------------------------
;; Async wrappers — submit the synchronous operation as a worker job. These
;; return either a 202 envelope or a 409 envelope; the actual completion is
;; observed by polling /v1/deployment/status.
(define (queued-payload status snapshot)
(cons (cons "schemaVersion" "2")
(cons (cons "status" status)
(filter (lambda (e)
(not (member (car e) '("schemaVersion" "status"))))
snapshot))))
(define (busy-payload snapshot)
`(("schemaVersion" . "2")
("ok" . #f)
("status" . "busy")
("reason" . "deployment already in progress")
,@(filter (lambda (e)
(not (member (car e) '("schemaVersion" "status" "ok"))))
snapshot)))
(define* (submit-prepare! state worker helper plugins plan-hash-value
#:key plan
(pull-required? #t))
(call-with-values
(lambda ()
(worker-submit!
worker 'prepare plan-hash-value
(lambda (update!)
(let ((on-frame
(lambda (frame)
(let ((phase (or (json-ref frame "phase") "running")))
(update! phase)))))
(%make-job-result-from-payload
(prepare-plugins! state helper plugins
plan-hash-value on-frame
#:plan plan
#:pull-required? pull-required?))))))
(lambda (status snapshot)
(case status
((accepted idempotent)
(values 202 (queued-payload "queued" snapshot)))
((busy)
(values 409 (busy-payload snapshot)))))))
(define (submit-commit! state worker helper plan-hash-value)
(call-with-values
(lambda ()
(worker-submit!
worker 'commit plan-hash-value
(lambda (update!)
(let ((on-frame
(lambda (frame)
(let ((phase (or (json-ref frame "phase") "switching")))
(update! phase)))))
(%make-job-result-from-payload
(commit-plan! state helper plan-hash-value on-frame))))))
(lambda (status snapshot)
(case status
((accepted idempotent)
(values 202 (queued-payload "queued" snapshot)))
((busy)
(values 409 (busy-payload snapshot)))))))
(define (submit-rollback! state worker helper store-path maybe-plan)
(call-with-values
(lambda ()
(worker-submit!
worker 'rollback (and maybe-plan (plan-hash maybe-plan))
(lambda (update!)
(let ((on-frame
(lambda (frame)
(let ((phase (or (json-ref frame "phase") "switching")))
(update! phase)))))
(%make-job-result-from-payload
(rollback-store-path! state helper store-path
maybe-plan on-frame))))))
(lambda (status snapshot)
(case status
((accepted idempotent)
(values 202 (queued-payload "queued" snapshot)))
((busy)
(values 409 (busy-payload snapshot)))))))
;; The worker expects job thunks to return <job-result>. Wrap the operation
;; payload accordingly so the worker can stash it as the final snapshot.
(define (%make-job-result-from-payload payload)
(make-job-result (equal? (json-ref payload "ok") #t) payload))
tribes/deploy/plan.scm
-126
View File
@@ -1,126 +0,0 @@
(define-module (tribes deploy plan)
#:use-module (ice-9 match)
#:use-module (json)
#:use-module (srfi srfi-1)
#:use-module (tribes deploy json)
#:export (assoc-set
plugin-entry-name
plugin-entry-enabled?
plugin-entry-channel-id
deployment-request-plugins
host-config-with-plugins
system-target-plugin-names
plan-plugins
plan-resolved-channels
plan-requires-pull?
plan-hash
string-plan-hash))
;; ---------------------------------------------------------------------------
;; Pure JSON helpers used by both the broker boot path and the resolver.
;;
;; Kept in a dedicated module — separate from (tribes deploy executor) — so
;; that handlers.scm, operations.scm, and cli.scm can pull in the cheap
;; helpers without dragging the resolver's (guix packages)/(tribes packages
;; plugins) dependencies into the broker's startup path. Loading the
;; resolver costs several seconds and pulls a large chunk of the Guix
;; module tree; it is now deferred until a /v1/deployment/resolve request
;; actually arrives.
(define (assoc-set object key value)
(let loop ((remaining object) (result '()) (updated? #f))
(cond
((null? remaining)
(reverse
(if updated?
result
(cons (cons key value) result))))
((equal? (caar remaining) key)
(loop (cdr remaining)
(cons (cons key value) result)
#t))
(else
(loop (cdr remaining)
(cons (car remaining) result)
updated?)))))
(define (plugin-entry-name plugin)
(or (json-ref plugin "plugin_name")
(json-ref plugin "pluginName")
(json-ref plugin "name")))
(define (plugin-entry-enabled? plugin)
(let ((enabled (json-bool-ref plugin "enabled")))
(if (boolean? enabled) enabled #t)))
(define (plugin-entry-channel-id plugin)
(or (json-ref plugin "channel_id")
(json-ref plugin "channelId")))
(define (deployment-request-plugins request)
(let* ((deployment-profile (json-ref request "deploymentProfile"))
(plugins (or (json-string-list-ref request "plugins")
(and (json-object? deployment-profile)
(json-string-list-ref deployment-profile
"plugins")))))
(or plugins '())))
(define (host-config-with-plugins host-config plugin-names)
(unless (json-object? host-config)
(error "host config must be a JSON object"))
(let ((tribes-config (json-ref host-config "tribes")))
(unless (json-object? tribes-config)
(error "host config is missing tribes object"))
(assoc-set host-config
"tribes"
(assoc-set tribes-config "plugins" plugin-names))))
(define (system-target-plugin-names target)
(let ((plugins (or (json-list-ref target "plugins") '())))
(sort
(filter-map
(lambda (plugin)
(and (json-object? plugin)
(plugin-entry-enabled? plugin)
(let ((name (plugin-entry-name plugin)))
(and (string? name) name))))
plugins)
string<?)))
(define (plan-plugins plan)
(let ((resolved (or (json-list-ref plan "resolved_plugins")
(json-list-ref plan "resolvedPlugins")
'())))
(sort
(filter-map
(lambda (plugin)
(and (json-object? plugin)
(let ((name (or (json-ref plugin "name")
(plugin-entry-name plugin))))
(and (string? name) name))))
resolved)
string<?)))
(define (plan-resolved-channels plan)
(or (json-list-ref plan "resolved_channels")
(json-list-ref plan "resolvedChannels")))
(define (plan-requires-pull? plan)
(let ((channels (plan-resolved-channels plan)))
(or (not channels)
(not (null? channels)))))
(define (canonical-json-string value)
(call-with-output-string
(lambda (port)
(scm->json value port))))
(define (string-plan-hash value)
(let* ((payload (canonical-json-string value))
(hash-value (hash payload 2147483647)))
(string-append "plan-" (number->string (abs hash-value) 16))))
(define (plan-hash plan)
(or (json-ref plan "plan_hash")
(json-ref plan "planHash")
(string-plan-hash plan)))
tribes/deploy/state.scm
-307
View File
@@ -1,307 +0,0 @@
(define-module (tribes deploy state)
#:use-module (guix build utils)
#:use-module (ice-9 ftw)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (ice-9 threads)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (tribes deploy config)
#:use-module (tribes deploy json)
#:export (make-state-store
state-store?
state-store-config
state-store-ensure-directory!
state-store-read-status
state-store-write-status!
state-store-active?
state-store-read-generations
state-store-write-generations!
state-store-find-generation-by-store-path
state-store-find-profile-generation-by-store-path
state-store-find-generation-by-plan-hash
state-store-upsert-generation!
state-store-activate-generation!
state-store-record-generation!
state-store-selected-system-path
state-store-running-system-path
state-store-current-generation-number
state-store-next-generation-number
state-store-generation-link-path
state-store-register-generation-root!
state-store-known-profile-generations
state-store-store-path-present?
json-put))
;; ---------------------------------------------------------------------------
;; <state-store> — owns the deploy directory. All writes go through atomic
;; tempfile+rename so a crash mid-write cannot leave a torn file. A single
;; mutex serializes accesses from the broker; cross-process consumers (CLI)
;; stay safe because every write is atomic at the filesystem level.
(define-record-type <state-store>
(%make-state-store config mutex)
state-store?
(config state-store-config)
(mutex state-store-mutex))
(define (make-state-store config)
(%make-state-store config (make-mutex)))
(define (with-store-lock store thunk)
(with-mutex (state-store-mutex store) (thunk)))
(define (state-store-ensure-directory! store)
(let ((dir (deploy-config-deploy-directory (state-store-config store))))
(unless (file-exists? dir)
(mkdir-p dir))))
;; ---------------------------------------------------------------------------
;; status.json
(define %idle-status
'(("schemaVersion" . "2")
("ok" . #t)
("status" . "idle")))
(define (state-store-read-status store)
(with-store-lock store
(lambda ()
(let ((path (deploy-config-status-file (state-store-config store))))
(if (and path (file-exists? path))
(read-json-file path)
%idle-status)))))
(define* (state-store-write-status! store status
#:key
(ok #t)
reason
plugins
selected-system
running-system
plan-hash
job-id
phase
store-path
generation-number
error-code
started-at
last-event-at
built-at
activated-at)
(state-store-ensure-directory! store)
(with-store-lock store
(lambda ()
(let ((path (deploy-config-status-file (state-store-config store))))
(atomic-write-json-file
path
`(("schemaVersion" . "2")
("ok" . ,ok)
("status" . ,status)
,@(if reason `(("reason" . ,reason)) '())
,@(if plugins `(("plugins" . ,plugins)) '())
,@(if selected-system `(("selectedSystem" . ,selected-system)) '())
,@(if running-system `(("runningSystem" . ,running-system)) '())
,@(if plan-hash `(("plan_hash" . ,plan-hash)) '())
,@(if job-id `(("job_id" . ,job-id)) '())
,@(if phase `(("phase" . ,phase)) '())
,@(if store-path `(("store_path" . ,store-path)) '())
,@(if generation-number `(("generation_number" . ,generation-number)) '())
,@(if error-code `(("code" . ,error-code)) '())
,@(if started-at `(("started_at" . ,started-at)) '())
,@(if last-event-at `(("last_event_at" . ,last-event-at)) '())
,@(if built-at `(("built_at" . ,built-at)) '())
,@(if activated-at `(("activated_at" . ,activated-at)) '())))))))
(define (state-store-active? store)
(let ((status (state-store-read-status store)))
(member (json-ref status "status") '("queued" "running" "pulling"
"building" "switching"))))
;; ---------------------------------------------------------------------------
;; generations.json — list of recorded generations. Atomic writes keep
;; readers (the BEAM, the CLI) safe.
(define (state-store-read-generations store)
(with-store-lock store
(lambda ()
(let ((path (deploy-config-generations-file (state-store-config store))))
(if (and path (file-exists? path))
(let ((payload (read-json-file path)))
(cond
((vector? payload) (vector->list payload))
((list? payload) payload)
(else '())))
'())))))
(define (state-store-write-generations! store generations)
(state-store-ensure-directory! store)
(with-store-lock store
(lambda ()
(let ((path (deploy-config-generations-file (state-store-config store))))
(atomic-write-json-file path generations)))))
(define (path-present? path)
(and (string? path)
(false-if-exception (lstat path))
#t))
(define (state-store-store-path-present? _store store-path)
(path-present? store-path))
;; ---------------------------------------------------------------------------
;; Profile / current-system inspection
(define (state-store-link-target-path link)
(or (and link (false-if-exception (canonicalize-path link)))
(and link (false-if-exception (readlink link)))
"unknown"))
(define (state-store-selected-system-path store)
(state-store-link-target-path
(deploy-config-system-profile-link (state-store-config store))))
(define (state-store-running-system-path store)
(state-store-link-target-path
(deploy-config-current-system-link (state-store-config store))))
(define %generation-link-rx (make-regexp "system-([0-9]+)-link"))
(define (state-store-current-generation-number store)
(let* ((link (deploy-config-system-profile-link (state-store-config store)))
(target (and link (false-if-exception (readlink link)))))
(and (string? target)
(let ((m (regexp-exec %generation-link-rx target)))
(and m (string->number (match:substring m 1)))))))
(define (state-store-generation-link-path store generation-number)
(string-append (deploy-config-system-profile-directory
(state-store-config store))
"/system-"
(number->string generation-number)
"-link"))
(define %profile-link-rx (make-regexp "^system-([0-9]+)-link$"))
(define (state-store-known-profile-generations store)
(let ((dir (deploy-config-system-profile-directory
(state-store-config store))))
(if (and dir (file-exists? dir))
(filter-map
(lambda (entry)
(let ((m (regexp-exec %profile-link-rx entry)))
(and m (string->number (match:substring m 1)))))
(scandir dir))
'())))
(define (known-recorded-generation-numbers store)
(filter-map
(lambda (gen)
(let ((n (json-ref gen "generation_number")))
(and (integer? n) n)))
(state-store-read-generations store)))
(define (state-store-next-generation-number store)
(let ((numbers (append (state-store-known-profile-generations store)
(known-recorded-generation-numbers store))))
(if (null? numbers) 1 (+ 1 (apply max numbers)))))
(define (state-store-register-generation-root! store generation-number store-path)
(let ((link (state-store-generation-link-path store generation-number)))
(when (path-present? link) (delete-file link))
(symlink store-path link)
link))
;; ---------------------------------------------------------------------------
;; Generation entries
(define (json-put object key value)
(cons (cons key value)
(filter (lambda (entry) (not (string=? (car entry) key))) object)))
(define (generation-store-path g) (or (json-ref g "store_path") ""))
(define (generation-plan-hash g) (or (json-ref g "plan_hash") ""))
(define (state-store-find-generation-by-store-path store store-path)
(find (lambda (g) (string=? (generation-store-path g) store-path))
(state-store-read-generations store)))
(define (state-store-find-profile-generation-by-store-path store store-path)
"Return a generation-like entry for STORE-PATH by inspecting Guix's system
profile links. This covers the installed baseline generation, which may
predate the local-control deployment state and therefore may not appear in
`generations.json'."
(let ((matches
(filter-map
(lambda (generation-number)
(let* ((link (state-store-generation-link-path store generation-number))
(target (state-store-link-target-path link)))
(and (string? target)
(string=? target store-path)
`(("store_path" . ,target)
("generation_number" . ,generation-number)
("plan_hash" . "")
("status" . "profile")))))
(state-store-known-profile-generations store))))
(and (not (null? matches)) (car matches))))
(define (state-store-find-generation-by-plan-hash store plan-hash)
(find (lambda (g) (string=? (generation-plan-hash g) plan-hash))
(state-store-read-generations store)))
(define (state-store-upsert-generation! store generation)
(let* ((sp (generation-store-path generation))
(ph (generation-plan-hash generation))
(remaining
(filter
(lambda (entry)
(and (not (string=? (generation-store-path entry) sp))
(or (string=? ph "")
(not (string=? (generation-plan-hash entry) ph)))))
(state-store-read-generations store)))
(updated (cons generation remaining)))
(state-store-write-generations! store updated)
generation))
(define (state-store-activate-generation! store store-path)
(let ((activated #f))
(let ((updated
(map
(lambda (g)
(cond
((string=? (generation-store-path g) store-path)
(set! activated
(json-put (json-put g "status" "active")
"activated_at" #f))
activated)
((string=? (or (json-ref g "status") "") "active")
(json-put g "status" "superseded"))
(else g)))
(state-store-read-generations store))))
(when activated
(state-store-write-generations! store updated))
activated)))
(define* (state-store-record-generation! store
store-path
plan-hash
generation-status
#:key
generation-number
built-at
activated-at
(gc-pinned #t)
(plugins #f))
(let ((generation
`(("store_path" . ,store-path)
("generation_number" . ,generation-number)
("plan_hash" . ,plan-hash)
("status" . ,generation-status)
("gc_pinned" . ,gc-pinned)
("built_at" . ,built-at)
("activated_at" . ,activated-at)
,@(if plugins `(("plugins" . ,plugins)) '()))))
(state-store-upsert-generation! store generation)
(when (string=? generation-status "active")
(state-store-activate-generation! store store-path))
generation))
tribes/deploy/worker.scm
-253
View File
@@ -1,253 +0,0 @@
(define-module (tribes deploy worker)
#:use-module (ice-9 atomic)
#:use-module (ice-9 match)
#:use-module (ice-9 q)
#:use-module (ice-9 threads)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-19)
#:use-module (tribes deploy config)
#:use-module (tribes deploy state)
#:export (make-worker
worker?
worker-config
worker-state
worker-status
worker-snapshot
worker-submit!
worker-abort!
worker-shutdown!
worker-idle?
make-job-result
job-result?
job-result-ok?
job-result-payload))
;; ---------------------------------------------------------------------------
;; Concurrency model. One POSIX thread, one job at a time. The web server
;; (or CLI) submits a job-thunk to the queue and immediately returns a
;; snapshot describing its state. The worker thread runs the thunk, calling
;; back into a status updater so polling endpoints see phase progression
;; without ever blocking on the build itself.
(define-record-type <worker>
(%make-worker config state mutex condvar queue snapshot
shutdown-flag thread)
worker?
(config worker-config)
(state worker-state)
(mutex worker-mutex)
(condvar worker-condvar)
(queue worker-queue)
(snapshot worker-snapshot) ;; <atomic-box> of an alist
(shutdown-flag worker-shutdown-flag) ;; <atomic-box> #t/#f
(thread worker-thread set-worker-thread!))
(define-record-type <job-result>
(make-job-result ok? payload)
job-result?
(ok? job-result-ok?)
(payload job-result-payload))
;; A job is a record threaded through the queue:
(define-record-type <job>
(%make-job id action plan-hash thunk started-at result-cell)
job?
(id job-id)
(action job-action)
(plan-hash job-plan-hash)
(thunk job-thunk)
(started-at job-started-at)
(result-cell job-result-cell)) ;; <atomic-box> of <job-result> or #f
;; ---------------------------------------------------------------------------
;; Snapshot helpers — the snapshot is the JSON shape returned by GET /status.
(define %idle-snapshot
'(("schemaVersion" . "2")
("ok" . #t)
("status" . "idle")
("phase" . "idle")))
(define (now-iso8601)
(date->string (time-utc->date (current-time time-utc) 0)
"~Y-~m-~dT~H:~M:~SZ"))
(define (snapshot-with-fields base . fields)
(let loop ((object base) (entries fields))
(match entries
(() object)
((key value . rest)
(loop
(cond
((not value) (filter (lambda (e) (not (string=? (car e) key))) object))
(else
(cons (cons key value)
(filter (lambda (e) (not (string=? (car e) key))) object))))
rest)))))
(define (worker-status worker)
(atomic-box-ref (worker-snapshot worker)))
(define (worker-idle? worker)
(let ((status (assoc "status" (worker-status worker))))
(and status (string=? (cdr status) "idle"))))
(define (set-snapshot! worker snapshot)
(atomic-box-set! (worker-snapshot worker) snapshot))
(define (with-snapshot! worker updater)
(let ((current (atomic-box-ref (worker-snapshot worker))))
(atomic-box-set! (worker-snapshot worker) (updater current))))
(define (job->snapshot job phase extra)
(apply snapshot-with-fields
`(("schemaVersion" . "2")
("ok" . #t)
("status" . ,phase)
("phase" . ,phase)
("job_id" . ,(job-id job))
("plan_hash" . ,(job-plan-hash job))
("started_at" . ,(job-started-at job))
("last_event_at" . ,(now-iso8601)))
extra))
;; ---------------------------------------------------------------------------
;; Worker thread loop.
(define (worker-loop worker)
(let loop ()
(let ((job (with-mutex (worker-mutex worker)
(let pop ()
(cond
((atomic-box-ref (worker-shutdown-flag worker)) #f)
((q-empty? (worker-queue worker))
(wait-condition-variable (worker-condvar worker)
(worker-mutex worker))
(pop))
(else (deq! (worker-queue worker))))))))
(cond
((not job)
;; Shutdown.
#t)
(else
(run-job worker job)
(loop))))))
(define (run-job worker job)
;; The job thunk gets a (update-snapshot! phase extras) callback so it can
;; stream phase progression while running. We default to "running".
(set-snapshot! worker (job->snapshot job "running" '()))
(let* ((update-snapshot!
(lambda (phase . extras)
(set-snapshot! worker (job->snapshot job phase extras))))
(result
(catch #t
(lambda () ((job-thunk job) update-snapshot!))
(lambda (key . args)
(make-job-result
#f
`(("schemaVersion" . "2")
("ok" . #f)
("status" . "failed")
("phase" . "failed")
("code" . "broker_internal")
("reason"
. ,(format #f "worker thread caught ~a: ~a" key args))
("plan_hash" . ,(job-plan-hash job))
("job_id" . ,(job-id job))))))))
(atomic-box-set! (job-result-cell job) result)
(set-snapshot! worker
(snapshot-with-fields
(job-result-payload result)
"job_id" (job-id job)
"last_event_at" (now-iso8601)))))
;; ---------------------------------------------------------------------------
;; Public API.
(define (make-worker config state)
(let* ((mutex (make-mutex))
(condvar (make-condition-variable))
(queue (make-q))
(snapshot (make-atomic-box %idle-snapshot))
(shutdown-flag (make-atomic-box #f))
(worker (%make-worker config state mutex condvar queue snapshot
shutdown-flag #f)))
(set-worker-thread! worker
(call-with-new-thread
(lambda () (worker-loop worker))))
worker))
(define %job-counter (make-atomic-box 0))
(define (next-job-id)
(let loop ()
(let* ((current (atomic-box-ref %job-counter))
(next (+ current 1)))
(if (eq? current
(atomic-box-compare-and-swap! %job-counter current next))
(string-append "job-" (number->string next))
(loop)))))
(define (current-job-of worker)
(with-mutex (worker-mutex worker)
(let* ((status (atomic-box-ref (worker-snapshot worker)))
(phase (assoc "phase" status))
(job-id (assoc "job_id" status))
(plan-hash (assoc "plan_hash" status)))
(and phase
(member (cdr phase)
'("queued" "running" "pulling" "building" "switching"))
job-id
`((id . ,(cdr job-id))
(plan-hash . ,(and plan-hash (cdr plan-hash))))))))
(define* (worker-submit! worker action plan-hash thunk)
"Submit a job to WORKER. THUNK takes a single argument, an
update-snapshot! callback (lambda (phase . extras) ...). Returns:
(values 'accepted snapshot) when a new job is queued
(values 'idempotent snapshot) when the running job has the same
plan-hash (caller can poll for it)
(values 'busy current-snapshot) when a different job is in flight"
(let ((current (current-job-of worker)))
(cond
((and current
(string? plan-hash)
(equal? plan-hash (assq-ref current 'plan-hash)))
(values 'idempotent (worker-status worker)))
(current
(values 'busy (worker-status worker)))
(else
(let* ((job (%make-job (next-job-id)
action
plan-hash
thunk
(now-iso8601)
(make-atomic-box #f)))
(snapshot (job->snapshot job "queued" '())))
(set-snapshot! worker snapshot)
(with-mutex (worker-mutex worker)
(enq! (worker-queue worker) job)
(signal-condition-variable (worker-condvar worker)))
(values 'accepted snapshot))))))
(define (worker-abort! worker)
"Mark the current job as aborted in the snapshot. Does not currently
SIGTERM a running helper subprocess — that is a follow-up. Returns the
post-abort snapshot."
(with-snapshot! worker
(lambda (current)
(snapshot-with-fields
current
"status" "aborted"
"phase" "aborted"
"ok" #t
"last_event_at" (now-iso8601))))
(worker-status worker))
(define (worker-shutdown! worker)
(atomic-box-set! (worker-shutdown-flag worker) #t)
(with-mutex (worker-mutex worker)
(signal-condition-variable (worker-condvar worker)))
(when (worker-thread worker)
(false-if-exception (join-thread (worker-thread worker)))))
tribes/diagnostics/system-generations.scm
-407
View File
@@ -1,407 +0,0 @@
(define-module (tribes diagnostics system-generations)
#:use-module (gnu services)
#:use-module (gnu services shepherd)
#:use-module (gnu system)
#:use-module (guix derivations)
#:use-module (guix gexp)
#:use-module (guix monads)
#:use-module (guix store)
#:use-module (ice-9 format)
#:use-module (ice-9 match)
#:use-module (json)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-13)
#:export (compare-system-generations-main))
(define (usage)
(format #t "Usage: compare-system-generations.scm OLD-CONFIG NEW-CONFIG [OPTIONS]~%")
(format #t "~%")
(format #t "Compare two Guix system configurations at the service and store-reference level.~%")
(format #t "~%")
(format #t "Options:~%")
(format #t " --old-system PATH Existing old system store path (for reference diffs)~%")
(format #t " --new-system PATH Existing new system store path (for reference diffs)~%")
(format #t " --full-closure Include full closure diffs for the supplied system paths~%")
(format #t " --pretty Pretty-print JSON output~%")
(format #t " -h, --help Show this help~%")
(exit 0))
(define (fail fmt . args)
(apply format (current-error-port) fmt args)
(newline (current-error-port))
(exit 1))
(define (json-object? value)
(and (list? value)
(every (lambda (entry)
(and (pair? entry)
(or (string? (car entry))
(symbol? (car entry)))))
value)))
(define (json-ref object key)
(and (json-object? object)
(let ((entry (assoc key object)))
(and entry (cdr entry)))))
(define (stringify value)
(cond
((symbol? value) (symbol->string value))
((boolean? value) value)
((number? value) value)
((string? value) value)
((null? value) #())
((vector? value) (list->vector (map stringify (vector->list value))))
((json-object? value)
(map (lambda (entry)
(cons (stringify (car entry))
(stringify (cdr entry))))
value))
((pair? value) (list->vector (map stringify value)))
(else (format #f "~a" value))))
(define (emit-json payload pretty?)
(let ((json-value (stringify payload)))
(if pretty?
(begin
(display (scm->json-string json-value #:pretty #t))
(newline))
(begin
(scm->json json-value (current-output-port))
(newline)))))
(define (string-list<? left right)
(string<? left right))
(define (store-item-summary path)
`(("path" . ,path)
("name" . ,(basename path))))
(define (store-item-diff old-items new-items)
(let* ((removed (sort (lset-difference string=? old-items new-items) string-list<?))
(added (sort (lset-difference string=? new-items old-items) string-list<?)))
`(("added" . ,(map store-item-summary added))
("removed" . ,(map store-item-summary removed))
("addedCount" . ,(length added))
("removedCount" . ,(length removed)))))
(define %top-level-store-item-rx
(make-regexp "^/gnu/store/[^/]+$"))
(define (top-level-store-item? path)
(and (string? path)
(regexp-exec %top-level-store-item-rx path)
#t))
(define (path->store-item path)
"Resolve PATH to a queryable top-level Guix store item when possible.
Guix store RPCs such as `references' require a store item like
/gnu/store/HASH-NAME, not a subpath such as /gnu/store/HASH-system/profile.
System generation members are often symlinks to top-level store items, so
canonicalize first and skip reference queries when the result is still a
subpath."
(let ((resolved (or (and (string? path)
(false-if-exception (canonicalize-path path)))
path)))
(and (top-level-store-item? resolved) resolved)))
(define* (skipped-store-item-diff reason #:key old-store-item new-store-item)
`(("added" . ())
("removed" . ())
("addedCount" . 0)
("removedCount" . 0)
("skipped" . #t)
("reason" . ,reason)
,@(if old-store-item `(("oldStoreItem" . ,old-store-item)) '())
,@(if new-store-item `(("newStoreItem" . ,new-store-item)) '())))
(define (safe-store-reference-diff old-store-item new-store-item)
(catch #t
(lambda ()
(store-item-diff (store-path-references old-store-item)
(store-path-references new-store-item)))
(lambda (key . args)
(skipped-store-item-diff
(format #f "store reference query failed: ~a: ~s" key args)
#:old-store-item old-store-item
#:new-store-item new-store-item))))
(define (safe-store-closure-diff old-store-item new-store-item)
(catch #t
(lambda ()
(store-item-diff (store-path-requisites old-store-item)
(store-path-requisites new-store-item)))
(lambda (key . args)
(skipped-store-item-diff
(format #f "store closure query failed: ~a: ~s" key args)
#:old-store-item old-store-item
#:new-store-item new-store-item))))
(define (with-store-result proc)
(with-store store
(run-with-store store (proc store))))
(define (realize-file-like->path file-like)
(with-store-result
(lambda (_store)
(mlet %store-monad ((lowered (lower-object file-like)))
(cond
((derivation? lowered)
(mbegin %store-monad
(built-derivations (list lowered))
(return (derivation->output-path lowered))))
((string? lowered)
(return lowered))
(else
(return (format #f "~a" lowered))))))))
(define (store-path-references path)
(with-store store
(sort (references store path) string-list<?)))
(define (store-path-requisites path)
(with-store store
(sort (requisites store (list path)) string-list<?)))
(define (load-operating-system config-file)
(unless (file-exists? config-file)
(fail "configuration file does not exist: ~a" config-file))
(let ((os (primitive-load config-file)))
(unless (operating-system? os)
(fail "configuration did not evaluate to an operating-system: ~a" config-file))
os))
(define (operating-system-shepherd-services os)
(shepherd-configuration-services
(service-value
(fold-services (operating-system-services os)
#:target-type shepherd-root-service-type))))
(define (service-summary service)
(let* ((name (symbol->string (shepherd-service-canonical-name service)))
(provisions (sort (map symbol->string (shepherd-service-provision service)) string-list<?))
(requirements (sort (map symbol->string (shepherd-service-requirement service)) string-list<?))
(file (realize-file-like->path (shepherd-service-file service))))
`(("name" . ,name)
("provisions" . ,provisions)
("requirements" . ,requirements)
("oneShot" . ,(shepherd-service-one-shot? service))
("autoStart" . ,(shepherd-service-auto-start? service))
("file" . ,file))))
(define (service-name summary)
(or (json-ref summary "name") ""))
(define (service-file summary)
(or (json-ref summary "file") ""))
(define (service-provisions summary)
(or (json-ref summary "provisions") '()))
(define (service-requirements summary)
(or (json-ref summary "requirements") '()))
(define (service-one-shot? summary)
(json-ref summary "oneShot"))
(define (service-auto-start? summary)
(json-ref summary "autoStart"))
(define (services->alist summaries)
(map (lambda (summary)
(cons (service-name summary) summary))
summaries))
(define (lookup-service services name)
(let ((entry (assoc name services)))
(and entry (cdr entry))))
(define (service-unchanged? old-summary new-summary)
(and (string=? (service-file old-summary) (service-file new-summary))
(equal? (service-provisions old-summary) (service-provisions new-summary))
(equal? (service-requirements old-summary) (service-requirements new-summary))
(equal? (service-one-shot? old-summary) (service-one-shot? new-summary))
(equal? (service-auto-start? old-summary) (service-auto-start? new-summary))))
(define (service-change-entry old-summary new-summary)
(let* ((old-file (service-file old-summary))
(new-file (service-file new-summary))
(file-ref-diff (if (and (string? old-file)
(not (string=? old-file ""))
(string? new-file)
(not (string=? new-file "")))
(store-item-diff (store-path-references old-file)
(store-path-references new-file))
`(("added" . ())
("removed" . ())
("addedCount" . 0)
("removedCount" . 0)))))
`(("name" . ,(service-name new-summary))
("oldFile" . ,old-file)
("newFile" . ,new-file)
("oldProvisions" . ,(service-provisions old-summary))
("newProvisions" . ,(service-provisions new-summary))
("oldRequirements" . ,(service-requirements old-summary))
("newRequirements" . ,(service-requirements new-summary))
("oldOneShot" . ,(service-one-shot? old-summary))
("newOneShot" . ,(service-one-shot? new-summary))
("oldAutoStart" . ,(service-auto-start? old-summary))
("newAutoStart" . ,(service-auto-start? new-summary))
("fileReferenceDiff" . ,file-ref-diff))))
(define (service-diff old-services new-services)
(let* ((old-alist (services->alist old-services))
(new-alist (services->alist new-services))
(old-names (sort (map car old-alist) string-list<?))
(new-names (sort (map car new-alist) string-list<?))
(added-names (sort (lset-difference string=? new-names old-names) string-list<?))
(removed-names (sort (lset-difference string=? old-names new-names) string-list<?))
(common-names (sort (lset-intersection string=? old-names new-names) string-list<?))
(changed '())
(unchanged '()))
(for-each
(lambda (name)
(let ((old-summary (lookup-service old-alist name))
(new-summary (lookup-service new-alist name)))
(if (service-unchanged? old-summary new-summary)
(set! unchanged (cons `(("name" . ,name)
("file" . ,(service-file new-summary)))
unchanged))
(set! changed (cons (service-change-entry old-summary new-summary)
changed)))))
common-names)
`(("added" . ,(map (lambda (name) (lookup-service new-alist name)) added-names))
("removed" . ,(map (lambda (name) (lookup-service old-alist name)) removed-names))
("changed" . ,(reverse changed))
("unchangedCount" . ,(length unchanged))
("unchanged" . ,(reverse unchanged))
("addedCount" . ,(length added-names))
("removedCount" . ,(length removed-names))
("changedCount" . ,(length changed)))))
(define (system-reference-section label old-path new-path full-closure?)
(let* ((old-store-item (path->store-item old-path))
(new-store-item (path->store-item new-path))
(base `(("label" . ,label)
("oldPath" . ,old-path)
("newPath" . ,new-path)
("oldExists" . ,(file-exists? old-path))
("newExists" . ,(file-exists? new-path))
,@(if old-store-item `(("oldStoreItem" . ,old-store-item)) '())
,@(if new-store-item `(("newStoreItem" . ,new-store-item)) '()))))
(if (and old-store-item new-store-item)
(let ((with-direct
(append base
`(("directReferences"
. ,(safe-store-reference-diff old-store-item
new-store-item))))))
(if full-closure?
(append with-direct
`(("fullClosure"
. ,(safe-store-closure-diff old-store-item
new-store-item))))
with-direct))
(let ((with-direct
(append base
`(("directReferences"
. ,(skipped-store-item-diff
"path is not a top-level Guix store item"
#:old-store-item old-store-item
#:new-store-item new-store-item))))))
(if full-closure?
(append with-direct
`(("fullClosure"
. ,(skipped-store-item-diff
"path is not a top-level Guix store item"
#:old-store-item old-store-item
#:new-store-item new-store-item))))
with-direct)))))
(define (maybe-system-reference-sections old-system new-system full-closure?)
(if (and old-system new-system)
(list
(system-reference-section "system" old-system new-system full-closure?)
(system-reference-section "profile"
(string-append old-system "/profile")
(string-append new-system "/profile")
full-closure?)
(system-reference-section "configuration"
(string-append old-system "/configuration.scm")
(string-append new-system "/configuration.scm")
full-closure?))
'()))
(define (parse-args args)
(let loop ((rest args)
(old-system #f)
(new-system #f)
(full-closure? #f)
(pretty? #f)
(positionals '()))
(match rest
(()
(let ((positional-args (reverse positionals)))
(match positional-args
((old-config new-config)
`((old-config . ,old-config)
(new-config . ,new-config)
(old-system . ,old-system)
(new-system . ,new-system)
(full-closure? . ,full-closure?)
(pretty? . ,pretty?)))
(_
(usage)))))
(((or "-h" "--help") . _)
(usage))
(((or "--full-closure") . tail)
(loop tail old-system new-system #t pretty? positionals))
(((or "--pretty") . tail)
(loop tail old-system new-system full-closure? #t positionals))
(("--old-system" path . tail)
(loop tail path new-system full-closure? pretty? positionals))
(("--new-system" path . tail)
(loop tail old-system path full-closure? pretty? positionals))
(((? (lambda (value) (string-prefix? "--old-system=" value)) arg) . tail)
(loop tail
(substring arg (string-length "--old-system="))
new-system full-closure? pretty? positionals))
(((? (lambda (value) (string-prefix? "--new-system=" value)) arg) . tail)
(loop tail old-system
(substring arg (string-length "--new-system="))
full-closure? pretty? positionals))
((arg . tail)
(loop tail old-system new-system full-closure? pretty? (cons arg positionals))))))
(define (compare-system-generations-main args)
(let* ((opts (parse-args args))
(old-config (assoc-ref opts 'old-config))
(new-config (assoc-ref opts 'new-config))
(old-system (assoc-ref opts 'old-system))
(new-system (assoc-ref opts 'new-system))
(full-closure? (assoc-ref opts 'full-closure?))
(pretty? (assoc-ref opts 'pretty?))
(old-os (load-operating-system old-config))
(new-os (load-operating-system new-config))
(old-services (map service-summary (operating-system-shepherd-services old-os)))
(new-services (map service-summary (operating-system-shepherd-services new-os)))
(service-report (service-diff old-services new-services))
(reference-sections (maybe-system-reference-sections old-system new-system full-closure?))
(report
`(("old" . (("config" . ,old-config)
,@(if old-system `(("system" . ,old-system)) '())))
("new" . (("config" . ,new-config)
,@(if new-system `(("system" . ,new-system)) '())))
("services" . ,service-report)
("references" . ,reference-sections))))
(emit-json report pretty?)))
(define (script-invocation? argv)
(match argv
((program . _)
(and (string? program)
(or (string=? program "system-generations.scm")
(string-suffix? "/system-generations.scm" program))))
(_ #f)))
(when (script-invocation? (command-line))
(compare-system-generations-main (cdr (command-line))))
tribes/packages/cli.scm
+301 -159
View File
@@ -1,184 +1,326 @@
(define-module (tribes packages cli)
#:use-module ((guix licenses) #:prefix license:)
#:use-module (guix build-system guile)
#:use-module (guix build-system trivial)
#:use-module (guix gexp)
#:use-module (guix packages)
#:use-module (gnu packages bash)
#:use-module (gnu packages guile)
#:use-module (gnu packages gnupg)
#:use-module (gnu packages tls)
#:use-module (gnu packages package-management)
#:export (tribes-command-package))
;; Guile must match the one (guix) was compiled with. Otherwise our build's
;; `guild compile` (and the broker at runtime) loads (guix records) etc. with
;; an incompatible bytecode version, falls back to recompiling guix from
;; source, and drags hundreds of (gnu packages …) modules through Guile's
;; user cache before our own modules can finish loading. Same idiom as
;; guix-modules — see (lookup-package-input guix "guile") in upstream
;; gnu/packages/package-management.scm.
(define guile-for-guix
(lookup-package-input guix "guile"))
(define tribes-command-program
(program-file
"tribes"
#~(begin
(use-modules (ice-9 format)
(ice-9 ftw)
(ice-9 match)
(srfi srfi-1))
(let ()
(define channels-file "/etc/tribes/channels.scm")
(define host-config-file "/etc/tribes/host-config.json")
(define current-config-file "/run/current-system/configuration.scm")
(define system-guix "/run/current-system/profile/bin/guix")
;; ---------------------------------------------------------------------------
;; Three transport binaries — all dispatch through (tribes deploy entry):
;; tribes -> entry 'shell (status command for the UI)
;; tribes-deploy-exec -> entry 'cli
;; tribes-local-control -> entry 'http
;;
;; Plus the privileged helper, whose body lives in (tribes deploy
;; helper-main). Every binary is a thin program-file that calls into a
;; compiled (tribes ...) module — no inline gexp bodies.
(define (home-directory)
(or (getenv "HOME") "/root"))
(define tribes-shell-program
(program-file "tribes"
#~(begin (use-modules (tribes deploy entry)) (main 'shell))
#:guile guile-for-guix))
(define (pulled-guix)
(string-append (home-directory) "/.config/guix/current/bin/guix"))
(define (guix-binary)
(cond
((file-exists? (pulled-guix)) (pulled-guix))
((file-exists? system-guix) system-guix)
(else "guix")))
(define (print-usage port)
(format port "Usage: tribes <command>~%")
(format port "~%Commands:~%")
(format port " help Show this help.~%")
(format port " os status Show node update state.~%")
(format port " os update Pull channels and reconfigure the OS.~%"))
(define (require-root)
(unless (string=? (or (getenv "USER") "") "root")
(format (current-error-port)
"tribes os update must run as root.~%")
(exit 1)))
(define (ensure-managed-file path)
(unless (file-exists? path)
(format (current-error-port)
"missing managed file: ~a~%"
path)
(exit 1)))
(define (run command . args)
(let ((status (apply system* command args)))
(if (and (integer? status) (zero? status))
0
(if (integer? status) status 1))))
(define (os-status)
(format #t "channels: ~a~%" channels-file)
(format #t " exists: ~a~%" (file-exists? channels-file))
(format #t "host config: ~a~%" host-config-file)
(format #t " exists: ~a~%" (file-exists? host-config-file))
(format #t "system guix: ~a~%" system-guix)
(format #t " exists: ~a~%" (file-exists? system-guix))
(format #t "selected guix: ~a~%" (guix-binary))
(format #t "current system: ~a~%"
(or (false-if-exception (readlink "/run/current-system"))
"unknown"))
(exit (run (guix-binary) "describe")))
(define (os-update)
(require-root)
(ensure-managed-file channels-file)
(ensure-managed-file host-config-file)
(let ((bootstrap-guix (if (file-exists? system-guix)
system-guix
(guix-binary))))
(let ((pull-status
(run bootstrap-guix
"pull"
"--allow-downgrades"
"-C"
channels-file)))
(unless (zero? pull-status)
(exit pull-status))))
(ensure-managed-file current-config-file)
(exit (run (guix-binary)
"system"
"reconfigure"
current-config-file)))
(match (cdr (command-line))
(() (print-usage (current-output-port)))
(("help") (print-usage (current-output-port)))
(("os" "status") (os-status))
(("os" "update") (os-update))
(_
(print-usage (current-error-port))
(exit 1)))))))
(define tribes-deploy-exec-program
(program-file "tribes-deploy-exec"
#~(begin (use-modules (tribes deploy entry)) (main 'cli))
#:guile guile-for-guix))
(define tribes-local-control-program
(program-file "tribes-local-control"
#~(begin (use-modules (tribes deploy entry)) (main 'http))
#:guile guile-for-guix))
(define tribes-guix-helper-program
(program-file "tribes-guix-helper"
#~(begin (use-modules (tribes deploy helper-main))
(helper-main (cdr (command-line))))
#:guile guile-for-guix))
(define tribes-compare-system-generations-program
(program-file "tribes-compare-system-generations"
(with-extensions
(list guile-json-4)
(program-file
"tribes-deploy-exec"
#~(begin
(use-modules (tribes deploy current-guix))
(let ((script (current-guix-module-file
"tribes/diagnostics/system-generations.scm")))
(exit (run-current-guix-repl-script script
(cdr (command-line))))))
#:guile guile-for-guix))
(use-modules (ice-9 format)
(ice-9 ftw)
(ice-9 match)
(json)
(tribes deploy executor))
(let ()
(define channels-file "/etc/tribes/channels.scm")
(define host-config-file "/etc/tribes/host-config.json")
(define current-config-file "/run/current-system/configuration.scm")
(define herd-binary "/run/current-system/profile/bin/herd")
(define system-guix "/run/current-system/profile/bin/guix")
(define deploy-directory "/var/lib/tribes/deploy")
(define request-file (string-append deploy-directory "/request.json"))
(define status-file (string-append deploy-directory "/status.json"))
(define tribes-modules-source
(local-file ".." "tribes-modules" #:recursive? #t))
(define (home-directory)
(or (getenv "HOME") "/root"))
(define nbde-modules-source
(local-file "../../nbde" "nbde-modules" #:recursive? #t))
(define (pulled-guix)
(string-append (home-directory) "/.config/guix/current/bin/guix"))
(define (guix-binary)
(cond
((file-exists? (pulled-guix)) (pulled-guix))
((file-exists? system-guix) system-guix)
(else "guix"))))
(define (require-root)
(unless (string=? (or (getenv "USER") "") "root")
(format (current-error-port)
"tribes-deploy-exec must run as root.~%")
(exit 1)))
(define (ensure-managed-file path)
(unless (file-exists? path)
(format (current-error-port)
"missing managed file: ~a~%"
path)
(exit 1)))
(define (ensure-deploy-directory)
(unless (file-exists? deploy-directory)
(mkdir deploy-directory #o755)))
(define (run command . args)
(let ((status (apply system* command args)))
(if (and (integer? status) (zero? status))
0
(if (integer? status) status 1))))
(define (json-response payload)
(scm->json payload (current-output-port))
(newline))
(define (read-json-file path)
(call-with-input-file path json->scm))
(define (write-json-file path payload)
(call-with-output-file path
(lambda (port)
(scm->json payload port))))
(define* (write-status! status
#:key
(ok #t)
reason
plugins
current-system)
(ensure-deploy-directory)
(write-json-file
status-file
`(("ok" . ,ok)
("status" . ,status)
,@(if reason `(("reason" . ,reason)) '())
,@(if plugins `(("plugins" . ,plugins)) '())
,@(if current-system `(("currentSystem" . ,current-system)) '()))))
(define (read-status)
(if (file-exists? status-file)
(read-json-file status-file)
'(("ok" . #t)
("status" . "idle"))))
(define (copy-request! source)
(ensure-deploy-directory)
(when (file-exists? request-file)
(delete-file request-file))
(copy-file source request-file))
(define (apply-request request-path)
(require-root)
(ensure-managed-file request-path)
(ensure-managed-file host-config-file)
(ensure-managed-file channels-file)
(ensure-managed-file current-config-file)
(ensure-managed-file herd-binary)
(let* ((request (read-json-file request-path))
(plugins (deployment-request-plugins request)))
(copy-request! request-path)
(write-status! "accepted" #:plugins plugins)
(let ((status (run herd-binary "start" "tribes-deploy-apply")))
(if (zero? status)
(begin
(json-response
`(("ok" . #t)
("status" . "accepted")
("plugins" . ,plugins))))
(begin
(write-status! "failed"
#:ok #f
#:reason "failed to start tribes-deploy-apply")
(json-response
'(("ok" . #f)
("status" . "failed")
("reason" . "failed to start tribes-deploy-apply")))
(exit status))))))
(define (run-pending)
(require-root)
(ensure-managed-file request-file)
(ensure-managed-file host-config-file)
(ensure-managed-file channels-file)
(ensure-managed-file current-config-file)
(let* ((request (read-json-file request-file))
(plugins (deployment-request-plugins request))
(host-config (read-json-file host-config-file))
(updated-host-config (host-config-with-plugins host-config plugins))
(bootstrap-guix (if (file-exists? system-guix)
system-guix
(guix-binary))))
(write-status! "running" #:plugins plugins)
(write-json-file host-config-file updated-host-config)
(let ((pull-status
(run bootstrap-guix
"pull"
"--allow-downgrades"
"-C"
channels-file)))
(if (not (zero? pull-status))
(begin
(write-status! "failed"
#:ok #f
#:plugins plugins
#:reason "guix pull failed")
(json-response
'(("ok" . #f)
("status" . "failed")
("reason" . "guix pull failed")))
(exit pull-status))
(let ((reconfigure-status
(run (guix-binary)
"system"
"reconfigure"
current-config-file)))
(if (zero? reconfigure-status)
(begin
(write-status! "completed"
#:plugins plugins
#:current-system
(or (false-if-exception
(readlink "/run/current-system"))
"unknown"))
(json-response
`(("ok" . #t)
("status" . "completed")
("plugins" . ,plugins)
("currentSystem" . ,(or (false-if-exception
(readlink "/run/current-system"))
"unknown")))))
(begin
(write-status! "failed"
#:ok #f
#:plugins plugins
#:reason "guix system reconfigure failed")
(json-response
'(("ok" . #f)
("status" . "failed")
("reason" . "guix system reconfigure failed")))
(exit reconfigure-status)))))))
(match (cdr (command-line))
(("status")
(json-response (read-status)))
(("apply" request-path)
(apply-request request-path))
(("run-pending")
(run-pending))
(_
(format (current-error-port)
"Usage: tribes-deploy-exec status | apply <request.json> | run-pending~%")
(exit 1))))))))
(define tribes-command-package
(package
(name "tribes-command")
(version "0.2")
(version "0.1")
(source #f)
(build-system guile-build-system)
(build-system trivial-build-system)
(arguments
(list
#:source-directory "."
;; Skip compilation of channel-eval-only modules: (tribes services …)
;; / (tribes system …) / (tribes config …) and the package
;; definitions other than the runtime-relevant {plugins, mix, source,
;; otp}. (tribes packages cli) — this very file — is also skipped:
;; channel users reach it via the git checkout, not via the package
;; output.
#:not-compiled-file-regexp
"tribes/(services/|system/|config/|packages/(cli|go|release|terminals|web)\\.scm)"
#:phases
#~(modify-phases %standard-phases
;; Default 'unpack would cd into the source directory and flatten
;; the (tribes …) prefix off our module paths. Re-create the
;; tribes/ subdir explicitly so guile-build-system compiles
;; modules as (tribes deploy …) etc.
(replace 'unpack
(lambda _
(mkdir-p "tribes")
(mkdir-p "nbde")
(copy-recursively #+tribes-modules-source "tribes")
(copy-recursively #+nbde-modules-source "nbde")))
(add-after 'build 'install-bin
(lambda* (#:key outputs #:allow-other-keys)
(let* ((out (assoc-ref outputs "out"))
(bin (string-append out "/bin"))
(site-dir (string-append out "/share/guile/site/3.0"))
(go-dir (string-append out "/lib/guile/3.0/site-ccache")))
(mkdir-p bin)
(define (install src name)
(let ((dest (string-append bin "/" name)))
(copy-file src dest)
(chmod dest #o555)))
(install #+tribes-shell-program "tribes")
(install #+tribes-deploy-exec-program "tribes-deploy-exec")
(install #+tribes-local-control-program "tribes-local-control")
(install #+tribes-guix-helper-program "tribes-guix-helper")
(install #+tribes-compare-system-generations-program
"tribes-compare-system-generations")
;; Two-tier wrap: only the resolver-bearing transports
;; carry guix / gcrypt / gnutls on their load paths. The
;; status shell and helper subprocess stay minimal because
;; they never load (tribes deploy executor).
(define (wrap-with-paths name with-guix?)
(let ((bin-path (string-append bin "/" name))
(load-path
(if with-guix?
(list site-dir
#$(file-append guix
"/share/guile/site/3.0")
#$(file-append guile-git
"/share/guile/site/3.0")
#$(file-append guile-bytestructures
"/share/guile/site/3.0")
#$(file-append guile-gcrypt
"/share/guile/site/3.0")
#$(file-append guile-json-4
"/share/guile/site/3.0")
#$(file-append guile-gnutls
"/share/guile/site/3.0"))
(list site-dir
#$(file-append guile-json-4
"/share/guile/site/3.0")
#$(file-append guix
"/share/guile/site/3.0"))))
(compiled-path
(if with-guix?
(list go-dir
#$(file-append guix
"/lib/guile/3.0/site-ccache")
#$(file-append guile-git
"/lib/guile/3.0/site-ccache")
#$(file-append guile-bytestructures
"/lib/guile/3.0/site-ccache")
#$(file-append guile-gcrypt
"/lib/guile/3.0/site-ccache")
#$(file-append guile-gnutls
"/lib/guile/3.0/site-ccache")
#$(file-append guile-json-4
"/lib/guile/3.0/site-ccache"))
(list go-dir
#$(file-append guile-json-4
"/lib/guile/3.0/site-ccache")
#$(file-append guix
"/lib/guile/3.0/site-ccache")))))
(wrap-program bin-path
#:sh #$(file-append bash-minimal "/bin/bash")
`("GUILE_LOAD_PATH" ":" prefix ,load-path)
`("GUILE_LOAD_COMPILED_PATH" ":" prefix ,compiled-path))))
(wrap-with-paths "tribes" #f)
(wrap-with-paths "tribes-guix-helper" #f)
(wrap-with-paths "tribes-deploy-exec" #t)
(wrap-with-paths "tribes-local-control" #t)
(wrap-with-paths "tribes-compare-system-generations" #f)))))))
(native-inputs
(list guile-for-guix guix))
(inputs
(list bash-minimal guile-for-guix guile-json-4
guix guile-git guile-bytestructures guile-gcrypt guile-gnutls))
#:modules '((guix build utils))
#:builder
#~(begin
(use-modules (guix build utils))
(let ((bin-dir (string-append #$output "/bin")))
(mkdir-p bin-dir)
(copy-file #+tribes-command-program
(string-append bin-dir "/tribes"))
(copy-file #+tribes-deploy-exec-program
(string-append bin-dir "/tribes-deploy-exec"))
(chmod (string-append bin-dir "/tribes") #o555)
(chmod (string-append bin-dir "/tribes-deploy-exec") #o555)))))
(home-page "https://git.teralink.net/tribes/guix-tribes.git")
(synopsis "Tribes node administration command")
(description
"Command-line helpers and the local-control broker that fronts every
operator action on a Tribes node. Bundles the privileged Guix helper used
to drive @command{guix pull}, @command{guix system build} and
@command{guix system switch-generation} from a single, typed-error-aware
process.")
"Command-line helper for updating and inspecting a deployed Tribes node.")
(license license:asl2.0)))
tribes/packages/go.scm
-1
View File
@@ -9,7 +9,6 @@
#:use-module (gnu packages base)
#:use-module (gnu packages compression)
#:use-module (gnu packages golang)
#:use-module (gnu packages certs)
#:use-module (gnu packages nss)
#:use-module (gnu packages version-control)
#:export (fetch-go-modules
tribes/packages/mix.scm
+14 -15
View File
@@ -10,7 +10,6 @@
#:use-module (gnu packages compression)
#:use-module (gnu packages erlang)
#:use-module (gnu packages node)
#:use-module (gnu packages certs)
#:use-module (gnu packages nss)
#:use-module (gnu packages version-control)
#:use-module (tribes packages otp)
@@ -43,15 +42,15 @@ SOURCE according to mix.lock."
(define cert-file
(string-append work "/ca-certificates.crt"))
(define hex-lib-dir
(string-append
#$(file-append elixir-hex-otp28 "/lib/elixir/1.19")
":"
#$(file-append elixir-hex-otp28 "/lib/elixir/1.18")))
#$(file-append elixir-hex-otp28
"/lib/elixir/"
(version-major+minor
(package-version elixir-otp28))))
(define path
(string-join
(list #$(file-append elixir-otp28 "/bin")
#$(file-append elixir-hex-otp28 "/bin")
#$(file-append rebar3-otp28 "/bin")
#$(file-append rebar3 "/bin")
#$(file-append bash-minimal "/bin")
#$(file-append coreutils "/bin")
#$(file-append findutils "/bin")
@@ -82,7 +81,7 @@ SOURCE according to mix.lock."
(setenv "MIX_ENV" #$mix-env)
(setenv "MIX_TARGET" #$mix-target)
(setenv "MIX_OS_CONCURRENCY_LOCK" "0")
(setenv "MIX_REBAR3" #$(file-append rebar3-otp28 "/bin/rebar3"))
(setenv "MIX_REBAR3" #$(file-append rebar3 "/bin/rebar3"))
(setenv "REBAR_GLOBAL_CONFIG_DIR" (string-append work "/rebar3"))
(setenv "REBAR_CACHE_DIR" (string-append work "/rebar3.cache"))
(setenv "LANG" "C.UTF-8")
@@ -264,17 +263,17 @@ MIX-FOD-DEPS as a pre-fetched dependency tree."
(define cert-file
(string-append work "/ca-certificates.crt"))
(define hex-lib-dir
(string-append
#$(file-append elixir-hex-otp28 "/lib/elixir/1.19")
":"
#$(file-append elixir-hex-otp28 "/lib/elixir/1.18")))
#$(file-append elixir-hex-otp28
"/lib/elixir/"
(version-major+minor
(package-version elixir-otp28))))
(define aclocal-path
(string-join (list #$@aclocal-dirs) ":"))
(define path
(string-join
(list #$(file-append elixir-otp28 "/bin")
#$(file-append elixir-hex-otp28 "/bin")
#$(file-append rebar3-otp28 "/bin")
#$(file-append rebar3 "/bin")
#$(file-append bash-minimal "/bin")
#$(file-append coreutils "/bin")
#$(file-append findutils "/bin")
@@ -315,8 +314,8 @@ MIX-FOD-DEPS as a pre-fetched dependency tree."
(setenv "MIX_OS_CONCURRENCY_LOCK" "0")
(setenv "MIX_OS_DEPS_COMPILE_PARTITION_COUNT" "4")
(setenv "HEX_OFFLINE" "1")
(setenv "MIX_REBAR" #$(file-append rebar3-otp28 "/bin/rebar3"))
(setenv "MIX_REBAR3" #$(file-append rebar3-otp28 "/bin/rebar3"))
(setenv "MIX_REBAR" #$(file-append rebar3 "/bin/rebar3"))
(setenv "MIX_REBAR3" #$(file-append rebar3 "/bin/rebar3"))
(setenv "REBAR_GLOBAL_CONFIG_DIR" (string-append work "/rebar3"))
(setenv "REBAR_CACHE_DIR" (string-append work "/rebar3.cache"))
(setenv "SHELL" #$(file-append bash-minimal "/bin/sh"))
@@ -371,7 +370,7 @@ MIX-FOD-DEPS as a pre-fetched dependency tree."
findutils
git-minimal
nss-certs
rebar3-otp28
rebar3
elixir-otp28
elixir-hex-otp28)
native-inputs))
tribes/packages/otp.scm
+1 -27
View File
@@ -9,9 +9,7 @@
#:use-module (gnu packages erlang)
#:use-module (gnu packages perl)
#:use-module (gnu packages version-control)
#:use-module (srfi srfi-1)
#:export (erlang-28
rebar3-otp28
elixir-otp28
elixir-hex-otp28))
@@ -31,22 +29,6 @@
(base32
"1lsbmjfraw03d0kcdzmjdjad8b95d630d1jmg8hjklmivc13l6pa"))
(patches (search-patches "erlang-man-path.patch"))))
(arguments
(substitute-keyword-arguments (package-arguments erlang)
((#:configure-flags flags)
`(append
(map (lambda (flag)
(if (string=? flag "--enable-wx")
"--without-wx"
flag))
,flags)
;; OTP does not automatically skip applications that depend on wx.
'("--without-debugger"
"--without-observer"
"--without-et"
"--without-reltool")))))
(inputs
(alist-delete "wxwidgets" (package-inputs erlang)))
(native-inputs
`(("perl" ,perl)
("erlang-manpages"
@@ -59,14 +41,6 @@
(base32
"00simi301qz3ssn71r77jmsyfz8sb61wp7k92j3gh7pq7gmmc40j"))))))))
(define-public rebar3-otp28
(package
(inherit rebar3)
(name "rebar3-otp28")
(native-inputs
(modify-inputs (package-native-inputs rebar3)
(replace "erlang" erlang-28)))))
(define-public elixir-otp28
(package
(inherit elixir)
@@ -91,7 +65,7 @@
(inputs
`(("bash-minimal" ,bash-minimal)
("erlang" ,erlang-28)
("rebar3" ,rebar3-otp28)
("rebar3" ,rebar3)
("git" ,git)))))
(define-public elixir-hex-otp28
tribes/packages/plugins.scm
+59 -141
View File
@@ -1,6 +1,5 @@
(define-module (tribes packages plugins)
#:use-module ((guix licenses) #:prefix license:)
#:use-module (guix base32)
#:use-module (guix build-system trivial)
#:use-module (guix git-download)
#:use-module (guix gexp)
@@ -8,7 +7,6 @@
#:use-module (guix records)
#:use-module (guix utils)
#:use-module (gnu packages autotools)
#:use-module (gnu packages bash)
#:use-module (gnu packages base)
#:use-module (gnu packages commencement)
#:use-module (gnu packages gawk)
@@ -32,15 +30,8 @@
tribes-plugin-definition
tribes-plugin-definition?
tribes-plugin-definition-name
tribes-plugin-definition-package-name
tribes-plugin-definition-version
tribes-plugin-definition-synopsis
tribes-plugin-definition-home-page
tribes-plugin-definition-provides
tribes-plugin-definition-requires
tribes-plugin-definition-external-plugin
tribes-plugin-catalog-file
tribes-plugin-package
tribes-external-plugin
tribes-external-plugin?
tribes-external-plugin-name
@@ -77,16 +68,6 @@
(or (string=? file root)
(not (transient-plugin-source-file? root file))))
(define %libsecp256k1-v0.7.1-source
(origin
(method git-fetch)
(uri (git-reference
(url "https://github.com/bitcoin-core/secp256k1")
(commit "v0.7.1")))
(file-name (git-file-name "secp256k1" "0.7.1"))
(sha256
(base32 "10cvh8jks3rjg6p7y0vm1v4kw9y7vljbfijj0zxwkxzysxx60w0f"))))
(define (plugin-source-directory->local-file directory)
"Return DIRECTORY as a recursively copied local-file suitable for Guix plugin
packaging, excluding transient build artifacts and, when possible, files not
@@ -189,38 +170,41 @@ and admin API consumption."
("plugins" . ,(list->vector plugins)))
port)))))))
(define* (tribes-plugin-package plugin-source
#:key
host-source
host-source-directory
mix-deps
mix-deps-sha256
(build-assets? #f)
(digest-assets? #f)
asset-deps
asset-deps-sha256
(assets-directory "assets")
asset-build-gexp
name
(version "dev")
(home-page "https://git.teralink.net/tribes/plugins")
synopsis
description)
"Build PLUGIN-SOURCE as a standalone Tribes plugin artifact. The plugin is
compiled against the Tribes host source specified by HOST-SOURCE or
HOST-SOURCE-DIRECTORY, and packages its compiled BEAM closure under
lib/*/ebin."
(let* ((resolved-host-source
(define* (local-tribes-plugin-package directory
#:key
host-source
host-source-directory
mix-deps
mix-deps-sha256
(build-assets? #f)
(digest-assets? #f)
asset-deps
asset-deps-sha256
(assets-directory "assets")
asset-build-gexp
name
(version "dev")
(home-page "https://git.teralink.net/tribes/plugins")
synopsis
description)
"Build DIRECTORY as a standalone Tribes plugin artifact. The plugin is
compiled against the Tribes plugin API from the host source specified by
HOST-SOURCE or HOST-SOURCE-DIRECTORY, and packages its compiled BEAM closure
under lib/*/ebin."
(let* ((plugin-source (plugin-source-directory->local-file directory))
(resolved-host-source
(or host-source
(and host-source-directory
(tribes-source-directory->local-file host-source-directory))
tribes-upstream-source))
(resolved-plugin-api-source
(file-append resolved-host-source "/tribes_plugin_api"))
(plugin-api-setup-gexp
#~(let ((host-root (string-append work "/tribes")))
(when (file-exists? host-root)
(delete-file-recursively host-root))
(copy-recursively #+resolved-host-source host-root #:follow-symlinks? #t)
(invoke "chmod" "-R" "u+w" host-root)))
#~(let* ((api-root (string-append work "/tribes"))
(api-dir (string-append api-root "/tribes_plugin_api")))
(mkdir-p api-root)
(copy-recursively #+resolved-plugin-api-source api-dir #:follow-symlinks? #t)
(invoke "chmod" "-R" "u+w" api-dir)))
(mix-deps-source
(or mix-deps
(and mix-deps-sha256
@@ -280,39 +264,35 @@ lib/*/ebin."
#:description description
#:license license:asl2.0
#:native-inputs
(append
(list autoconf
autoconf-wrapper
automake
gcc-toolchain
diffutils
gawk
grep
gnu-make
libtool
linux-libre-headers
m4
perl
pkg-config
sed)
(if build-assets? (list node) '()))
(list autoconf
autoconf-wrapper
automake
gcc-toolchain
gawk
grep
gnu-make
libtool
linux-libre-headers
m4
node
perl
pkg-config
sed)
#:path-inputs
(append
(list autoconf
autoconf-wrapper
automake
gcc-toolchain
diffutils
gawk
grep
gnu-make
libtool
linux-libre-headers
m4
perl
pkg-config
sed)
(if build-assets? (list node) '()))
(list autoconf
autoconf-wrapper
automake
gcc-toolchain
gawk
grep
gnu-make
libtool
linux-libre-headers
m4
node
perl
pkg-config
sed)
#:aclocal-inputs
(list automake libtool)
#:setup-gexp
@@ -335,33 +315,7 @@ lib/*/ebin."
(setenv "CPP"
(string-append #$(file-append gcc-toolchain "/bin/gcc")
" -E"))
#$setup-gexp
(let* ((libsecp-dep (string-append app-dir "/deps/lib_secp256k1"))
(libsecp-c-src (string-append libsecp-dep "/c_src"))
(libsecp-source-dir (string-append libsecp-c-src "/secp256k1")))
(when (file-exists? libsecp-dep)
(mkdir-p libsecp-c-src)
(when (file-exists? libsecp-source-dir)
(delete-file-recursively libsecp-source-dir))
(copy-recursively #+%libsecp256k1-v0.7.1-source
libsecp-source-dir
#:follow-symlinks? #t)
(invoke "chmod" "-R" "u+w" libsecp-source-dir)
(substitute* (string-append libsecp-source-dir "/autogen.sh")
(("^#!.*") (string-append "#!" #$(file-append bash-minimal "/bin/sh") "\n")))
(with-directory-excursion libsecp-source-dir
(invoke #$(file-append bash-minimal "/bin/sh") "autogen.sh")
(invoke #$(file-append bash-minimal "/bin/sh")
"configure"
"--disable-benchmark"
"--disable-tests"
"--disable-fast-install"
"--with-pic"
"--enable-experimental"
"--enable-module-musig"))
(call-with-output-file (string-append libsecp-source-dir "/.fetched")
(lambda (port)
(display "vendored by guix-tribes\n" port))))))
#$setup-gexp)
#:build-gexp
#~(begin
#$resolved-asset-build-gexp
@@ -392,42 +346,6 @@ lib/*/ebin."
(string-append out "/lib")
#:follow-symlinks? #t))))))
(define* (local-tribes-plugin-package directory
#:key
host-source
host-source-directory
mix-deps
mix-deps-sha256
(build-assets? #f)
(digest-assets? #f)
asset-deps
asset-deps-sha256
(assets-directory "assets")
asset-build-gexp
name
(version "dev")
(home-page "https://git.teralink.net/tribes/plugins")
synopsis
description)
"Build DIRECTORY as a standalone Tribes plugin artifact."
(tribes-plugin-package
(plugin-source-directory->local-file directory)
#:host-source host-source
#:host-source-directory host-source-directory
#:mix-deps mix-deps
#:mix-deps-sha256 mix-deps-sha256
#:build-assets? build-assets?
#:digest-assets? digest-assets?
#:asset-deps asset-deps
#:asset-deps-sha256 asset-deps-sha256
#:assets-directory assets-directory
#:asset-build-gexp asset-build-gexp
#:name name
#:version version
#:home-page home-page
#:synopsis synopsis
#:description description))
(define* (tribes-package-with-external-plugins host-package plugins
#:key
(package-name "tribes-with-plugins")
tribes/packages/source.scm
+5 -20
View File
@@ -14,7 +14,6 @@
#:use-module (gnu packages linux)
#:use-module (gnu packages m4)
#:use-module (gnu packages node)
#:use-module (gnu packages certs)
#:use-module (gnu packages nss)
#:use-module (gnu packages perl)
#:use-module (gnu packages pkg-config)
@@ -35,13 +34,13 @@
;; from the current Tribes mix.lock, with git metadata stripped except for
;; .git/HEAD in SCM dependencies.
(define %tribes-raw-mix-deps-sha256
"1s7k3qaqnl7lj9jl5xrm9rx0rva23n3az2f99vqjwvibhnhnml0v")
"0gl1qn26im9ggdk1l1hikp8602bc1a04qdih1hiwmqjwdagm8c81")
;; Recursive sha256 of the Tribes-specific prepared deps tree, after injecting
;; the upstream secp256k1 source into the Hex package and patching its build
;; recipe to avoid build-time network access.
(define %tribes-mix-deps-sha256
"1q7p44xdm7xqbrg2z7pa86v8n89a56hlr9c5y31yd4slssb0r8mk")
"1jzfsh3d2h6f30dq9i9kb13zglvifk7ap8inm106plamc1rmajbj")
;; Recursive sha256 of assets/node_modules generated from assets/package-lock.json
;; in an isolated build environment, with local file dependencies resolved from
@@ -53,7 +52,7 @@
"https://git.teralink.net/tribes/tribes.git")
(define %tribes-commit
"d5d4d62b0f941b74749702c393743d2db009aba2")
"497c02d3b84fdb6f4289ad2276638fb557b90572")
(define %tribes-revision "1")
@@ -61,7 +60,7 @@
(git-version "0.2.0" %tribes-revision %tribes-commit))
(define %tribes-source-sha256
"1pkl0xpf95n5ravqs1m79084l3nklfwjhsrzihyj1cpm01dfc5np")
"0118rdpnpn3qnm3r7v9fhys760sq1nw9590z41ly6ydj4zwyyb9m")
(define %tribes-upstream-source
(origin
@@ -463,10 +462,6 @@ mix.lock and assets/package-lock.json."
(invoke "mix" "phx.digest"))
#:install-gexp
#~(begin
(when (file-exists? "plugins/tribes_ui/mix.exs")
(with-directory-excursion "plugins/tribes_ui"
(invoke "mix" "compile")))
(invoke "mix" "release" "--path" out)
(let ((launcher (string-append out "/bin/" #$name))
(launcher-app (string-append out "/bin/" #$name "-app")))
@@ -476,17 +471,7 @@ mix.lock and assets/package-lock.json."
(when (file-exists? "plugins")
(copy-recursively "plugins"
(string-append out "/plugins")
#:follow-symlinks? #t))
(let ((tribes-ui-ebin "_build/prod/lib/tribes_ui/ebin")
(tribes-ui-out (string-append out "/plugins/tribes_ui/ebin")))
(when (file-exists? tribes-ui-ebin)
(when (file-exists? tribes-ui-out)
(delete-file-recursively tribes-ui-out))
(mkdir-p (dirname tribes-ui-out))
(copy-recursively tribes-ui-ebin
tribes-ui-out
#:follow-symlinks? #t)))))))
#:follow-symlinks? #t))))))
(define* (local-tribes-package directory
#:key
tribes/plugins/aether.scm
+7 -69
View File
@@ -1,72 +1,12 @@
(define-module (tribes plugins aether)
#:use-module (guix git-download)
#:use-module (guix packages)
#:use-module (guix utils)
#:use-module (tribes packages plugins)
#:use-module (tribes packages source)
#:export (aether-package
aether-plugin-definition
#:export (aether-plugin-definition
aether-external-plugin
local-aether-package))
(define %aether-home-page
"https://git.teralink.net/tribes/tribes-plugin-aether")
(define %aether-source-url
%aether-home-page)
(define %aether-commit
"5d6ab457ef1795867663b7d061268cd89d248d3d")
(define %aether-revision "1")
(define %aether-version
(git-version "0.1.0" %aether-revision %aether-commit))
(define %aether-source-sha256
"1g095pk6gmlsvhpj5738g4g8vai8d8w8r29lzkrk7qc8bs9ahwm9")
(define %aether-mix-deps-sha256
"008s3k3ry3jy13q1gx7l5i0ygr012xqybm8l0zaf1cxbx6mw9nfr")
(define %aether-npm-deps-sha256
"0sjjj9z1dhilhpc8pq4154czrb79z9cm044jvn75kxcjv6v5l2m5")
(define %aether-source
(origin
(method git-fetch)
(uri (git-reference
(url %aether-source-url)
(commit %aether-commit)))
(file-name (git-file-name "tribes-plugin-aether" %aether-version))
(sha256
(base32 %aether-source-sha256))))
(define* (aether-package-from-source source
#:key
(host-source tribes-upstream-source)
(mix-deps-sha256 %aether-mix-deps-sha256)
(asset-deps-sha256 %aether-npm-deps-sha256)
(version %aether-version))
"Build the pinned Aether source as an external Tribes plugin artifact."
(tribes-plugin-package
source
#:host-source host-source
#:mix-deps-sha256 mix-deps-sha256
#:build-assets? #t
#:digest-assets? #t
#:asset-deps-sha256 asset-deps-sha256
#:name "tribes-plugin-aether"
#:version version
#:home-page %aether-home-page
#:synopsis "Aether timeline UI plugin for Tribes"
#:description
"External Tribes plugin artifact for Aether, packaged as a Guix-managed
plugin directory."))
(define aether-package
(aether-package-from-source %aether-source))
(define* (local-aether-package directory
#:key
host-source
@@ -74,7 +14,6 @@ plugin directory."))
(build-assets? #t)
(digest-assets? #t)
(mix-deps-sha256 %aether-mix-deps-sha256)
(asset-deps-sha256 %aether-npm-deps-sha256)
(version "dev"))
"Build a local checkout of tribes-plugin-aether as an external plugin
artifact."
@@ -85,25 +24,24 @@ artifact."
#:mix-deps-sha256 mix-deps-sha256
#:build-assets? build-assets?
#:digest-assets? digest-assets?
#:asset-deps-sha256 asset-deps-sha256
#:name "tribes-plugin-aether"
#:version version
#:home-page %aether-home-page
#:home-page "https://git.teralink.net/tribes/tribes-plugin-aether.git"
#:synopsis "Aether timeline UI plugin for Tribes"
#:description
"External Tribes plugin artifact for Aether, packaged as a Guix-managed
plugin directory."))
(define* (aether-plugin-definition #:key (package aether-package))
(define* (aether-plugin-definition #:key package)
"Return the channel-owned plugin definition for Aether."
(tribes-plugin-definition
(name "aether")
(package-name "tribes-plugin-aether")
(version "0.1.0")
(version "dev")
(synopsis "Aether timeline UI plugin for Tribes")
(home-page %aether-home-page)
(provides '("aether@1"))
(requires '("ecto@1" "phoenix@1"))
(home-page "https://git.teralink.net/tribes/tribes-plugin-aether.git")
(provides '("timeline@1"))
(requires '())
(external-plugin (aether-external-plugin #:package package))))
(define* (aether-external-plugin #:key package)
tribes/plugins/registry.scm
+1 -3
View File
@@ -1,7 +1,6 @@
(define-module (tribes plugins registry)
#:use-module (tribes packages plugins)
#:use-module (tribes plugins aether)
#:use-module (tribes plugins supertest)
#:use-module (srfi srfi-1)
#:export (guix-tribes-plugin-catalog
guix-tribes-plugin-definition-by-name
@@ -10,8 +9,7 @@
(define guix-tribes-plugin-definitions
(list
(aether-plugin-definition)
(supertest-plugin-definition)))
(aether-plugin-definition)))
(define guix-tribes-plugin-catalog
(tribes-plugin-catalog-file guix-tribes-plugin-definitions))
tribes/plugins/supertest.scm
-106
View File
@@ -1,106 +0,0 @@
(define-module (tribes plugins supertest)
#:use-module (guix git-download)
#:use-module (guix packages)
#:use-module (guix utils)
#:use-module (tribes packages plugins)
#:use-module (tribes packages source)
#:export (supertest-package
supertest-plugin-definition
supertest-external-plugin
local-supertest-package))
(define %supertest-home-page
"https://git.teralink.net/tribes/tribes-plugin-supertest")
(define %supertest-source-url
%supertest-home-page)
(define %supertest-commit
"c5b2a3b2e70082877d64697a991526f25d8a6671")
(define %supertest-revision "1")
(define %supertest-version
(git-version "0.1.1" %supertest-revision %supertest-commit))
(define %supertest-source-sha256
"097z65nhvci2r5qk7pb7w75ig9hsw8rplwbv89hi5n6kmqafdhq3")
(define %supertest-mix-deps-sha256
"0dacj6c9mhxw37ykksjbhmnsqdhrwpkfsbswm68d2wvcwchqazw9")
(define %supertest-npm-deps-sha256
#f)
(define %supertest-source
(origin
(method git-fetch)
(uri (git-reference
(url %supertest-source-url)
(commit %supertest-commit)))
(file-name (git-file-name "tribes-plugin-supertest" %supertest-version))
(sha256
(base32 %supertest-source-sha256))))
(define* (supertest-package-from-source source
#:key
(host-source tribes-upstream-source)
(mix-deps-sha256 %supertest-mix-deps-sha256)
(version %supertest-version))
"Build the pinned Supertest source as an external Tribes plugin artifact."
(tribes-plugin-package
source
#:host-source host-source
#:mix-deps-sha256 mix-deps-sha256
#:build-assets? #f
#:digest-assets? #f
#:name "tribes-plugin-supertest"
#:version version
#:home-page %supertest-home-page
#:synopsis "Supertest fixture plugin for Tribes"
#:description
"External Tribes plugin artifact used by live rollout and sync tests."))
(define supertest-package
(supertest-package-from-source %supertest-source))
(define* (local-supertest-package directory
#:key
host-source
host-source-directory
(mix-deps-sha256 %supertest-mix-deps-sha256)
(version "dev"))
"Build a local checkout of tribes-plugin-supertest as an external plugin artifact."
(local-tribes-plugin-package
directory
#:host-source host-source
#:host-source-directory host-source-directory
#:mix-deps-sha256 mix-deps-sha256
#:build-assets? #f
#:digest-assets? #f
#:name "tribes-plugin-supertest"
#:version version
#:home-page %supertest-home-page
#:synopsis "Supertest fixture plugin for Tribes"
#:description
"External Tribes plugin artifact used by live rollout and sync tests."))
(define* (supertest-plugin-definition #:key (package supertest-package))
"Return the channel-owned plugin definition for Supertest."
(tribes-plugin-definition
(name "supertest")
(package-name "tribes-plugin-supertest")
(version "0.1.1")
(synopsis "Supertest fixture plugin for Tribes")
(home-page %supertest-home-page)
(provides '("supertest@1"))
(requires '("ecto@1"))
(external-plugin (supertest-external-plugin #:package package))))
(define* (supertest-external-plugin #:key package)
"Return the channel-owned Guix integration record for the Supertest plugin."
(tribes-external-plugin
(name "supertest")
(package package)
(extra-packages '())
(extra-services (lambda (_node-config) '()))))
tribes/services/hitch.scm
+2 -14
View File
@@ -23,8 +23,6 @@
hitch-configuration-pid-file
hitch-configuration-ocsp-dir
hitch-configuration-extra-config
hitch-configuration-open-files-soft-limit
hitch-configuration-open-files-hard-limit
hitch-service-type))
(define-record-type* <hitch-configuration>
@@ -49,11 +47,7 @@
(ocsp-dir hitch-configuration-ocsp-dir
(default "/var/cache/hitch/ocsp"))
(extra-config hitch-configuration-extra-config
(default '()))
(open-files-soft-limit hitch-configuration-open-files-soft-limit
(default 32768))
(open-files-hard-limit hitch-configuration-open-files-hard-limit
(default 65535)))
(default '())))
(define %hitch-accounts
(list
@@ -106,11 +100,6 @@
"-x"
"hitch"))))
(define (hitch-resource-limits config)
`((nofile
,(hitch-configuration-open-files-soft-limit config)
,(hitch-configuration-open-files-hard-limit config))))
(define (hitch-shepherd-services config)
(let ((config-file (hitch-config-file config))
(package (hitch-configuration-package config)))
@@ -123,8 +112,7 @@
#~(make-forkexec-constructor
(list #$(file-append package "/sbin/hitch")
"--config"
#$config-file)
#:resource-limits '#$(hitch-resource-limits config)))
#$config-file)))
(stop #~(make-kill-destructor))
(actions
(list
tribes/services/lego.scm
+65 -98
View File
@@ -1,15 +1,12 @@
(define-module (tribes services lego)
#:use-module (gnu packages admin)
#:use-module (gnu packages base)
#:use-module (gnu packages package-management)
#:use-module (gnu packages tls)
#:use-module (gnu services)
#:use-module (gnu services herd)
#:use-module (gnu services shepherd)
#:use-module (guix gexp)
#:use-module (guix modules)
#:use-module (guix packages)
#:use-module (guix records)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-13)
#:use-module (tribes packages web)
@@ -23,7 +20,6 @@
lego-certificate-configuration-listen-http
lego-certificate-configuration-webroot
lego-certificate-configuration-key-type
lego-certificate-configuration-acme-enabled?
lego-certificate-configuration-renew-days
lego-certificate-configuration-requirement
lego-certificate-configuration-reload-services
@@ -53,9 +49,7 @@
(webroot lego-certificate-configuration-webroot
(default #f))
(key-type lego-certificate-configuration-key-type
(default "ec384"))
(acme-enabled? lego-certificate-configuration-acme-enabled?
(default #t))
(default "ec256"))
(renew-days lego-certificate-configuration-renew-days
(default #f))
(requirement lego-certificate-configuration-requirement
@@ -82,10 +76,17 @@
(define (lego-certificate-full-pem certificate)
(string-append (lego-certificate-directory certificate) "/full.pem"))
(define (lego-certificate-last-run-log certificate)
(string-append (lego-certificate-directory certificate) "/last-run.log"))
(define (subject->san-entry subject)
(if (and (not (string-any char-alphabetic? subject))
(string-any (lambda (chr)
(or (char-numeric? chr)
(char=? chr #\.)
(char=? chr #\:)))
subject))
(string-append "IP:" subject)
(string-append "DNS:" subject)))
(define (subject-is-ip? subject)
(define (ip-subject? subject)
(and (not (string-any char-alphabetic? subject))
(string-any (lambda (chr)
(or (char-numeric? chr)
@@ -93,9 +94,6 @@
(char=? chr #\:)))
subject)))
(define (subject->san-entry subject)
(string-append (if (subject-is-ip? subject) "IP:" "DNS:") subject))
(define (certificate-key-name certificate)
(string-map (lambda (chr)
(if (char=? chr #\*)
@@ -131,7 +129,7 @@
(if server
(list "--server" server)
'())
(if (any subject-is-ip? subjects)
(if (any ip-subject? subjects)
(list "--disable-cn")
'())
(list "--key-type" key-type)
@@ -166,11 +164,10 @@
(invoke #$(file-append openssl "/bin/openssl")
"req"
"-x509"
"-newkey" "ec"
"-pkeyopt" "ec_paramgen_curve:P-384"
"-newkey" "rsa:2048"
"-keyout" #$key-output
"-out" #$initial-cert
"-sha384"
"-sha256"
"-days" "1"
"-nodes"
"-subj" #$(string-append "/CN=" primary-subject)
@@ -195,7 +192,6 @@
(cert-output (string-append state-dir "/cert.pem"))
(key-output (string-append state-dir "/key.pem"))
(full-pem (string-append state-dir "/full.pem"))
(last-run-log (lego-certificate-last-run-log certificate))
(run-arguments
(append (lego-common-arguments certificate)
(list "run")
@@ -219,14 +215,11 @@
(list "--dynamic")))))
(program-file
(string-append "lego-" (lego-certificate-configuration-name certificate))
(with-imported-modules (source-module-closure
'((gnu services herd)
(guix build utils)))
(with-imported-modules '((gnu services herd)
(guix build utils))
#~(begin
(use-modules (gnu services herd)
(guix build utils)
(ice-9 popen)
(ice-9 rdelim)
(ice-9 textual-ports))
(define (file-contents path)
@@ -238,39 +231,16 @@
(new (file-contents #$certificate-file)))
(not (equal? old new))))
(define (run-lego lego args)
(let* ((log-port (open-output-file #$last-run-log))
(port (apply open-pipe* OPEN_READ
#$(file-append coreutils "/bin/timeout")
"--signal=TERM" "180" lego args)))
(let loop ()
(let ((line (read-line port 'concat)))
(cond
((eof-object? line) #t)
(else (display line)
(display line log-port)
(loop)))))
(close-port log-port)
(zero? (close-pipe port))))
(define (run-lego-with-retry lego args)
;; Used only when no cert exists yet: keeps boot-time
;; retries to two attempts so a misconfigured node can't
;; burn Let's Encrypt's failure rate limit.
(or (run-lego lego args)
(begin
(display "lego: first attempt failed; retrying in 30 s.\n")
(sleep 30)
(run-lego lego args))))
(mkdir-p #$state-dir)
(let ((lego #$(file-append
(lego-configuration-package config)
"/bin/lego")))
"/bin/lego"))
(run-args '#$run-arguments)
(renew-args '#$renew-arguments))
(if (file-exists? #$certificate-file)
(run-lego lego '#$renew-arguments)
(run-lego-with-retry lego '#$run-arguments)))
(apply invoke lego renew-args)
(apply invoke lego run-args)))
(when (and (file-exists? #$certificate-file)
(fullchain-changed?))
@@ -286,8 +256,7 @@
(display (call-with-input-file #$fullchain get-string-all) port)))
#$@(map (lambda (service)
#~(with-shepherd-action '#$service ('reload) result result))
(lego-certificate-configuration-reload-services certificate)))))
#:guile (lookup-package-input guix "guile"))))
(lego-certificate-configuration-reload-services certificate))))))))
(define (lego-certificate-service-symbol prefix certificate)
(string->symbol
@@ -298,50 +267,48 @@
(define (lego-renewal-services config)
(append-map
(lambda (certificate)
(if (lego-certificate-configuration-acme-enabled? certificate)
(let ((program (lego-certificate-program config certificate)))
(list
(shepherd-service
(documentation
(string-append "Renew the ACME certificate for "
(lego-certificate-configuration-name certificate)
" on a timer."))
(provision
(list (lego-certificate-service-symbol "lego-renewal"
certificate)))
(requirement
(append '(user-processes networking)
(lego-certificate-configuration-requirement certificate)))
(modules '((shepherd service timer)))
(start
#~(let ((minutes '#$(lego-configuration-renew-minutes config))
(hours '#$(lego-configuration-renew-hours config)))
(make-timer-constructor
(calendar-event
#:minutes minutes
#:hours hours)
(command (list #$program))
#:wait-for-termination? #t)))
(stop #~(make-timer-destructor))
(actions
(list shepherd-trigger-action
(shepherd-configuration-action program))))
(shepherd-service
(documentation
(string-append "Attempt ACME renewal for "
(lego-certificate-configuration-name certificate)
" at boot."))
(provision
(list (lego-certificate-service-symbol "lego-bootstrap"
certificate)))
(requirement
(append '(user-processes networking)
(lego-certificate-configuration-requirement certificate)))
(one-shot? #t)
(start #~(lambda _
(zero? (system* #$program))))
(respawn? #f))))
'()))
(let ((program (lego-certificate-program config certificate)))
(list
(shepherd-service
(documentation
(string-append "Renew the ACME certificate for "
(lego-certificate-configuration-name certificate)
" on a timer."))
(provision
(list (lego-certificate-service-symbol "lego-renewal"
certificate)))
(requirement
(append '(user-processes networking)
(lego-certificate-configuration-requirement certificate)))
(modules '((shepherd service timer)))
(start
#~(let ((minutes '#$(lego-configuration-renew-minutes config))
(hours '#$(lego-configuration-renew-hours config)))
(make-timer-constructor
(calendar-event
#:minutes minutes
#:hours hours)
(command (list #$program))
#:wait-for-termination? #t)))
(stop #~(make-timer-destructor))
(actions
(list shepherd-trigger-action
(shepherd-configuration-action program))))
(shepherd-service
(documentation
(string-append "Attempt ACME renewal for "
(lego-certificate-configuration-name certificate)
" at boot."))
(provision
(list (lego-certificate-service-symbol "lego-bootstrap"
certificate)))
(requirement
(append '(user-processes networking)
(lego-certificate-configuration-requirement certificate)))
(one-shot? #t)
(start #~(lambda _
(zero? (system* #$program))))
(respawn? #f)))))
(lego-configuration-certificates config)))
(define (lego-activation config)
tribes/services/tribes.scm
+44 -185
View File
@@ -55,8 +55,6 @@
tribes-configuration-dns-cluster-query
tribes-configuration-extra-environment-variables
tribes-configuration-log-file
tribes-configuration-open-files-soft-limit
tribes-configuration-open-files-hard-limit
tribes-service-type))
(define-record-type* <tribes-configuration>
@@ -131,11 +129,7 @@
(extra-environment-variables tribes-configuration-extra-environment-variables
(default '()))
(log-file tribes-configuration-log-file
(default "/var/log/tribes/tribes.log"))
(open-files-soft-limit tribes-configuration-open-files-soft-limit
(default 32768))
(open-files-hard-limit tribes-configuration-open-files-hard-limit
(default 65535)))
(default "/var/log/tribes/tribes.log")))
(define (tribes-accounts config)
(list
@@ -210,33 +204,6 @@
(define (tribes-deploy-directory config)
(string-append (tribes-configuration-working-directory config) "/deploy"))
(define (tribes-local-control-socket-file _config)
"/var/run/tribes/local-control.sock")
(define (tribes-generated-configuration-file _config)
"/etc/tribes/configuration.scm")
(define (tribes-human-friendly-configuration-file _config)
"/etc/config.scm")
(define (tribes-generated-configuration-text)
(string-append
";; Auto-generated by guix-tribes / Tribes local-control.\n"
";; Edit /etc/tribes/host-config.json and /etc/tribes/system-facts.json instead.\n"
";; This file is provided so Guix users can still discover the active system\n"
";; configuration in a familiar place.\n\n"
"(use-modules (guix gexp)\n"
" (gnu packages guile))\n\n"
"(with-extensions (list guile-json-4)\n"
" (begin\n"
" (use-modules (tribes system materialize))\n"
" (tribes-operating-system-from-json-files\n"
" #:host-config-file \"/etc/tribes/host-config.json\"\n"
" #:system-facts-file \"/etc/tribes/system-facts.json\")))\n"))
(define (tribes-migrations-log-file _config)
"/var/log/tribes/tribes-migrations.log")
(define (tribes-plugin-profile-packages config)
(append-map tribes-external-plugin-extra-packages
(tribes-configuration-plugins config)))
@@ -271,8 +238,6 @@
#$(tribes-configuration-sync-bind-address config))
#~(setenv "TRIBES_PLUGIN_DIR" #$(tribes-effective-plugin-directory config))
#~(setenv "TRIBES_PLUGIN_CATALOG" #$(tribes-effective-plugin-catalog config))
#~(setenv "TRIBES_LOCAL_CONTROL_SOCKET"
#$(tribes-local-control-socket-file config))
#~(setenv "TRIBES_SYNC_OVERLAP_SECONDS"
#$(number->string
(tribes-configuration-sync-overlap-seconds config)))
@@ -280,12 +245,6 @@
#$(string-join
(tribes-configuration-admin-pubkeys config)
","))
;; The Tribes plugin manager dynamically adds external plugin ebin
;; directories at runtime. Elixir releases default to Erlang embedded
;; mode, which prevents those newly added paths from being loaded during
;; application startup. Use interactive mode so packaged external
;; plugins can be loaded after a rollout switches the service profile.
#~(setenv "RELEASE_MODE" "interactive")
#~(setenv "RELEASE_DISTRIBUTION" #$distribution)
#~(setenv "SSL_CERT_DIR" "/etc/ssl/certs")
#~(setenv "SSL_CERT_FILE" "/etc/ssl/certs/ca-certificates.crt"))
@@ -369,18 +328,6 @@
"tribes-app"
(cons #$command '#$args)))))
(define (tribes-user-command config name command args)
(let ((launcher (tribes-launcher config command args)))
(program-file
(string-append "tribes-" name "-as-user")
#~(begin
(let* ((user (getpwnam #$(tribes-configuration-user config)))
(group (getgrnam #$(tribes-configuration-group config))))
(setgroups (vector (group:gid group)))
(setgid (group:gid group))
(setuid (passwd:uid user))
(execl #$launcher #$launcher))))))
(define (tribes-activation config)
#~(begin
(use-modules (guix build utils)
@@ -392,6 +339,7 @@
(dirs (append
(list #$(tribes-configuration-working-directory config)
(dirname #$(tribes-configuration-log-file config))
#$(tribes-deploy-directory config)
(dirname #$(tribes-configuration-secret-key-base-file config))
(dirname #$(tribes-configuration-release-cookie-file config))
(dirname #$(tribes-configuration-token-signing-secret-file config)))
@@ -399,167 +347,76 @@
(if (and plugin-dir
(not (string-prefix? "/gnu/store/" plugin-dir)))
(list plugin-dir)
'()))))
(deploy-dir #$(tribes-deploy-directory config))
(generated-config-file #$(tribes-generated-configuration-file config))
(human-friendly-config-file
#$(tribes-human-friendly-configuration-file config))
(generated-config-text #$(tribes-generated-configuration-text)))
'())))))
(for-each
(lambda (dir)
(mkdir-p dir)
(chown dir uid gid))
dirs)
(mkdir-p deploy-dir)
(chown deploy-dir 0 0)
(chmod deploy-dir #o700)
(mkdir-p (dirname generated-config-file))
(call-with-output-file generated-config-file
(lambda (port)
(display generated-config-text port)))
(chown generated-config-file 0 0)
(chmod generated-config-file #o644)
(when (false-if-exception (lstat human-friendly-config-file))
(delete-file human-friendly-config-file))
(symlink generated-config-file human-friendly-config-file))))
dirs))))
(define (tribes-migration-runner-shepherd-service config provision expression)
(let* ((launcher (tribes-user-command
config
(symbol->string provision)
"eval"
(list expression)))
(capture-launcher
(program-file
"tribes-migrations-capture"
#~(begin
(dup2 1 2)
(execl #$launcher #$launcher))))
(log-file (tribes-migrations-log-file config))
(logged-launcher
(program-file
"tribes-migrations-logged"
#~(begin
(use-modules (ice-9 popen)
(ice-9 rdelim))
(define (timestamp)
(strftime "%Y-%m-%dT%H:%M:%S%z"
(localtime (current-time))))
(define (write-end port)
(format port "== tribes-migrations end ~a ==~%"
(timestamp))
(force-output port))
(let ((port (open-file #$log-file "a")))
(format port "~%== tribes-migrations start ~a ==~%"
(timestamp))
(format port "launcher: ~a~%" #$launcher)
(force-output port)
(catch #t
(lambda ()
(let ((pipe (open-pipe* OPEN_READ #$capture-launcher)))
(let loop ()
(let ((line (read-line pipe 'concat)))
(cond
((eof-object? line) #t)
(else
(display line)
(display line port)
(force-output port)
(loop)))))
(let ((status (close-pipe pipe)))
(format port "exit status: ~a~%" status)
(write-end port)
(close-port port)
(primitive-exit (if (zero? status) 0 1)))))
(lambda args
(format port "exception: ~s~%" args)
(write-end port)
(close-port port)
(primitive-exit 1))))))))
(define (tribes-migrations-shepherd-service config)
(let ((launcher (tribes-launcher
config
"eval"
'("Tribes.Release.migrate_with_storage_up()"))))
(list
(shepherd-service
(documentation (string-append "Run Tribes migration expression: " expression))
(provision (list provision))
(documentation "Run Tribes database migrations.")
(provision '(tribes-migrations))
(requirement '(postgres user-processes))
(one-shot? #t)
(start
#~(lambda _
(zero? (system* #$logged-launcher))))
(zero? (spawn-command
(list #$launcher)
#:user #$(tribes-configuration-user config)
#:group #$(tribes-configuration-group config)))))
(respawn? #f)))))
(define (tribes-migrations-shepherd-service config)
(tribes-migration-runner-shepherd-service
config
'tribes-migrations
"Tribes.Release.migrate_with_storage_up()"))
(define (tribes-plugin-rollback-migrations-shepherd-service config)
(tribes-migration-runner-shepherd-service
config
'tribes-plugin-rollback-migrations
"Tribes.Release.rollback_plugins(0)"))
(define (tribes-resource-limits config)
`((nofile
,(tribes-configuration-open-files-soft-limit config)
,(tribes-configuration-open-files-hard-limit config))))
(define (tribes-shepherd-service config)
(let ((launcher (tribes-launcher config "start" '())))
(list
(shepherd-service
(documentation "Run the Tribes application service.")
(documentation "Run the Tribes application service.")
(provision '(tribes))
(requirement '(tribes-local-control tribes-migrations networking
user-processes))
(requirement '(tribes-migrations networking user-processes))
(start
#~(make-forkexec-constructor
(list #$launcher)
#:user #$(tribes-configuration-user config)
#:group #$(tribes-configuration-group config)
#:log-file #$(tribes-configuration-log-file config)
#:resource-limits '#$(tribes-resource-limits config)))
#:log-file #$(tribes-configuration-log-file config)))
(stop #~(make-kill-destructor))
(respawn? #f)))))
(define (tribes-local-control-launcher config)
(program-file
"tribes-local-control-launcher"
#~(begin
(setenv "TRIBES_LOCAL_CONTROL_GROUP"
#$(tribes-configuration-group config))
(setenv "TRIBES_LOCAL_CONTROL_SOCKET"
#$(tribes-local-control-socket-file config))
(setenv "TRIBES_CURRENT_CONFIG_FILE"
#$(tribes-human-friendly-configuration-file config))
(setenv "TRIBES_GUIX_HELPER"
#$(file-append tribes-command-package
"/bin/tribes-guix-helper"))
(execl #$(file-append tribes-command-package
"/bin/tribes-local-control")
"tribes-local-control"))))
(define (tribes-local-control-shepherd-service config)
(let ((launcher (tribes-local-control-launcher config)))
(list
(shepherd-service
(documentation "Run the local Tribes control broker.")
(provision '(tribes-local-control))
(requirement '(user-processes))
(start
#~(make-forkexec-constructor
(list #$launcher)))
(stop #~(make-kill-destructor))
(respawn? #f)))))
(define (tribes-deploy-shepherd-service _config)
(list
(shepherd-service
(documentation "Apply a pending Tribes deployment request.")
(provision '(tribes-deploy-apply))
(requirement '(user-processes))
(one-shot? #t)
(start
#~(lambda _
(zero? (system* #$(file-append tribes-command-package
"/bin/tribes-deploy-exec")
"run-pending"))))
(respawn? #f))))
(define (tribes-root-shepherd-services config)
(append (tribes-migrations-shepherd-service config)
(tribes-plugin-rollback-migrations-shepherd-service config)
(tribes-shepherd-service config)
(tribes-local-control-shepherd-service config)))
(tribes-deploy-shepherd-service config)))
(define (tribes-sudoers-entries config)
`(("sudoers.d/tribes-deploy-exec"
,(plain-file
"tribes-deploy-exec.sudoers"
(string-append
(tribes-configuration-user config)
" ALL=(root) NOPASSWD: /run/current-system/profile/bin/tribes-deploy-exec status\n"
(tribes-configuration-user config)
" ALL=(root) NOPASSWD: /run/current-system/profile/bin/tribes-deploy-exec apply *\n")))))
(define (tribes-profile-packages config)
(match (tribes-effective-package config)
@@ -591,6 +448,8 @@
tribes-accounts)
(service-extension activation-service-type
tribes-activation)
(service-extension etc-service-type
tribes-sudoers-entries)
(service-extension shepherd-root-service-type
tribes-root-shepherd-services)
(service-extension profile-service-type
tribes/services/vinyl.scm
+3 -15
View File
@@ -18,8 +18,6 @@
vinyl-configuration-storage
vinyl-configuration-parameters
vinyl-configuration-extra-options
vinyl-configuration-open-files-soft-limit
vinyl-configuration-open-files-hard-limit
vinyl-service-type))
(define-record-type* <vinyl-configuration>
@@ -40,11 +38,7 @@
(parameters vinyl-configuration-parameters
(default '()))
(extra-options vinyl-configuration-extra-options
(default '()))
(open-files-soft-limit vinyl-configuration-open-files-soft-limit
(default 32768))
(open-files-hard-limit vinyl-configuration-open-files-hard-limit
(default 65535)))
(default '())))
(define %vinyl-accounts
(list
@@ -75,17 +69,12 @@
#~(begin
#$@(map vinyl-activation-gexp configs)))
(define (vinyl-resource-limits config)
`((nofile
,(vinyl-configuration-open-files-soft-limit config)
,(vinyl-configuration-open-files-hard-limit config))))
(define (vinyl-shepherd-services configs)
(append-map
(lambda (config)
(match config
(($ <vinyl-configuration> package name backend vcl listen storage
parameters extra-options _ _)
parameters extra-options)
(let ((state-dir (vinyl-state-directory name)))
(list
(shepherd-service
@@ -113,8 +102,7 @@
(car parameter)
(cdr parameter))))
parameters)
#$@extra-options)
#:resource-limits '#$(vinyl-resource-limits config)))
#$@extra-options)))
(stop #~(make-kill-destructor))))))))
configs))
tribes/system/installer.scm
+2 -4
View File
@@ -15,8 +15,7 @@
initrd
interface
authorized-keys-file
(extra-services '())
(enable-bbr? #t))
(extra-services '()))
"Return an installed NBDE operating-system extended with PostgreSQL and the
Tribes service using an explicit host configuration record."
(unless (tribes-host-configuration? host-configuration)
@@ -26,8 +25,7 @@ Tribes service using an explicit host configuration record."
(postgresql (postgresql-configuration
(postgresql postgresql)))
(tribes (tribes-host-configuration-tribes host-configuration))
(edge (tribes-host-configuration-edge host-configuration))
(enable-bbr? enable-bbr?))))
(edge (tribes-host-configuration-edge host-configuration)))))
(nbde-installed-operating-system
#:host-name host-name
#:bootloader bootloader
tribes/system/materialize.scm
-157
View File
@@ -1,157 +0,0 @@
(define-module (tribes system materialize)
#:use-module (gnu bootloader)
#:use-module (gnu bootloader grub)
#:use-module (gnu packages cryptsetup)
#:use-module (gnu packages curl)
#:use-module (gnu services)
#:use-module (gnu system file-systems)
#:use-module (gnu system mapped-devices)
#:use-module (gnu system uuid)
#:use-module (guix gexp)
#:use-module (ice-9 match)
#:use-module (nbde packages crypto)
#:use-module (nbde services tang)
#:use-module (nbde system initrd)
#:use-module (nbde system mapped-devices)
#:use-module (tribes config host)
#:use-module (tribes config system-facts)
#:use-module (tribes system installer)
#:export (tribes-host-configuration+system-facts->operating-system
tribes-operating-system-from-json-files))
(define (uuid-type-for-file-system file-system-type)
(match file-system-type
("vfat" 'fat32)
(_ (string->symbol file-system-type))))
(define (bootloader-configuration-from-system-facts system-facts)
(let ((targets (tribes-system-facts-bootloader-targets system-facts)))
(match (tribes-system-facts-boot-mode system-facts)
("efi"
(bootloader-configuration
(bootloader grub-efi-removable-bootloader)
(targets targets)))
(_
(bootloader-configuration
(bootloader grub-bootloader)
(targets targets))))))
(define (optional-local-boot-key-file system-facts)
(let ((local-boot-key-file
(tribes-system-facts-local-boot-key-file system-facts)))
(and (string? local-boot-key-file)
(file-exists? local-boot-key-file)
(local-file local-boot-key-file))))
(define (clevis-luks-device-kind-from-system-facts system-facts)
(let ((key-file (optional-local-boot-key-file system-facts))
(base clevis-luks-device-mapping))
(mapped-device-kind
(open
(lambda (source targets)
((mapped-device-kind-open base) source targets #:key-file key-file)))
(close (mapped-device-kind-close base))
(modules (mapped-device-kind-modules base))
(check (mapped-device-kind-check base)))))
(define (mapped-devices-from-system-facts system-facts)
(list
(mapped-device
(source (uuid (tribes-system-facts-root-luks-uuid system-facts)
'luks))
(target (tribes-system-facts-root-mapper-name system-facts))
(type (clevis-luks-device-kind-from-system-facts system-facts)))))
(define (initrd-from-system-facts system-facts)
(let ((mapped-devices (mapped-devices-from-system-facts system-facts))
(interface (tribes-system-facts-interface system-facts))
(timeout (tribes-system-facts-initrd-network-timeout-seconds
system-facts)))
(lambda (file-systems . rest)
(apply clevis-initrd file-systems
#:mapped-devices mapped-devices
#:network (nbde-network-configuration
(interface interface)
(timeout timeout))
rest))))
(define (file-systems-from-system-facts system-facts)
(append
(list
(file-system
(mount-point "/")
(device (string-append "/dev/mapper/"
(tribes-system-facts-root-mapper-name system-facts)))
(type (tribes-system-facts-root-file-system-type system-facts)))
(file-system
(mount-point "/boot")
(device (uuid (tribes-system-facts-boot-partition-uuid system-facts)
(uuid-type-for-file-system
(tribes-system-facts-boot-partition-file-system-type
system-facts))))
(type (tribes-system-facts-boot-partition-file-system-type system-facts))))
(let ((efi-uuid (tribes-system-facts-efi-partition-uuid system-facts)))
(if efi-uuid
(list
(file-system
(mount-point "/boot/efi")
(device (uuid efi-uuid
(uuid-type-for-file-system
(tribes-system-facts-efi-partition-file-system-type
system-facts))))
(type (tribes-system-facts-efi-partition-file-system-type
system-facts))))
'()))
%base-file-systems))
(define (extra-services-from-system-facts system-facts)
(list
(service tang-service-type
(tang-configuration
(port (tribes-system-facts-tang-port system-facts))))
(simple-service
'tribes-node-nbde-packages
profile-service-type
(list clevis cryptsetup curl))))
(define (authorized-keys-local-file system-facts)
(let ((authorized-keys-file
(tribes-system-facts-authorized-keys-file system-facts)))
(unless (and (string? authorized-keys-file)
(file-exists? authorized-keys-file))
(error "authorized keys file does not exist"
authorized-keys-file))
(local-file authorized-keys-file)))
(define (tribes-host-configuration+system-facts->operating-system
host-configuration
system-facts)
(unless (tribes-host-configuration? host-configuration)
(error "host-configuration must be a tribes-host-configuration record"))
(unless (tribes-system-facts? system-facts)
(error "system-facts must be a tribes-system-facts record"))
(tribes-installer-operating-system
#:host-name (tribes-system-facts-host-name system-facts)
#:host-configuration host-configuration
#:bootloader (bootloader-configuration-from-system-facts system-facts)
#:mapped-devices (mapped-devices-from-system-facts system-facts)
#:file-systems (file-systems-from-system-facts system-facts)
#:initrd (initrd-from-system-facts system-facts)
#:interface (tribes-system-facts-interface system-facts)
#:authorized-keys-file (authorized-keys-local-file system-facts)
#:extra-services (extra-services-from-system-facts system-facts)
#:enable-bbr? (tribes-system-facts-enable-bbr? system-facts)))
(define* (tribes-operating-system-from-json-files
#:key
(host-config-file "/etc/tribes/host-config.json")
(system-facts-file "/etc/tribes/system-facts.json"))
(let ((json->scm
(module-ref (resolve-interface '(json)) 'json->scm)))
(let ((host-config
(call-with-input-file host-config-file json->scm))
(system-facts
(call-with-input-file system-facts-file json->scm)))
(tribes-host-configuration+system-facts->operating-system
(json-scm->tribes-host-configuration host-config)
(json-scm->tribes-system-facts system-facts)))))
tribes/system/node.scm
+64 -114
View File
@@ -1,10 +1,7 @@
(define-module (tribes system node)
#:use-module (gnu packages databases)
#:use-module (gnu packages linux)
#:use-module (gnu services)
#:use-module (gnu services databases)
#:use-module (gnu services linux)
#:use-module (gnu services sysctl)
#:use-module (guix gexp)
#:use-module (guix records)
#:use-module (srfi srfi-1)
@@ -33,7 +30,6 @@
tribes-node-configuration-postgresql
tribes-node-configuration-tribes
tribes-node-configuration-edge
tribes-node-configuration-enable-bbr?
tribes-node-services))
(define-record-type* <tribes-edge-configuration>
@@ -73,9 +69,7 @@
(tribes tribes-node-configuration-tribes
(default (tribes-configuration)))
(edge tribes-node-configuration-edge
(default #f))
(enable-bbr? tribes-node-configuration-enable-bbr?
(default #t)))
(default #f)))
(define (tribes-node-postgresql-roles config)
(let ((tribes (tribes-node-configuration-tribes config)))
@@ -91,11 +85,8 @@
subjects)))
(define (edge-certificate-config edge tribes)
(let* ((subjects (edge-certificate-subjects edge tribes))
(email (tribes-edge-configuration-certificate-email edge))
(certificate-profile
(tribes-edge-configuration-certificate-profile edge))
(self-signed-only? (string=? certificate-profile "self-signed")))
(let ((subjects (edge-certificate-subjects edge tribes))
(email (tribes-edge-configuration-certificate-email edge)))
(unless email
(error "edge certificate email is required"
(tribes-edge-configuration-certificate-name edge)))
@@ -103,12 +94,11 @@
(name (tribes-edge-configuration-certificate-name edge))
(subjects subjects)
(email email)
(profile (and (not self-signed-only?) certificate-profile))
(profile (tribes-edge-configuration-certificate-profile edge))
(listen-http
(format #f "~a:~a"
(tribes-edge-configuration-challenge-address edge)
(tribes-edge-configuration-challenge-port edge)))
(acme-enabled? (not self-signed-only?))
(renew-days (tribes-edge-configuration-renew-days edge))
(requirement '(vinyl-tribes-http))
(reload-services '(hitch)))))
@@ -142,89 +132,67 @@
" return (deliver);\n"
"}\n")))
(define (edge-cache-vcl-text edge tribes)
(string-append
"vcl 4.1;\n\n"
"backend tribes {\n"
" .host = \"" (or (tribes-configuration-listen-address tribes)
"127.0.0.1") "\";\n"
" .port = \"" (number->string
(tribes-configuration-listen-port tribes)) "\";\n"
" .connect_timeout = 1s;\n"
" .first_byte_timeout = 5s;\n"
" .between_bytes_timeout = 5s;\n"
" .probe = {\n"
" .url = \"/healthz\";\n"
" .interval = 5s;\n"
" .timeout = 1s;\n"
" .window = 5;\n"
" .threshold = 3;\n"
" }\n"
"}\n\n"
"sub vcl_recv {\n"
" set req.http.X-Forwarded-Proto = \"https\";\n"
" set req.http.X-Forwarded-Port = \"" (number->string
(tribes-edge-configuration-https-port edge))
"\";\n"
" set req.http.X-Forwarded-Host = req.http.host;\n"
" if (req.restarts == 0) {\n"
" if (req.http.X-Forwarded-For) {\n"
" set req.http.X-Forwarded-For = req.http.X-Forwarded-For + \", \" + client.ip;\n"
" } else {\n"
" set req.http.X-Forwarded-For = client.ip;\n"
" }\n"
" }\n\n"
" if (req.http.Upgrade ~ \"(?i)websocket\" ||\n"
" req.url ~ \"^/(live|ws/gql|nostr/relay)\") {\n"
" return (pipe);\n"
" }\n\n"
" if (req.method != \"GET\" && req.method != \"HEAD\") {\n"
" return (pass);\n"
" }\n\n"
" if (req.url ~ \"^/(assets/|fonts/|images/)\" ||\n"
" req.url ~ \"^/(favicon\\\\.ico|robots\\\\.txt)$\") {\n"
" return (hash);\n"
" }\n\n"
" return (pass);\n"
"}\n\n"
"sub vcl_backend_response {\n"
" if ((bereq.method == \"GET\" || bereq.method == \"HEAD\") &&\n"
" beresp.status >= 500 && beresp.status <= 599 &&\n"
" bereq.retries < 5) {\n"
" return (retry);\n"
" }\n\n"
" if (beresp.status >= 500 && beresp.status <= 599) {\n"
" set beresp.uncacheable = true;\n"
" set beresp.ttl = 0s;\n"
" return (deliver);\n"
" }\n\n"
" if (bereq.url ~ \"^/(assets/|fonts/|images/)\" ||\n"
" bereq.url ~ \"^/(favicon\\\\.ico|robots\\\\.txt)$\") {\n"
" unset beresp.http.Set-Cookie;\n"
" set beresp.ttl = 1h;\n"
" set beresp.grace = 5m;\n"
" return (deliver);\n"
" }\n\n"
" set beresp.uncacheable = true;\n"
" set beresp.ttl = 0s;\n"
" return (deliver);\n"
"}\n\n"
"sub vcl_backend_error {\n"
" if ((bereq.method == \"GET\" || bereq.method == \"HEAD\") &&\n"
" bereq.retries < 5) {\n"
" return (retry);\n"
" }\n"
"}\n\n"
"sub vcl_deliver {\n"
" unset resp.http.X-Vinyl;\n"
" unset resp.http.X-Cache;\n"
" unset resp.http.Via;\n"
"}\n"))
(define (edge-cache-vcl edge tribes)
(plain-file
"tribes-edge-cache.vcl"
(edge-cache-vcl-text edge tribes)))
(string-append
"vcl 4.1;\n\n"
"backend tribes {\n"
" .host = \"" (or (tribes-configuration-listen-address tribes)
"127.0.0.1") "\";\n"
" .port = \"" (number->string
(tribes-configuration-listen-port tribes)) "\";\n"
" .probe = {\n"
" .url = \"/healthz\";\n"
" .interval = 5s;\n"
" .timeout = 1s;\n"
" .window = 5;\n"
" .threshold = 3;\n"
" }\n"
"}\n\n"
"sub vcl_recv {\n"
" set req.http.X-Forwarded-Proto = \"https\";\n"
" set req.http.X-Forwarded-Port = \"" (number->string
(tribes-edge-configuration-https-port edge))
"\";\n"
" set req.http.X-Forwarded-Host = req.http.host;\n"
" if (req.restarts == 0) {\n"
" if (req.http.X-Forwarded-For) {\n"
" set req.http.X-Forwarded-For = req.http.X-Forwarded-For + \", \" + client.ip;\n"
" } else {\n"
" set req.http.X-Forwarded-For = client.ip;\n"
" }\n"
" }\n\n"
" if (req.http.Upgrade ~ \"(?i)websocket\" ||\n"
" req.url ~ \"^/(live|ws/gql|nostr/relay)\") {\n"
" return (pipe);\n"
" }\n\n"
" if (req.method != \"GET\" && req.method != \"HEAD\") {\n"
" return (pass);\n"
" }\n\n"
" if (req.url ~ \"^/(assets/|fonts/|images/)\" ||\n"
" req.url ~ \"^/(favicon\\\\.ico|robots\\\\.txt)$\") {\n"
" return (hash);\n"
" }\n\n"
" return (pass);\n"
"}\n\n"
"sub vcl_backend_response {\n"
" if (bereq.url ~ \"^/(assets/|fonts/|images/)\" ||\n"
" bereq.url ~ \"^/(favicon\\\\.ico|robots\\\\.txt)$\") {\n"
" unset beresp.http.Set-Cookie;\n"
" set beresp.ttl = 1h;\n"
" set beresp.grace = 5m;\n"
" return (deliver);\n"
" }\n\n"
" set beresp.uncacheable = true;\n"
" set beresp.ttl = 0s;\n"
" return (deliver);\n"
"}\n\n"
"sub vcl_deliver {\n"
" unset resp.http.X-Vinyl;\n"
" unset resp.http.X-Cache;\n"
" unset resp.http.Via;\n"
"}\n")))
(define (edge-services config)
(let* ((tribes (tribes-node-configuration-tribes config))
@@ -253,8 +221,7 @@
(tribes-edge-configuration-cache-address edge)
":"
(number->string cache-port))))
(storage (tribes-edge-configuration-cache-storage edge))
(parameters '((max_retries . 5))))))
(storage (tribes-edge-configuration-cache-storage edge)))))
(service hitch-service-type
(hitch-configuration
(backend (format #f "[~a]:~a"
@@ -264,19 +231,6 @@
(format #f "[::]:~a" https-port)))
(pem-files (list (lego-certificate-full-pem certificate))))))))
(define (tribes-node-bbr-services config)
(if (tribes-node-configuration-enable-bbr? config)
(list
(simple-service 'tribes-bbr-kernel-modules
kernel-module-loader-service-type
'("sch_fq" "tcp_bbr"))
(simple-service
'tribes-bbr-sysctl
sysctl-service-type
'(("net.core.default_qdisc" . "fq")
("net.ipv4.tcp_congestion_control" . "bbr"))))
'()))
(define (tribes-node-services config)
(let* ((tribes (tribes-node-configuration-tribes config))
(plugins (tribes-configuration-plugins tribes))
@@ -293,11 +247,7 @@
postgresql-role-service-type
(tribes-node-postgresql-roles config))
(service tribes-service-type
tribes)
(simple-service 'tribes-node-network-tools
profile-service-type
(list iptables)))
(tribes-node-bbr-services config)
tribes))
plugin-services
(if (tribes-node-configuration-edge config)
(edge-services config)