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

Compare commits

merge into: tribes/guix-tribes:kexec-installer
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
kexec-installer .. 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
107 changed files with 1518 additions and 16624 deletions
Expand all files Collapse all files
.gitea/workflows/pinned-e2e.yml
-110
View File
@@ -1,110 +0,0 @@
name: Pinned Docker E2E
on:
push:
branches: [master]
workflow_dispatch:
concurrency:
group: pinned-docker-e2e-${{ github.ref }}
cancel-in-progress: true
jobs:
pinned-docker-e2e:
if: ${{ github.event_name == 'workflow_dispatch' || github.actor == 'self' }}
runs-on: nix-host
timeout-minutes: 90
env:
GUIX_SUBSTITUTE_GRACE_SECONDS: "1800"
TRIBES_DOCKER_MIRROR_URL: https://mirror.tribe-one.org/tribes-1
TRIBES_DOCKER_SYSTEM: x86_64-linux
NIX_REMOTE: daemon
NIX_CONFIG: |
experimental-features = nix-command flakes
PATH: /root/.nix-profile/bin:/run/current-system/sw/bin:/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin
steps:
- uses: actions/checkout@v4
- name: Probe host Nix
run: |
nix --version
nix store info --store daemon
nix config show | grep -E 'sandbox|experimental-features|substituters' || true
- name: Install devenv
run: nix profile add nixpkgs#devenv
- name: Wait for Guix substitute/image builder
run: sleep "$GUIX_SUBSTITUTE_GRACE_SECONDS"
- name: Download pinned debug Docker image
run: |
set -euo pipefail
commit="$(git rev-parse HEAD)"
image="tribes-debug-docker-${TRIBES_DOCKER_SYSTEM}-${commit}.tar.gz"
base="${TRIBES_DOCKER_MIRROR_URL%/}"
download() {
output="$1"
url="$2"
for attempt in $(seq 1 12); do
if curl --fail --location --output "$output" "$url"; then
return 0
fi
echo "download failed (attempt ${attempt}/12): $url" >&2
sleep 15
done
return 1
}
download "$image" "$base/$image"
download "$image.sha256" "$base/$image.sha256"
sha256sum -c "$image.sha256"
loaded_image="$(docker load < "$image" | awk -F': ' '/Loaded image:/ { print $2; exit }')"
echo "TRIBES_IMAGE=${loaded_image}" >> "$GITHUB_ENV"
- name: Check out pinned Tribes e2e harness
run: |
set -euo pipefail
tribes_commit="$(awk '
/\(define %tribes-commit/ { in_commit = 1; next }
in_commit && match($0, /"[0-9a-f]{40}"/) {
print substr($0, RSTART + 1, 40)
exit
}
' tribes/packages/source.scm)"
if [ -z "$tribes_commit" ]; then
echo "failed to parse %tribes-commit" >&2
exit 1
fi
rm -rf ../tribes-e2e
git clone https://git.teralink.net/tribes/tribes.git ../tribes-e2e
git -C ../tribes-e2e checkout "$tribes_commit"
- name: Run core Docker e2e
run: |
set -euo pipefail
cd ../tribes-e2e
devenv shell -- bash -c '
set -euo pipefail
mix local.hex --force
mix local.rebar --force
mix deps.get
env \
SKIP_BUILD=1 \
TRIBES_IMAGE="$TRIBES_IMAGE" \
TRIBES_E2E_WITHOUT_SUPERTEST=1 \
scripts/run_e2e.sh --without-supertest
'
.guix-authorizations
-8
View File
@@ -1,8 +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"))))
.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
+46 -108
View File
@@ -1,120 +1,58 @@
# Guix Tribes Channel
## NBDE Channel
This repository is the Guix channel for Tribes OS. It contains the package,
service, system, installer, deployment, and substitute-builder definitions used
to build and operate Tribes nodes.
This repository provides the Guix-side pieces for network-bound disk
encryption:
## Contents
- `nbde/packages/crypto.scm`
Package definitions for `luksmeta`, `tang`, and `clevis`.
- `nbde/services/tang.scm`
A standalone Tang service for Guix systems.
- `nbde/system/mapped-devices.scm`
A Clevis-backed mapped-device kind with manual `cryptsetup` fallback.
- `nbde/system/initrd.scm`
A helper around `raw-initrd` for early-boot Clevis support.
- `examples/phase0-system.scm`
Minimal reference system using the Clevis-backed mapped-device kind and
custom initrd.
Network-bound disk encryption (NBDE):
- `nbde/packages/crypto.scm`: package definitions for `luksmeta`, `tang`, and
`clevis`.
- `nbde/services/tang.scm`: standalone Tang service for Guix systems.
- `nbde/system/mapped-devices.scm`: Clevis-backed mapped-device kind with manual
`cryptsetup` fallback.
- `nbde/system/initrd.scm`: early-boot Clevis support around `raw-initrd`.
- `docs/nbde.md`: operational notes for LUKS headers, initrd, Tang, and
`/boot/nbde/local-boot.key`.
Tribes packages and systems:
- `tribes/packages/devtools.scm` and `tribes/packages/node.scm`: shared tooling
package definitions used by repo-local Guix development manifests.
- `tribes/packages/source.scm`: source-built Tribes package producing a
production release from pinned source plus vendored Mix/npm dependency FODs.
- `tribes/plugins/*.scm`: external plugin package definitions and plugin
metadata.
- `tribes/services/*.scm`: Shepherd services for Tribes and supporting runtime
components.
- `tribes/system/node.scm`: node operating-system constructor.
- `tribes/system/installer.scm`: installer-facing Tribes OS constructor.
- `manifests/substitutes/*.scm` and `tribes/ci/substitutes.scm`: substitute
builder manifests and CI targets.
Deployment and diagnostics:
- `tribes/deploy/*.scm`: deployment helper API and worker/operation support used
by Legion.
- `tribes/diagnostics/*.scm`: diagnostics helpers, including system generation
comparison.
- `scripts/build-kexec-image`: builds the Legion kexec installer image.
- `scripts/build-tribes-docker-image`: builds the pinned Tribes debug Docker
image.
## Pin maintenance
Refresh the upstream Guix channel pin intentionally with:
```sh
./scripts/update-base-channels-pin
```
The script updates `pins/base-channels.sexp` and syncs the Guix entry in
`pins/legion-channels.sexp`. It auto-detects whether the current pin uses the
local `guix-fork` channel or the mirrored official Guix channel, uses the
matching sibling checkout head by default (`../guix-fork` or `../guix`), accepts
`--commit COMMIT`, and can switch back to the mirrored official channel with
`--official`.
After changing the base channel pin, run Legion's generator in `../legion_kk`:
```sh
npm run generate:guix-base-channel
```
Refresh the Tribes and external plugin source pins with:
```sh
./scripts/update-tribes-and-plugin-pins
```
By default, the pin update scripts use local `guix` for hashing and fixed-output
builds. If the local host is not suitable for Guix networked fixed-output builds,
run them explicitly on an SSH build host:
```sh
./scripts/update-tribes-and-plugin-pins --build-host HOST
```
Use `--commit` to commit the affected pin files after a successful refresh:
```sh
./scripts/update-tribes-and-plugin-pins --commit
```
The combined script updates:
It now also carries the first Tribes deployment substrate:
- `tribes/packages/release.scm`
A deployment-bridge package wrapper for a prebuilt Tribes release tree.
- `tribes/packages/source.scm`
- `tribes/plugins/sender.scm`
- `tribes/plugins/aether.scm`
- `tribes/plugins/supertest.scm`
- `tribes/plugins/kobold.scm`
- `tribes/plugins/trust.scm`
A real source-built Tribes package that produces a production release from
vendored Mix and npm dependency trees plus local Parrhesia source.
Local-source builds accept hash overrides via `TRIBES_MIX_DEPS_SHA256`,
`TRIBES_RAW_MIX_DEPS_SHA256`, and `TRIBES_NPM_DEPS_SHA256`.
- `tribes/services/tribes.scm`
Shepherd service, runtime environment wiring, and account/activation setup
for a Tribes node.
- `tribes/system/node.scm`
A higher-level service bundle that wires PostgreSQL plus the Tribes service.
- `tribes/system/installer.scm`
Installer-facing OS constructor for NBDE-installed Tribes nodes.
- `nbde/system/installed-base.scm`
Shared base installed-system constructor used by both the minimal NBDE flow
and the Tribes-specific installer path.
For one-off updates, use `scripts/update-tribes-pin` or
`scripts/update-plugin-pin --help` directly.
Current development status:
## Channel files
1. `luksmeta`, `tang`, and `clevis` build successfully on `pguix`.
2. A disposable Tang + LUKS smoke test passes.
3. A QEMU Phase-0 system with encrypted root now boots unattended through
Clevis/Tang and reaches a login prompt.
Checked-in channel files serve different roles:
For pinned bootstrap usage, generate a `channels.scm` that combines upstream
Guix with this repository's current commit.
- `pins/base-channels.sexp`: upstream Guix pin only; used for `guix pull -C` and
related bootstrap tooling.
- `pins/legion-channels.sexp`: Legion/build-host default channel set containing
the pinned upstream Guix channel plus default `tribes` channel metadata.
- The `kexec-installer` branch selects the default kexec installer source commit.
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`.
For pinned bootstrap usage, generate a `channels.scm` that combines the pinned
upstream Guix channel with this repository's current commit.
The current Legion kexec image path is based on:
## Current development status
- `examples/build-host-kexec-installer.scm`
- `nbde/system/build-host-kexec-installer.scm`
- NBDE packages and the disposable Tang + LUKS smoke path are working.
- The QEMU Phase-0 encrypted-root system boots unattended through Clevis/Tang and
reaches a login prompt.
- The active Legion kexec image definition is based on
`examples/build-host-kexec-installer.scm` and
`nbde/system/build-host-kexec-installer.scm`.
- Tribes source, plugin, node, installer, Docker debug image, and substitute
manifest definitions are maintained in this channel.
That build-host installer is the active kexec image definition used for
Legion deployment bootstrapping.
docs/LOCAL_CONTROL_API.md
-329
View File
@@ -1,329 +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.
- discover channel update candidates from Guix's existing Git checkouts.
- 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 current system channel provenance plus the list of recorded generations in newest-first order. The top-level `current_channels` field is parsed from `/run/current-system/channels.scm` when present and lets callers identify the initial installed channel pins before local-control has prepared its first generation.
Each generation 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",
"channels": [
{
"channel_id": "guix-tribes",
"name": "tribes",
"url": "https://git.example.test/tribes/guix-tribes.git",
"branch": "master",
"commit": "abc123...",
"position": 10
}
]
}
```
`channels` is present for generations prepared by local-control from a plan
that included `resolved_channels`. After `guix pull` succeeds, local-control
records the pulled profile's `guix describe --format=json` commit for each
matching channel, so branch-based plans become exact generation pins. Active
generation `channels` are the preferred source for the currently installed
channel commit; callers can fall back to top-level `current_channels` for the
initial non-local-control install.
### `POST /v1/channels/updates`
Synchronous. Discovers update candidates for configured channels by using the
Guix channel Git checkouts under `$XDG_CACHE_HOME/guix/checkouts` or
`$HOME/.cache/guix/checkouts`. The endpoint does not maintain its own checkout
or update database; it locates the checkout whose `remote.origin.url` matches
the requested channel URL, runs `git fetch --tags --prune origin`, and inspects
Git refs directly.
Body:
```json
{
"mode": "semver_tags",
"limit": 20,
"channels": [
{
"id": "...",
"name": "tribes",
"url": "https://git.example.test/tribes/guix-tribes.git",
"branch": "master",
"current_commit": "abc123..."
}
]
}
```
Response:
```json
{
"schemaVersion": "1",
"ok": true,
"mode": "semver_tags",
"channels": [
{
"id": "...",
"name": "tribes",
"url": "https://git.example.test/tribes/guix-tribes.git",
"branch": "master",
"ok": true,
"current_commit": "abc123...",
"branch_head": "def456...",
"candidates": [
{
"tag": "v1.2.3",
"commit": "def456...",
"short_commit": "def4567",
"subject": "release 1.2.3",
"message": "release 1.2.3\n",
"committed_at": "2026-06-07T10:00:00+00:00"
}
]
}
]
}
```
Supported modes:
- `semver_tags` — default. Candidates are tags matching `vMAJOR.MINOR.PATCH`
with optional prerelease/build suffixes, reachable from the configured branch
head, and descendants of `current_commit` when one is provided.
- `commits` — advanced mode. Candidates are recent branch commits after
`current_commit` when it is an ancestor of the branch head, otherwise recent
commits from the branch head.
Guix channel authentication remains enforced later by `deployment/prepare`; this endpoint is discovery only.
Per-channel failures are returned inline with `ok: false` and an error code,
e.g. `checkout_not_found`, `fetch_failed`, `branch_not_found`, or
`unsupported_mode`.
### `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=...`, pre-realizes the
target system closure and the store inputs needed for the post-switch Shepherd
service-definition upgrade, registers the resulting GC root, and records a
`ready` generation. Keeping this work in `prepare` means missing substitutes or
unexpectedly large local builds fail before the system profile is switched. 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, and the NBDE boot-store activation hook copies GRUB-referenced
`/gnu/store` items into `/boot` for nodes whose real store is on encrypted
root. 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 later boots, `tribes-boot-start` starts the
app only after Legion-managed secret files exist, keeping the first
secrets-free boot quiet while allowing reboot recovery. 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.
- `host_capability_missing` — the pinned host and built-in plugin manifests
have an unsatisfied capability contract.
- `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.
- `system_closure_preload_failed` — the prepared system's referenced store
closure could not be realized before switching.
- `service_upgrade_preload_failed` — the post-switch Shepherd
service-definition upgrade inputs could not be realized before switching.
- `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.
docs/nbde.md
-95
View File
@@ -1,95 +0,0 @@
# NBDE boot policy
This document describes the Guix-side NBDE boot model used by Tribes nodes.
## Storage locations
NBDE state is split across three places:
- The LUKS header stores unlock methods: recovery keyslots, disposable local
boot keyslots, and Clevis/Tang bindings.
- The initrd stores generic unlock logic and helper programs. It must not store
node-local boot key material.
- `/boot/nbde/local-boot.key` stores the disposable local boot key when a node
is allowed to unlock itself without Tang peers.
Tang peer URLs and quorum settings are Clevis metadata in the LUKS header. They
are not baked into the initrd.
## Boot partition key
The initrd is built with generic logic to find the boot partition by UUID, mount
it read-only, and try `nbde/local-boot.key` before falling back to Clevis/Tang
and then interactive `cryptsetup`.
The key path exposed in system facts is:
```json
{
"localBootKeyFile": "/boot/nbde/local-boot.key"
}
```
The key bytes are not imported with `local-file`, so changing the local boot key
does not require a Guix system rebuild or a new initrd generation. Only the
fixed initrd reader logic is part of the system generation.
Legion currently creates `/boot` as an ext4 filesystem for both BIOS and EFI
nodes. EFI nodes also have a vfat `/boot/efi` partition, but the NBDE local boot
key does not live there.
## Unlock methods
Every managed NBDE node has a durable recovery secret controlled by the
management layer. That secret is used for administrative LUKS operations such as
adding local boot keys and binding Clevis pins.
The local boot key is different:
- it is generated when degraded local unlock is needed,
- it is stored only on the node under `/boot/nbde/local-boot.key`,
- it is not stored in Guix store items,
- it is not stored in Legion state,
- it only matters while the matching LUKS keyslot exists.
## State transitions
When entering degraded local-key mode:
1. Generate a fresh local boot key.
2. Write it to `/boot/nbde/local-boot.key`.
3. Add it as a LUKS keyslot using the durable recovery secret.
4. Remove obsolete Clevis bindings.
When leaving degraded mode:
1. Add the desired Clevis/Tang or Clevis SSS quorum binding.
2. Remove obsolete Clevis bindings after the new binding succeeds.
3. Remove the local boot keyslot with `cryptsetup luksRemoveKey`.
4. Best-effort overwrite `/boot/nbde/local-boot.key`, sync, and unlink it.
The LUKS header is the source of truth. If the local keyslot was removed
successfully, a leftover file under `/boot/nbde` is no longer an unlock secret.
Overwriting before unlink is hygiene for cloud block devices and ext4, not a
cryptographic erasure guarantee.
## Threat model
Without Secure Boot, measured boot, or another trusted boot chain, an
unencrypted `/boot` partition is readable by an attacker with disk access. A
local key baked into an initrd on `/boot` and a local key stored as a separate
file on `/boot` therefore have the same practical confidentiality level.
The `/boot/nbde/local-boot.key` model is preferred because it keeps key rotation
out of Guix system generation rebuilds and avoids copying secret bytes through
the Guix store and boot-store staging paths.
## Boot-store staging
The boot-store staging service remains necessary for kernel, initrd, and GRUB
store references. GRUB can read `/boot` before the encrypted root is unlocked,
but it cannot read `/gnu/store` on the encrypted root.
Local boot key material is intentionally outside that mechanism. The initrd
reader is staged as part of the normal system generation; the mutable key file
is managed directly under `/boot/nbde`.
examples/legion-host-config.json
+2 -2
View File
@@ -17,6 +17,7 @@
"syncTlsKeyFile": "/var/lib/tribes/secrets/sync/node-key.pem",
"syncTlsCaCertFile": "/var/lib/tribes/secrets/sync/ca.pem",
"adminPubkeys": [],
"syncOverlapSeconds": 300,
"databaseUser": "tribes",
"databaseName": "tribes",
"parrhesiaDatabaseName": "parrhesia",
@@ -24,8 +25,7 @@
"secretKeyBaseFile": "/var/lib/tribes/secrets/secret_key_base",
"tokenSigningSecretFile": "/var/lib/tribes/secrets/token_signing_secret",
"releaseCookieFile": "/var/lib/tribes/secrets/release_cookie",
"releaseDistribution": "name",
"releaseNode": "tribes@127.0.0.1",
"releaseDistribution": "none",
"extraEnvironmentVariables": [
"TRIBES_BOOTSTRAP_FILE=/etc/tribes/bootstrap.json"
],
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
manifests/packs/sender-runtime.scm
-18
View File
@@ -1,18 +0,0 @@
(define-module (manifests packs sender-runtime)
#:use-module (gnu packages admin)
#:use-module (gnu packages monitoring)
#:use-module (gnu packages nss)
#:use-module (guix profiles)
#:use-module (tribes packages monitoring)
#:use-module (tribes packages sender-runtime)
#:use-module (tribes packages web))
(packages->manifest
(list tribes-sender-runtime
sender-ffmpeg
vinyl
vinyl-exporter
prometheus-node-exporter
victoriametrics
shepherd
nss-certs))
manifests/sources.scm
-54
View File
@@ -1,54 +0,0 @@
;;; Manifest of upstream source origins for every package defined by the
;;; tribes channel. Consumed by Cuirass's `manifests' build type as a
;;; network-bound canary: fast-fails when an upstream URL or commit ref
;;; becomes unreachable, without depending on any actual package build.
(define-module (manifests sources)
#:use-module (gnu packages)
#:use-module (guix discovery)
#:use-module (guix packages)
#:use-module (guix profiles)
#:use-module (ice-9 match)
#:use-module (ice-9 vlist)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:export (sources-manifest))
(define (channel-module-path prefix)
(delete-duplicates
(filter-map (lambda (dir)
(let ((path (string-append dir "/" prefix)))
(and (file-exists? path) (cons dir prefix))))
%load-path)
equal?))
(define (channel-packages)
(fold-packages cons '()
(append (all-modules (channel-module-path "tribes/packages"))
(all-modules (channel-module-path "nbde/packages")))))
(define (upstream-origin source)
(origin (inherit source) (snippet #f) (patches '())))
(define (channel-origins)
(let loop ((packages (channel-packages))
(origins '())
(visited vlist-null))
(match packages
((head . tail)
(let ((new (remove (cut vhash-assq <> visited)
(package-direct-sources head))))
(loop tail (append new origins)
(fold (cut vhash-consq <> #t <>)
visited new))))
(() origins))))
(define sources-manifest
(manifest (map (lambda (origin)
(manifest-entry
(name (or (origin-actual-file-name origin) "origin"))
(version "0")
(item (upstream-origin origin))))
(channel-origins))))
sources-manifest
manifests/substitutes/base.scm
+44
View File
@@ -0,0 +1,44 @@
(define-module (manifests substitutes base)
#:use-module (gnu packages)
#:use-module (guix profiles)
#:use-module (nbde packages crypto)
#:use-module (tribes packages otp)
#:use-module (tribes packages terminals))
(define %base-specifications
'("bash-minimal"
"coreutils"
"diffutils"
"findutils"
"gawk"
"grep"
"gzip"
"inetutils"
"iproute2"
"less"
"nss-certs"
"openssh"
"postgresql"
"procps"
"rsync"
"sed"
"tar"
"which"
"xz"
"cryptsetup"
"dosfstools"
"e2fsprogs"
"gptfdisk"
"kmod"
"parted"
"util-linux"))
(packages->manifest
(append (map specification->package %base-specifications)
(list clevis
tang
luksmeta
erlang-28
elixir-otp28
elixir-hex-otp28
ghostty-terminfo)))
manifests/substitutes/installer.scm
+44
View File
@@ -0,0 +1,44 @@
(define-module (manifests substitutes installer)
#:use-module (gnu packages)
#:use-module (guix profiles)
#:use-module (nbde packages crypto))
(define %installer-specifications
'("bash-minimal"
"coreutils"
"diffutils"
"findutils"
"gawk"
"git-minimal"
"grep"
"gzip"
"guix"
"inetutils"
"iproute2"
"kexec-tools"
"less"
"curl"
"nss-certs"
"procps"
"rsync"
"sed"
"tar"
"which"
"zstd"
"xz"
"console-setup"
"cryptsetup"
"dosfstools"
"grub-efi"
"grub-pc"
"mdadm"
"e2fsprogs"
"gptfdisk"
"kmod"
"parted"
"util-linux"))
(packages->manifest
(append (map specification->package %installer-specifications)
(list clevis
luksmeta)))
manifests/substitutes/tribes-node.scm
+47
View File
@@ -0,0 +1,47 @@
(define-module (manifests substitutes tribes-node)
#:use-module (gnu packages)
#:use-module (guix profiles)
#:use-module (tribes packages otp)
#:use-module (tribes packages source)
#:use-module (tribes packages terminals)
#:use-module (tribes packages web))
(define %tribes-node-specifications
'("nss-certs"
"openssh"
"postgresql"
"rsync"
"ripgrep"
"fd"
"tmux"
"neovim"
"btop"))
(define (getenv/default name default)
(or (getenv name) default))
(define (tribes-node-package)
(let ((source-directory (getenv "TRIBES_SOURCE_DIRECTORY")))
(if source-directory
(local-tribes-package
source-directory
#:version (getenv/default "TRIBES_RELEASE_VERSION" "dev")
#:mix-deps-sha256 (getenv "TRIBES_MIX_DEPS_SHA256")
#:raw-mix-deps-sha256 (getenv "TRIBES_RAW_MIX_DEPS_SHA256")
#:npm-deps-sha256 (getenv "TRIBES_NPM_DEPS_SHA256"))
tribes-package)))
(define (make-tribes-node-manifest)
(packages->manifest
(append
(map specification->package %tribes-node-specifications)
(list erlang-28
elixir-otp28
elixir-hex-otp28
ghostty-terminfo
hitch
vinyl
lego
(tribes-node-package)))))
(make-tribes-node-manifest)
nbde/packages/crypto.scm
+1
View File
@@ -18,6 +18,7 @@
#:use-module (gnu packages hardware)
#:use-module (gnu packages jose)
#:use-module (gnu packages linux)
#:use-module (gnu packages ninja)
#:use-module (gnu packages networking)
#:use-module (gnu packages password-utils)
#:use-module (gnu packages pkg-config)
nbde/services/tang.scm
+2 -4
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)
@@ -46,8 +45,7 @@
"-l"
"-p" #$(number->string
(tang-configuration-port config))
#$(tang-configuration-key-directory config))
#:log-file "/var/log/tang.log"))
#$(tang-configuration-key-directory config))))
(stop #~(make-kill-destructor))
(respawn? #f))))
nbde/system/boot-store.scm
+40 -78
View File
@@ -1,87 +1,49 @@
(define-module (nbde system boot-store)
#:use-module (gnu services)
#:use-module (guix build utils)
#:use-module (guix gexp)
#:use-module (guix modules)
#:use-module (ice-9 regex)
#:use-module (ice-9 rdelim)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-13)
#:use-module (srfi srfi-14)
#:export (boot-store-staging-service
grub-config-store-references
stage-boot-store-references!))
(define %store-reference-rx
(make-regexp "/gnu/store/[^\" )\n\r]*"))
(define (trim-store-reference ref)
(string-trim-right ref (char-set #\; #\, #\))))
(define (line-store-references line)
(let loop ((start 0)
(refs '()))
(let ((match (regexp-exec %store-reference-rx line start)))
(if match
(loop (match:end match)
(cons (trim-store-reference (match:substring match 0)) refs))
(reverse refs)))))
(define (grub-config-store-references grub-cfg)
"Return unique /gnu/store references mentioned by GRUB-CFG."
(call-with-input-file grub-cfg
(lambda (port)
(let loop ((line (read-line port 'concat))
(refs '()))
(if (eof-object? line)
(delete-duplicates (reverse refs))
(loop (read-line port 'concat)
(append (reverse (line-store-references line)) refs)))))))
(define (delete-file-or-directory-recursively path)
(when (file-exists? path)
(if (file-is-directory? path)
(begin
(for-each make-file-writable
(find-files path (lambda (_file stat)
(eq? 'directory (stat:type stat)))
#:directories? #t))
(delete-file-recursively path))
(begin
(make-file-writable path)
(delete-file path)))))
(define* (stage-boot-store-references! boot-mount grub-cfg)
"Copy every /gnu/store item referenced by GRUB-CFG below BOOT-MOUNT.
This is needed when the real store lives on the encrypted root device: GRUB can
read /boot before the initrd unlocks root, but it cannot read root's
/gnu/store."
(for-each
(lambda (ref)
(unless (file-exists? ref)
(error "GRUB store reference does not exist" ref))
(let ((target (string-append boot-mount ref)))
(mkdir-p (dirname target))
(delete-file-or-directory-recursively target)
(if (file-is-directory? ref)
(copy-recursively ref target
#:log (%make-void-port "w")
#:keep-mtime? #t
#:keep-permissions? #t)
(copy-file ref target))))
(grub-config-store-references grub-cfg)))
#:export (boot-store-staging-service))
(define (boot-store-staging-gexp)
(with-imported-modules (source-module-closure
'((nbde system boot-store)))
(with-imported-modules '((guix build utils)
(ice-9 regex)
(ice-9 rdelim)
(srfi srfi-1))
#~(begin
(use-modules (nbde system boot-store))
(let ((grub-cfg "/boot/grub/grub.cfg")
(boot-mount "/boot"))
(when (and (file-exists? boot-mount)
(file-exists? grub-cfg))
(stage-boot-store-references! boot-mount grub-cfg))))))
(use-modules (guix build utils)
(ice-9 regex)
(ice-9 rdelim)
(srfi srfi-1))
(define grub-cfg "/boot/grub/grub.cfg")
(define boot-mount "/boot")
(define store-ref-rx (make-regexp "/gnu/store/[^\" )]*"))
(define (store-refs file)
(call-with-input-file file
(lambda (port)
(let loop ((line (read-line port 'concat))
(refs '()))
(if (eof-object? line)
(delete-duplicates (reverse refs))
(let ((match (regexp-exec store-ref-rx line)))
(loop (read-line port 'concat)
(if match
(cons (match:substring match 0) refs)
refs))))))))
(define (stage-ref ref)
(let ((target (string-append boot-mount ref)))
(mkdir-p (dirname target))
(if (file-is-directory? ref)
(begin
(mkdir-p target)
(copy-recursively ref target))
(copy-file ref target))))
(when (and (file-exists? "/boot")
(file-exists? grub-cfg))
(for-each stage-ref
(filter file-exists? (store-refs grub-cfg)))))))
(define (boot-store-staging-service)
(simple-service 'stage-grub-visible-store-items
nbde/system/build-host-kexec-installer.scm
+4 -16
View File
@@ -14,7 +14,6 @@
#:use-module (guix gexp)
#:use-module (nbde packages crypto)
#:use-module (nbde system kexec-initrd)
#:use-module (tribes packages kernel)
#:export (build-host-kexec-installer-os))
(define %build-host-kexec-shell-packages
@@ -55,10 +54,7 @@
util-linux)))
(define %build-host-kexec-initrd-modules
'(;; Common block/storage basics.
"ahci"
"ata_piix"
"cdrom"
'("ahci"
"dm-crypt"
"fat"
"loop"
@@ -67,19 +63,13 @@
"nvme"
"overlay"
"sd_mod"
"sr_mod"
"squashfs"
"vfat"
;; KVM/QEMU and common emulated or non-virtio NICs.
"virtio_blk"
"virtio_console"
"virtio_net"
"virtio_pci"
"virtio_scsi"
"e1000"
"e1000e"
"r8169"))
"virtio_scsi"))
(define build-host-kexec-installer-os
(operating-system
@@ -87,16 +77,14 @@
(timezone "Etc/UTC")
(locale "en_US.UTF-8")
(keyboard-layout (keyboard-layout "us"))
(kernel tribes-linux)
(label "Guix build-host kexec installer")
(initrd-modules %build-host-kexec-initrd-modules)
(initrd kexec-installer-initrd)
(kernel-arguments
'("console=tty0"
"console=ttyS0,115200n8"
'("console=ttyS0,115200n8"
"net.ifnames=0"
"panic=30"
"loglevel=6"))
"loglevel=4"))
(bootloader
(bootloader-configuration
(bootloader grub-bootloader)
nbde/system/build-host.scm
-3
View File
@@ -3,7 +3,6 @@
#:use-module (gnu packages)
#:use-module (gnu system linux-initrd)
#:use-module (nbde system installed-base)
#:use-module (tribes packages kernel)
#:export (nbde-build-host-operating-system))
(define %build-host-packages
@@ -26,7 +25,6 @@
authorized-keys-file
(timezone "Etc/UTC")
(locale "en_US.UTF-8")
(kernel tribes-linux)
(kernel-arguments
(list "console=tty0"
"console=ttyS0,115200n8"))
@@ -52,7 +50,6 @@ Clevis-specific runtime pieces."
#:authorized-keys-file authorized-keys-file
#:timezone timezone
#:locale locale
#:kernel kernel
#:kernel-arguments kernel-arguments
#:extra-services extra-services))
(packages
nbde/system/installed-base.scm
+3 -27
View File
@@ -5,9 +5,6 @@
#:use-module (gnu services networking)
#:use-module (gnu services ssh)
#:use-module (guix gexp)
#:use-module (nbde system boot-store)
#:use-module (tribes packages kernel)
#:use-module (tribes services logging)
#:export (nbde-installed-operating-system))
(define %tribe-one-guix-substitute-url
@@ -18,24 +15,6 @@
"guix.tribe-one.org-signing-key.pub"
"(public-key \n (ecc \n (curve Ed25519)\n (q #7F0B2300CC4BDA2520DB462BCAD45107E7C874E0E09DC8EF429B145C8A52B306#)\n )\n )\n"))
(define %nbde-initrd-modules
'("bnxt_en"
"ena"
"e1000e"
"i40e"
"ice"
"igb"
"igc"
"ixgbe"
"mlx4_core"
"mlx4_en"
"mlx5_core"
"nvme"
"r8169"
"sd_mod"
"tg3"
"virtio_scsi"))
(define* (nbde-installed-operating-system #:key
host-name
bootloader
@@ -46,12 +25,11 @@
authorized-keys-file
(timezone "Etc/UTC")
(locale "en_US.UTF-8")
(kernel tribes-linux)
(kernel-arguments
(list "console=tty0"
"console=ttyS0,115200n8"))
(initrd-modules
(append %nbde-initrd-modules
(append '("nvme" "sd_mod" "virtio_scsi")
%base-initrd-modules))
(extra-services '()))
"Return a base installed Guix system for the NBDE flow, parameterized by the
@@ -61,7 +39,6 @@ runtime-discovered boot and filesystem values from the installer."
(timezone timezone)
(locale locale)
(keyboard-layout (keyboard-layout "us"))
(kernel kernel)
(kernel-arguments kernel-arguments)
(initrd-modules initrd-modules)
(initrd initrd)
@@ -71,8 +48,7 @@ runtime-discovered boot and filesystem values from the installer."
(services
(append
extra-services
(list (boot-store-staging-service)
(service dhcpcd-service-type)
(list (service dhcpcd-service-type)
(service elogind-service-type)
(service agetty-service-type
(agetty-configuration
@@ -90,4 +66,4 @@ runtime-discovered boot and filesystem values from the installer."
(guix-extension
(authorized-keys (list %tribe-one-guix-signing-key))
(substitute-urls (list %tribe-one-guix-substitute-url)))))
(tribes-base-services)))))
%base-services))))
nbde/system/mapped-devices.scm
+10 -78
View File
@@ -13,31 +13,20 @@
#:key
(clevis-package clevis)
key-file
boot-key-file
boot-device-uuid
(boot-file-system-type "ext4")
allow-discards?
(extra-options '()))
"Return a gexp that unlocks SOURCE with a boot key file, Clevis, or an
interactive cryptsetup fallback. BOOT-KEY-FILE is relative to the boot
partition and is read at boot time, not baked into the initrd."
"Return a gexp that first tries to unlock SOURCE using Clevis and falls back
to interactive cryptsetup when that fails. The fallback path intentionally
keeps a manual recovery slot available."
(with-imported-modules (source-module-closure
'((gnu build file-systems)
(guix build syscalls)
(guix build utils)))
(match targets
((target)
#~(let ((source #$(if (uuid? source)
(uuid-bytevector source)
source))
(keyfile #$key-file)
(boot-key-file #$boot-key-file)
(boot-source #$(and boot-device-uuid
(if (uuid? boot-device-uuid)
(uuid-bytevector boot-device-uuid)
boot-device-uuid)))
(boot-file-system-type #$boot-file-system-type)
(boot-mount "/run/nbde-boot"))
(keyfile #$key-file))
(mkdir-p "/run/cryptsetup/")
(let* ((partition
@@ -71,65 +60,7 @@ partition and is read at boot time, not baked into the initrd."
'())
'#$extra-options
(list partition #$target))))
(define (try-key-file path label)
(and path
(file-exists? path)
(begin
(format #t "nbde: trying ~a key file for ~a -> ~a~%"
label partition #$target)
(force-output)
(zero? (apply system*/tty cryptsetup-bin
"--key-file" path
cryptsetup-flags)))))
(define (resolve-boot-partition)
(and boot-source
(or (let loop ((tries-left 20))
(and (positive? tries-left)
(or (find-partition-by-uuid boot-source)
(begin
(format #t "nbde: waiting for boot partition (~a tries left)~%"
tries-left)
(force-output)
(sleep 1)
(loop (- tries-left 1))))))
(begin
(format #t "nbde: boot partition not found~%")
(force-output)
#f))))
(define (try-boot-key-file)
(and boot-key-file
boot-source
(let ((boot-partition (resolve-boot-partition))
(mounted? #f))
(and boot-partition
(catch #t
(lambda ()
(dynamic-wind
(lambda ()
(mkdir-p boot-mount)
(mount boot-partition boot-mount
boot-file-system-type MS_RDONLY)
(set! mounted? #t))
(lambda ()
(let ((path (string-append boot-mount "/"
boot-key-file)))
(try-key-file path "boot")))
(lambda ()
(when mounted?
(catch #t
(lambda () (umount boot-mount))
(lambda _ #f))))))
(lambda args
(format #t "nbde: failed to read boot key file: ~a~%"
args)
(force-output)
#f))))))
(or (try-boot-key-file)
(try-key-file keyfile "embedded")
(zero? (system* shell-bin "-c"
(or (zero? (system* shell-bin "-c"
(string-append
"attempt=0; "
"while :; do "
@@ -149,6 +80,10 @@ partition and is read at boot time, not baked into the initrd."
"fi; "
"sleep 2; "
"done")))
(and keyfile
(zero? (apply system*/tty cryptsetup-bin
"--key-file" keyfile
cryptsetup-flags)))
(zero? (apply system*/tty cryptsetup-bin
cryptsetup-flags)))))))))
@@ -164,9 +99,6 @@ partition and is read at boot time, not baked into the initrd."
(close close-clevis-luks-device)
(modules '((rnrs bytevectors)
((gnu build file-systems)
#:select (find-partition-by-luks-uuid find-partition-by-uuid
system*/tty))
((guix build syscalls)
#:select (MS_RDONLY))
#:select (find-partition-by-luks-uuid system*/tty))
((guix build utils)
#:select (mkdir-p))))))
pins/base-channels.sexp
+4 -4
View File
@@ -1,12 +1,12 @@
(list (channel
(name 'guix)
(url "https://git.teralink.net/tribes/guix-fork.git")
(branch "feature/substitute-read-timeout")
;; guix-fork feature/substitute-read-timeout
(branch "master")
;; Guix v1.5.0
(commit
"4574af27f27c7a5d2dc4d4823ef4518a392dc973")
"6f9c3cd1761f0a3f8b70223cb0e0f47e29582d90")
(introduction
(make-channel-introduction
"093f27dde01cdbda68f2ec4b81e5a34ae180aab9"
"6f9c3cd1761f0a3f8b70223cb0e0f47e29582d90"
(openpgp-fingerprint
"6688 9153 C51C 4613 A493 A525 2F0D FD14 EF99 DAC3")))))
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 "feature/substitute-read-timeout")
;; guix-fork feature/substitute-read-timeout
(commit
"4574af27f27c7a5d2dc4d4823ef4518a392dc973")
(introduction
(make-channel-introduction
"093f27dde01cdbda68f2ec4b81e5a34ae180aab9"
(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/build-kexec-image
-278
View File
@@ -1,278 +0,0 @@
#!/bin/sh
set -eu
usage() {
cat <<'EOF'
Usage: scripts/build-kexec-image [options]
Build a Guix kexec installer tarball from this guix-tribes checkout.
Options:
--channels=PATH Guix channels file for time-machine
--output=PATH Output tarball path, or - for stdout
--gzip-level=N gzip level for final tarball (default: 4)
-h, --help Show this help
EOF
}
script_dir=$(CDPATH= cd -- "$(dirname "$0")" && pwd)
root_dir=$(CDPATH= cd -- "$script_dir/.." && pwd)
channels=
output=
gzip_level="${NBDE_KEXEC_GZIP_LEVEL:-4}"
for arg in "$@"; do
case "$arg" in
--channels=*)
channels=${arg#*=}
;;
--output=*)
output=${arg#*=}
;;
--gzip-level=*)
gzip_level=${arg#*=}
;;
-h|--help)
usage
exit 0
;;
*)
echo "unknown argument: $arg" >&2
usage >&2
exit 2
;;
esac
done
[ -n "$channels" ] || {
echo "missing required --channels=PATH" >&2
usage >&2
exit 2
}
[ -n "$output" ] || {
echo "missing required --output=PATH" >&2
usage >&2
exit 2
}
load_guix_env() {
for profile in \
"$HOME/.config/guix/current/etc/profile" \
"$HOME/.guix-profile/etc/profile" \
/run/current-system/profile/etc/profile
do
[ -r "$profile" ] || continue
# shellcheck disable=SC1090
. "$profile"
done
}
require_tool() {
command -v "$1" >/dev/null 2>&1 || {
echo "$1 command not found" >&2
exit 1
}
}
require_file() {
path=$1
label=$2
[ -e "$path" ] || {
echo "$label not found: $path" >&2
exit 1
}
}
require_store_dir() {
path=$1
label=$2
case "$path" in
/gnu/store/*) ;;
*)
echo "$label did not produce a /gnu/store path: ${path:-<empty>}" >&2
exit 1
;;
esac
[ -d "$path" ] || {
echo "$label store path does not exist: $path" >&2
exit 1
}
}
log() {
echo "$*" >&2
}
load_guix_env
require_tool guix
require_tool guile
require_tool mksquashfs
require_tool cpio
require_file "$channels" "channels file"
require_file "$script_dir/kexec-run" "kexec runner"
require_file "$root_dir/examples/build-host-kexec-installer.scm" "system file"
tmp=$(mktemp -d /tmp/guix-kexec-image.XXXXXX)
system_build_stdout="$tmp/system-build.stdout"
static_kexec_stdout="$tmp/static-kexec.stdout"
closure_paths="$tmp/closure-paths"
cleanup() {
chmod -R u+w "$tmp" >/dev/null 2>&1 || true
rm -rf "$tmp"
}
trap cleanup EXIT INT TERM
log "building kexec installer system"
if ! guix time-machine -C "$channels" -- system build -L "$root_dir" \
"$root_dir/examples/build-host-kexec-installer.scm" >"$system_build_stdout"; then
[ ! -s "$system_build_stdout" ] || cat "$system_build_stdout" >&2
echo "failed to build kexec installer system" >&2
exit 1
fi
system=$(tail -n 1 "$system_build_stdout")
require_store_dir "$system" "kexec installer system"
require_file "$system/parameters" "kexec installer system parameters"
require_file "$system/boot" "kexec installer system boot directory"
log "building static kexec-tools"
if ! guix time-machine -C "$channels" -- build -e '(begin
(use-modules (gnu packages linux)
(guix build-system gnu))
(static-package kexec-tools))' >"$static_kexec_stdout"; then
[ ! -s "$static_kexec_stdout" ] || cat "$static_kexec_stdout" >&2
echo "failed to build static kexec-tools" >&2
exit 1
fi
static_kexec=$(tail -n 1 "$static_kexec_stdout")
require_store_dir "$static_kexec" "static kexec-tools"
require_file "$static_kexec/sbin/kexec" "static kexec binary"
guile -s /dev/stdin -- "$system" >"$tmp/metadata" <<'GUILE'
(use-modules (ice-9 match)
(srfi srfi-1)
(srfi srfi-13))
(define (field name fields)
(match (assoc name fields)
((_ value) value)
(_ (error "missing boot parameter field" name))))
(let* ((system (last (command-line)))
(sexp (call-with-input-file
(string-append system "/parameters")
read)))
(match sexp
(('boot-parameters fields ...)
(let* ((kernel (field 'kernel fields))
(initrd (field 'initrd fields))
(root (field 'root-device fields))
(args (field 'kernel-arguments fields))
(boot-link (string-append system "/boot"))
(boot-path (canonicalize-path boot-link))
(boot-args
(append
(cond
((equal? root "tmpfs")
'("rootfstype=tmpfs"))
((and (string? root) (not (string=? root "none")))
(list (string-append "root=" root)))
(else
'()))
(list (string-append "gnu.system=" system)
(string-append "gnu.load=" boot-path))
args)))
(display kernel)
(newline)
(display initrd)
(newline)
(display boot-path)
(newline)
(display (string-join boot-args " "))
(newline)))
(_
(error "unrecognized boot parameters file" sexp))))
GUILE
kernel=$(sed -n '1p' "$tmp/metadata")
initrd=$(sed -n '2p' "$tmp/metadata")
boot_path=$(sed -n '3p' "$tmp/metadata")
cmdline=$(sed -n '4p' "$tmp/metadata")
boot_refs=$(guix gc --references "$boot_path")
store_item_root() {
case "$1" in
/gnu/store/*)
printf '%s\n' "$1" | sed 's#^\(/gnu/store/[^/]*\).*#\1#'
;;
*)
echo "not a store item: $1" >&2
exit 1
;;
esac
}
initrd_store=$(store_item_root "$initrd")
parameters_store=$(store_item_root "$(readlink -f "$system/parameters")")
system_refs="$tmp/system-refs"
guix gc --references "$system" \
| while IFS= read -r ref; do
case "$ref" in
"$initrd_store"|"$parameters_store")
log "excluding already-copied boot artifact from embedded store: $ref"
;;
*)
printf '%s\n' "$ref"
;;
esac
done >"$system_refs"
mkdir -p "$tmp/kexec"
cp "$kernel" "$tmp/kexec/bzImage"
cp "$initrd" "$tmp/kexec/initrd"
chmod 644 "$tmp/kexec/initrd"
cp "$static_kexec/sbin/kexec" "$tmp/kexec/kexec-static"
chmod 755 "$tmp/kexec/kexec-static"
cp "$script_dir/kexec-run" "$tmp/kexec/run"
chmod 755 "$tmp/kexec/run"
printf '%s\n' "$cmdline" >"$tmp/kexec/cmdline"
{
printf '%s\n' "$system" "$boot_path"
printf '%s\n' $boot_refs
cat "$system_refs"
guix gc --requisites "$boot_path" $boot_refs $(cat "$system_refs")
} | sort -u >"$closure_paths"
squashfs_root="$tmp/squashfs-root"
mkdir -p "$squashfs_root"
while IFS= read -r path; do
[ -n "$path" ] || continue
cp -a "$path" "$squashfs_root/$(basename "$path")"
done <"$closure_paths"
log "packing Guix store closure into initrd"
mksquashfs "$squashfs_root" "$tmp/kexec/gnu-store.squashfs" \
-comp gzip -Xcompression-level 9 -no-xattrs -noappend >&2
squashfs_cpio="$tmp/squashfs-cpio"
mkdir -p "$squashfs_cpio"
cp "$tmp/kexec/gnu-store.squashfs" "$squashfs_cpio/gnu-store.squashfs"
( cd "$squashfs_cpio" && printf 'gnu-store.squashfs' | cpio -o -H newc | gzip -9 ) \
>> "$tmp/kexec/initrd"
rm "$tmp/kexec/gnu-store.squashfs"
log "writing kexec installer tarball"
case "$output" in
-)
GZIP="-$gzip_level" tar -C "$tmp" -czf - kexec
;;
*)
mkdir -p "$(dirname "$output")"
GZIP="-$gzip_level" tar -C "$tmp" -czf "$output" kexec
;;
esac
scripts/build-sender-runtime-pack
-70
View File
@@ -1,70 +0,0 @@
#!/bin/sh
set -eu
usage() {
cat <<'EOF'
Usage: scripts/build-sender-runtime-pack [options]
Build the external Tribes Sender runtime Guix pack from this checkout.
Options:
--guix=PATH Guix command to use (default: guix)
--output=PATH Copy resulting .tar.zst pack to PATH
-h, --help Show this help
EOF
}
script_dir=$(CDPATH= cd -- "$(dirname "$0")" && pwd)
root_dir=$(CDPATH= cd -- "$script_dir/.." && pwd)
guix_bin=${GUIX:-guix}
output=
for arg in "$@"; do
case "$arg" in
--guix=*)
guix_bin=${arg#*=}
;;
--output=*)
output=${arg#*=}
;;
-h|--help)
usage
exit 0
;;
*)
echo "unknown argument: $arg" >&2
usage >&2
exit 2
;;
esac
done
command -v "$guix_bin" >/dev/null 2>&1 || {
echo "guix command not found: $guix_bin" >&2
exit 1
}
pack_path=$("$guix_bin" pack \
-L "$root_dir" \
-f tarball \
-C zstd \
--save-provenance \
-S /opt/tribes-sender-runtime/bin=bin \
-S /opt/tribes-sender-runtime/sbin=sbin \
-S /opt/tribes-sender-runtime/share=share \
-m "$root_dir/manifests/packs/sender-runtime.scm" | tail -n 1)
case "$pack_path" in
/gnu/store/*) ;;
*)
echo "guix pack did not produce a /gnu/store path: ${pack_path:-<empty>}" >&2
exit 1
;;
esac
if [ -n "$output" ]; then
cp "$pack_path" "$output"
printf '%s\n' "$output"
else
printf '%s\n' "$pack_path"
fi
scripts/build-tribes-docker-image
-73
View File
@@ -1,73 +0,0 @@
#!/bin/sh
set -eu
usage() {
cat <<'EOF'
Usage: scripts/build-tribes-docker-image [options]
Build the pinned debug Tribes Docker image from this guix-tribes checkout.
Options:
--guix=PATH Guix command to use (default: guix)
--image-tag=TAG Docker image tag (default: tribes-guix-debug:latest)
--output=PATH Copy resulting image tarball to PATH
-h, --help Show this help
EOF
}
script_dir=$(CDPATH= cd -- "$(dirname "$0")" && pwd)
root_dir=$(CDPATH= cd -- "$script_dir/.." && pwd)
guix_bin=${GUIX:-guix}
image_tag=tribes-guix-debug:latest
output=
for arg in "$@"; do
case "$arg" in
--guix=*)
guix_bin=${arg#*=}
;;
--image-tag=*)
image_tag=${arg#*=}
;;
--output=*)
output=${arg#*=}
;;
-h|--help)
usage
exit 0
;;
*)
echo "unknown argument: $arg" >&2
usage >&2
exit 2
;;
esac
done
command -v "$guix_bin" >/dev/null 2>&1 || {
echo "guix command not found: $guix_bin" >&2
exit 1
}
image_path=$("$guix_bin" pack \
-L "$root_dir" \
-f docker \
--image-tag="$image_tag" \
-S /bin=bin \
--entry-point=/bin/tribes \
-e '(@ (tribes packages docker) tribes-debug-docker-package)' | tail -n 1)
case "$image_path" in
/gnu/store/*) ;;
*)
echo "guix pack did not produce a /gnu/store path: ${image_path:-<empty>}" >&2
exit 1
;;
esac
if [ -n "$output" ]; then
cp "$image_path" "$output"
printf '%s\n' "$output"
else
printf '%s\n' "$image_path"
fi
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/kexec-run
-67
View File
@@ -1,67 +0,0 @@
#!/bin/sh
set -eu
script_dir=$(CDPATH= cd -- "$(dirname "$0")" && pwd)
kernel="$script_dir/bzImage"
initrd="$script_dir/initrd"
cmdline=$(tr '\n' ' ' < "$script_dir/cmdline" | sed 's/[[:space:]]\+/ /g; s/^ //; s/ $//')
extra_args="${KEXEC_KERNEL_APPEND:-}"
extra_initrd="${KEXEC_EXTRA_INITRD:-}"
tmp_initrd=
execute_delay="${KEXEC_EXEC_DELAY:-3}"
cleanup() {
[ -n "${tmp_initrd:-}" ] && rm -f "$tmp_initrd"
}
trap cleanup EXIT INT TERM
[ -r "$kernel" ] || {
echo "missing kernel image: $kernel" >&2
exit 1
}
[ -r "$initrd" ] || {
echo "missing initrd image: $initrd" >&2
exit 1
}
if [ -n "$extra_initrd" ]; then
[ -r "$extra_initrd" ] || {
echo "extra initrd is not readable: $extra_initrd" >&2
exit 1
}
tmp_initrd=$(mktemp "${TMPDIR:-/tmp}/guix-kexec-initrd.XXXXXX")
cat "$initrd" "$extra_initrd" >"$tmp_initrd"
initrd="$tmp_initrd"
fi
if [ -n "$extra_args" ]; then
cmdline="$cmdline $extra_args"
fi
if [ -n "${KEXEC_BIN:-}" ]; then
kexec_bin="$KEXEC_BIN"
elif [ -x "$script_dir/kexec-static" ]; then
kexec_bin="$script_dir/kexec-static"
elif command -v kexec >/dev/null 2>&1; then
kexec_bin=$(command -v kexec)
else
echo "kexec binary not found and no bundled fallback present" >&2
exit 1
fi
kexec_load_flags=
if printf '%s\n' "6.1" "$(uname -r)" | sort -c -V 2>/dev/null; then
kexec_load_flags="--kexec-syscall-auto"
fi
echo "kexec: loading $kernel"
echo "kexec: initrd=$initrd ($(wc -c < "$initrd") bytes)"
"$kexec_bin" --load "$kernel" $kexec_load_flags --initrd="$initrd" --command-line="$cmdline" --no-checks
echo "machine will boot into guix in ${execute_delay}s"
if [ -e /dev/kmsg ]; then
exec >/dev/kmsg 2>&1
else
exec >/dev/null 2>&1
fi
nohup sh -c "sleep '$execute_delay' && exec '$kexec_bin' -e" &
scripts/update-base-channels-pin
+8 -197
View File
@@ -3,205 +3,16 @@ set -eu
script_dir=$(CDPATH= cd -- "$(dirname "$0")" && pwd)
root_dir=$(CDPATH= cd -- "$script_dir/.." && pwd)
base_output="${NBDE_BASE_CHANNELS_OUTPUT:-$root_dir/pins/base-channels.sexp}"
legion_output="${NBDE_LEGION_CHANNELS_OUTPUT:-$root_dir/pins/legion-channels.sexp}"
output="${1:-$root_dir/pins/base-channels.sexp}"
channels_source_host="${NBDE_GUIX_CHANNELS_SOURCE_HOST:-pguix}"
fork_url="https://git.teralink.net/tribes/guix-fork.git"
fork_branch="feature/substitute-read-timeout"
fork_introduction_commit="093f27dde01cdbda68f2ec4b81e5a34ae180aab9"
fork_introduction_signer="6688 9153 C51C 4613 A493 A525 2F0D FD14 EF99 DAC3"
fork_checkout="$root_dir/../guix-fork"
fork_comment="guix-fork feature/substitute-read-timeout"
mkdir -p "$(dirname "$output")"
official_url="https://git.teralink.net/tribes/guix.git"
official_branch="master"
official_introduction_commit="9edb3f66fd807b096b48283debdcddccfea34bad"
official_introduction_signer="BBB0 2DDF 2CEA F6A8 0D1D E643 A2A0 6DF2 A33A 54FA"
official_checkout="$root_dir/../guix"
official_comment="guix master"
usage() {
cat <<EOF
Usage: $(basename "$0") [--fork|--official] [--commit COMMIT]
Refreshes $base_output and syncs the Guix entry in $legion_output.
Defaults to the current channel kind from pins/base-channels.sexp and uses the
matching sibling checkout HEAD (../guix-fork or ../guix) when available.
EOF
}
is_full_commit() {
printf '%s\n' "$1" | grep -Eq '^[0-9a-f]{40}$'
}
current_channel_kind() {
current_url=$(perl -0ne 'if (/\(name \x27guix\)[\s\S]*?\(url "([^"]+)"\)/s) { print $1; exit 0 } exit 1' "$base_output")
case "$current_url" in
"$fork_url")
printf '%s\n' fork
;;
"$official_url")
printf '%s\n' official
;;
*)
echo "Unsupported Guix channel URL in $base_output: $current_url" >&2
exit 1
;;
esac
}
checkout_head() {
checkout=$1
if [ -d "$checkout/.git" ]; then
git -C "$checkout" rev-parse HEAD
return 0
fi
return 1
}
remote_branch_head() {
git ls-remote "$1" "refs/heads/$2" | awk 'NR == 1 { print $1 }'
}
channel_kind=
commit_override=
while [ "$#" -gt 0 ]; do
case "$1" in
--fork)
channel_kind=fork
;;
--official)
channel_kind=official
;;
--commit)
shift
[ "$#" -gt 0 ] || {
echo "Missing value for --commit" >&2
usage >&2
exit 2
}
commit_override=$1
;;
-h|--help)
usage
exit 0
;;
*)
if [ -z "$commit_override" ]; then
commit_override=$1
else
echo "Unexpected argument: $1" >&2
usage >&2
exit 2
fi
;;
esac
shift
done
[ -n "$channel_kind" ] || channel_kind=$(current_channel_kind)
case "$channel_kind" in
fork)
channel_url=$fork_url
channel_branch=$fork_branch
channel_introduction_commit=$fork_introduction_commit
channel_introduction_signer=$fork_introduction_signer
channel_checkout=$fork_checkout
channel_comment=$fork_comment
;;
official)
channel_url=$official_url
channel_branch=$official_branch
channel_introduction_commit=$official_introduction_commit
channel_introduction_signer=$official_introduction_signer
channel_checkout=$official_checkout
channel_comment=$official_comment
;;
*)
echo "Unsupported channel kind: $channel_kind" >&2
exit 1
;;
esac
commit_source=
if [ -n "$commit_override" ]; then
if [ -d "$channel_checkout/.git" ]; then
commit=$(git -C "$channel_checkout" rev-parse "$commit_override^{commit}" 2>/dev/null || true)
else
commit=
fi
[ -n "$commit" ] || commit=$commit_override
commit_source="override"
if command -v guix >/dev/null 2>&1; then
guix describe -f channels >"$output"
else
commit=$(checkout_head "$channel_checkout" || true)
if [ -n "$commit" ]; then
commit_source=$channel_checkout
else
commit=$(remote_branch_head "$channel_url" "$channel_branch")
commit_source="$channel_url#$channel_branch"
fi
ssh -o BatchMode=yes -o ConnectTimeout=10 \
"$channels_source_host" 'guix describe -f channels' >"$output"
fi
is_full_commit "$commit" || {
echo "Expected a full 40-character commit, got: $commit" >&2
exit 1
}
mkdir -p "$(dirname "$base_output")" "$(dirname "$legion_output")"
cat >"$base_output" <<EOF
(list (channel
(name 'guix)
(url "$channel_url")
(branch "$channel_branch")
;; $channel_comment
(commit
"$commit")
(introduction
(make-channel-introduction
"$channel_introduction_commit"
(openpgp-fingerprint
"$channel_introduction_signer")))))
EOF
new_guix_block=$(cat <<EOF
(channel
(name 'guix)
(url "$channel_url")
(branch "$channel_branch")
;; $channel_comment
(commit
"$commit")
(introduction
(make-channel-introduction
"$channel_introduction_commit"
(openpgp-fingerprint
"$channel_introduction_signer"))))
EOF
)
tmp_output=$(mktemp "${TMPDIR:-/tmp}/update-base-channels-pin.XXXXXX")
trap 'rm -f "$tmp_output"' EXIT HUP INT TERM
NEW_GUIX_BLOCK=$new_guix_block perl -0pe '
BEGIN { $changed = 0 }
$changed = s{\A\(list\s*\n \(channel\b[\s\S]*?\)\)\n(?= \(channel\b)}{"(list\n$ENV{NEW_GUIX_BLOCK}\n"}se;
END { exit($changed ? 0 : 1) }
' "$legion_output" >"$tmp_output" || {
echo "Failed to sync the Guix entry in $legion_output" >&2
exit 1
}
mv "$tmp_output" "$legion_output"
rm -f "$tmp_output"
trap - EXIT HUP INT TERM
printf 'Updated %s\n' "$base_output"
printf 'Synced %s\n' "$legion_output"
printf 'Channel: %s\n' "$channel_kind"
printf 'Commit: %s\n' "$commit"
printf 'Source: %s\n' "$commit_source"
printf '\nRun Legion pin refresh next:\n'
printf ' cd %s && npm run generate:guix-base-channel\n' "$root_dir/../legion_kk"
printf '%s\n' "$output"
scripts/update-plugin-pin
-513
View File
@@ -1,513 +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 JSON::PP qw(decode_json encode_json);
sub usage {
print <<'EOF';
Usage: update-plugin-pin [options] plugin [rev]
Pin a Tribes external plugin and refresh fixed-output hashes.
PLUGIN is the plugin slug. REV defaults to "master" resolved from the
plugin checkout. The plugin manifest.json is the source of truth for plugin
id, slug, 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
--build-host HOST SSH host used for Guix builds and hashing
-h, --help Show this help
Hashing and Guix builds run with local `guix` unless --build-host is provided.
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 ($fh, $path) = tempfile('command-output.XXXXXX', TMPDIR => 1);
my $pid = fork();
defined $pid or fail("Failed to fork for @cmd: $!");
if ($pid == 0) {
open STDOUT, '>&', $fh or die "Failed to redirect stdout: $!\n";
open STDERR, '>&', $fh or die "Failed to redirect stderr: $!\n";
exec @cmd or die "Failed to exec $cmd[0]: $!\n";
}
close $fh or fail("Failed to close $path: $!");
waitpid($pid, 0);
my $wait_status = $?;
my $status = $wait_status == -1 ? 255 : ($wait_status & 127 ? 128 + ($wait_status & 127) : $wait_status >> 8);
open my $out, '<', $path or fail("Failed to read $path: $!");
local $/;
my $output = <$out> // '';
close $out or fail("Failed to close $path: $!");
unlink $path;
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 replace_all {
my ($text_ref, $pattern, $replacement, $label) = @_;
my $count = ($$text_ref =~ s/$pattern/$replacement/sg);
$count >= 1 or fail("failed to update $label");
}
my $local_tmp = '';
my $remote_tmp = '';
my @argv = @ARGV;
my %opts;
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},
'build-host=s' => \$opts{build_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 tar perl);
my $use_remote = defined($opts{build_host}) && $opts{build_host} ne '' ? 1 : 0;
require_tool('guix') unless $use_remote;
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{build_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(id slug 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_id = $manifest->{id};
my $plugin_slug = $manifest->{slug};
my $version = $manifest->{version};
my $provides_joined = join("\037", @{ $manifest->{provides} });
my $requires_joined = join("\037", @{ $manifest->{requires} });
$plugin_slug eq $plugin or fail("Plugin manifest slug mismatch: expected $plugin, got $plugin_slug");
my ($plugin_source_for_scheme, $tribes_source_for_scheme, $guix_load_path);
my $source_hash;
sub setup_remote {
require_tool($_) for qw(rsync ssh);
if ($remote_tmp eq '') {
print STDERR "Using build host $opts{build_host}.\n";
($status, my $remote_tmp_output) = run_capture('ssh', $opts{build_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{build_host}:$remote_tmp/guix-tribes/");
run_checked('rsync', '-az', '--delete', "$plugin_source_dir/", "$opts{build_host}:$remote_tmp/plugin-source/");
run_checked('rsync', '-az', '--delete', "$tribes_source_dir/", "$opts{build_host}:$remote_tmp/tribes-source/");
}
$plugin_source_for_scheme = "$remote_tmp/plugin-source";
$tribes_source_for_scheme = "$remote_tmp/tribes-source";
$guix_load_path = "$remote_tmp/guix-tribes";
($status, my $source_hash_output) =
run_capture('ssh', $opts{build_host}, "guix hash -rx '$plugin_source_for_scheme'");
$status == 0 or fail(trim($source_hash_output));
$source_hash = trim($source_hash_output);
$source_hash =~ tr/\r//d;
}
if ($use_remote) {
setup_remote();
} else {
$plugin_source_for_scheme = $plugin_source_dir;
$tribes_source_for_scheme = $tribes_source_dir;
$guix_load_path = $guix_repo;
($status, my $source_hash_output) = run_capture('guix', 'hash', '-rx', $plugin_source_dir);
$status == 0 or fail(trim($source_hash_output));
$source_hash = trim($source_hash_output);
$source_hash =~ tr/\r//d;
}
sub 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: $!");
if ($use_remote) {
run_checked('rsync', '-az', $local_path, "$opts{build_host}:$remote_tmp/$name.scm");
my ($exit, $output) =
run_capture('ssh', $opts{build_host}, "guix build -L '$guix_load_path' -f '$remote_tmp/$name.scm' --no-grafts 2>&1");
return $output;
}
my ($exit, $output) =
run_capture('guix', 'build', '-L', $guix_load_path, '-f', $local_path, '--no-grafts');
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;
}
sub build_hash {
my ($label, $build) = @_;
my $output = $build->();
my $hash = eval { extract_hash($output) };
if ($@) {
my $hint = $use_remote
? "Build host Guix did not complete the hash refresh."
: "Local Guix did not complete the hash refresh. To run this step on a build host, rerun with --build-host HOST.";
fail("Failed to extract $label hash.\n$hint\n$output");
}
return $hash;
}
my $dummy_hash = '0' x 52;
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");
my $package_body = $text;
if ($text =~ /\(define\* \(\Q$symbol_base\E-package-from-source\b(.*?)(?:\n\(define \Q$symbol_base\E-package\b)/s) {
$package_body = $1;
}
sub package_reuses_host_libs {
my ($body) = @_;
return 1 if $body =~ /#:reuse-host-libs\?\s+#t\b/;
return 0 if $body =~ /#:reuse-host-libs\?\s+#f\b/;
if ($body =~ /#:reuse-host-libs\?\s+reuse-host-libs\?/) {
return 1 if $body =~ /\(reuse-host-libs\?\s+#t\)/;
return 0 if $body =~ /\(reuse-host-libs\?\s+#f\)/;
}
return 0;
}
sub package_includes_mix_deps {
my ($body, $reuse_host_libs) = @_;
return 1 if $body =~ /#:include-mix-deps\?\s+#t\b/;
return 0 if $body =~ /#:include-mix-deps\?\s+#f\b/;
if ($body =~ /#:include-mix-deps\?\s+include-mix-deps\?/) {
return 1 if $body =~ /\(include-mix-deps\?\s+#t\)/;
return 0 if $body =~ /\(include-mix-deps\?\s+#f\)/;
}
return $reuse_host_libs ? 0 : 1;
}
my $reuse_host_libs = package_reuses_host_libs($package_body);
my $include_mix_deps = package_includes_mix_deps($package_body, $reuse_host_libs);
sub host_setup_gexp {
return <<"EOF";
#~(begin
(let ((host-root (string-append work "/tribes")))
(when (file-exists? host-root)
(delete-file-recursively host-root))
(copy-recursively #+(local-file "$tribes_source_for_scheme" #:recursive? #t)
host-root
#:follow-symlinks? #t)
(invoke "chmod" "-R" "u+w" host-root)))
EOF
}
my $source_setup_gexp = $reuse_host_libs ? "#~(begin)" : host_setup_gexp();
sub mix_deps_output {
return run_scheme(
'mix-deps',
<<"EOF"
(use-modules (guix gexp) (tribes packages mix))
(fetch-mix-deps
(local-file "$plugin_source_for_scheme" #:recursive? #t)
#:name "$plugin_package_name-mix-deps"
#:version "$version"
#:sha256 "$dummy_hash"
#:setup-gexp $source_setup_gexp)
EOF
);
}
sub npm_deps_output {
return run_scheme(
'npm-deps',
<<"EOF"
(use-modules (guix gexp) (tribes packages mix))
(fetch-npm-deps
(local-file "$plugin_source_for_scheme" #:recursive? #t)
#:name "$plugin_package_name-npm-deps"
#:version "$version"
#:sha256 "$dummy_hash"
#:assets-dir "assets"
#:setup-gexp $source_setup_gexp)
EOF
);
}
$text =~ /\(define %\Q$symbol_base\E-mix-deps-sha256\s+"([^"]+)"\)/
or fail("failed to locate %$symbol_base-mix-deps-sha256 in $plugin_file");
my $mix_hash = $1;
if ($include_mix_deps) {
$mix_hash = build_hash('mix deps', \&mix_deps_output);
}
my $npm_hash = '';
if (-f File::Spec->catfile($plugin_source_dir, 'assets', 'package-lock.json')) {
$npm_hash = build_hash('npm deps', \&npm_deps_output);
}
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",
);
replace_all(
\$text,
qr/#:provides\s+'\([^)]*\)/,
"#:provides '" . scheme_string_list(@{ $manifest->{provides} }),
'plugin provides',
);
replace_all(
\$text,
qr/#:requires\s+'\([^)]*\)/,
"#:requires '" . scheme_string_list(@{ $manifest->{requires} }),
'plugin requires',
);
write_file($plugin_file, $text);
print "Updated $plugin_file\n";
print "plugin: $plugin\n";
print "plugin id: $plugin_id\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";
scripts/update-tribes-and-plugin-pins
-113
View File
@@ -1,113 +0,0 @@
#!/bin/sh
set -eu
# External plugin pins to refresh. Each name maps to ../tribes-plugin-$name
# and tribes/plugins/$name.scm unless update-plugin-pin is called with
# different defaults in the future.
plugins="sender aether supertest kobold trust"
usage() {
cat <<'EOF'
Usage: update-tribes-and-plugin-pins [options]
Refresh the Tribes pin and all plugin pins listed in this script by calling
scripts/update-tribes-pin and scripts/update-plugin-pin.
Options:
--commit Commit the affected pin files after updating
--tribes-repo PATH Local Tribes git checkout
--guix-repo PATH Local guix-tribes checkout
--build-host HOST SSH host used by the update scripts for Guix builds and hashing
-h, --help Show this help
EOF
}
script_dir=$(CDPATH= cd -- "$(dirname -- "$0")" && pwd)
default_guix_repo=$(CDPATH= cd -- "$script_dir/.." && pwd)
default_tribes_repo=$(CDPATH= cd -- "$default_guix_repo/../tribes" && pwd)
guix_repo=$default_guix_repo
tribes_repo=$default_tribes_repo
build_host=
commit_after=false
while [ "$#" -gt 0 ]; do
case "$1" in
--commit)
commit_after=true
shift
;;
--tribes-repo)
tribes_repo=$2
shift 2
;;
--guix-repo)
guix_repo=$2
shift 2
;;
--build-host)
build_host=$2
shift 2
;;
-h|--help)
usage
exit 0
;;
*)
printf 'Unknown option: %s\n' "$1" >&2
usage >&2
exit 1
;;
esac
done
update_tribes_pin=$guix_repo/scripts/update-tribes-pin
update_plugin_pin=$guix_repo/scripts/update-plugin-pin
if [ ! -x "$update_tribes_pin" ]; then
printf 'update-tribes-pin not found or not executable: %s\n' "$update_tribes_pin" >&2
exit 1
fi
if [ ! -x "$update_plugin_pin" ]; then
printf 'update-plugin-pin not found or not executable: %s\n' "$update_plugin_pin" >&2
exit 1
fi
build_host_args=
if [ -n "$build_host" ]; then
build_host_args="--build-host $build_host"
fi
# shellcheck disable=SC2086
"$update_tribes_pin" \
--guix-repo "$guix_repo" \
--tribes-repo "$tribes_repo" \
$build_host_args
for plugin in $plugins; do
# shellcheck disable=SC2086
"$update_plugin_pin" \
--guix-repo "$guix_repo" \
--tribes-repo "$tribes_repo" \
$build_host_args \
"$plugin"
done
if [ "$commit_after" = true ]; then
git -C "$guix_repo" add -- \
tribes/packages/source.scm
for plugin in $plugins; do
git -C "$guix_repo" add -- "tribes/plugins/$plugin.scm"
done
if git -C "$guix_repo" diff --cached --quiet; then
printf 'No pin changes to commit.\n'
else
git -C "$guix_repo" commit \
-m "chore: Bump Tribes and plugin pins" \
-m "Refresh the Tribes source pin and the external plugin pins listed in scripts/update-tribes-and-plugin-pins."
fi
fi
scripts/update-tribes-pin
+36 -86
View File
@@ -8,14 +8,13 @@ Usage: update-tribes-pin [options] [rev]
Pin guix-tribes to a Tribes commit and refresh all fixed-output hashes.
By default, REV is "master" resolved from the local Tribes checkout. Hashing and
Guix builds run with local `guix` unless --build-host is provided.
By default, REV is "master" resolved from the local Tribes checkout.
Options:
--tribes-repo PATH Local Tribes git checkout
--guix-repo PATH Local guix-tribes checkout
--build-host HOST SSH host used for Guix builds and hashing
-h, --help Show this help
--tribes-repo PATH Local Tribes git checkout
--guix-repo PATH Local guix-tribes checkout
--pguix-host HOST SSH host used for Guix builds and hashing
-h, --help Show this help
EOF
}
@@ -25,7 +24,7 @@ default_tribes_repo=$(CDPATH= cd -- "$default_guix_repo/../tribes" && pwd)
tribes_repo=$default_tribes_repo
guix_repo=$default_guix_repo
build_host=
pguix_host=pguix
rev=master
while [ "$#" -gt 0 ]; do
@@ -38,8 +37,8 @@ while [ "$#" -gt 0 ]; do
guix_repo=$2
shift 2
;;
--build-host)
build_host=$2
--pguix-host)
pguix_host=$2
shift 2
;;
-h|--help)
@@ -89,17 +88,12 @@ require_tool() {
require_tool env
require_tool git
require_tool rsync
require_tool ssh
require_tool tar
require_tool perl
require_tool mktemp
if [ -n "$build_host" ]; then
use_remote=true
else
use_remote=false
require_tool guix
fi
commit=$(git -C "$tribes_repo" rev-parse "$rev^{commit}")
version=$(env LC_ALL=C perl -0ne 'print $1 if /\(git-version "([^"]+)"/' "$source_file")
@@ -113,7 +107,7 @@ remote_tmp=
cleanup() {
if [ -n "${remote_tmp:-}" ]; then
ssh "$build_host" "rm -rf '$remote_tmp'" >/dev/null 2>&1 || true
ssh "$pguix_host" "rm -rf '$remote_tmp'" >/dev/null 2>&1 || true
fi
rm -rf "$local_tmp"
}
@@ -123,49 +117,22 @@ trap cleanup EXIT INT TERM
mkdir -p "$local_tmp/tribes-source"
git -C "$tribes_repo" archive "$commit" | tar -x -C "$local_tmp/tribes-source"
setup_remote() {
require_tool rsync
require_tool ssh
remote_tmp=$(ssh "$pguix_host" 'mktemp -d /tmp/tribes-pin.XXXXXX')
if [ -z "${remote_tmp:-}" ]; then
printf 'Using build host %s.\n' "$build_host" >&2
remote_tmp=$(ssh "$build_host" 'mktemp -d /tmp/tribes-pin.XXXXXX')
rsync -az --delete --exclude .git "$guix_repo/" "$pguix_host:$remote_tmp/guix-tribes/"
rsync -az --delete "$local_tmp/tribes-source/" "$pguix_host:$remote_tmp/tribes-source/"
rsync -az --delete --exclude .git "$guix_repo/" "$build_host:$remote_tmp/guix-tribes/"
rsync -az --delete "$local_tmp/tribes-source/" "$build_host:$remote_tmp/tribes-source/"
fi
source_hash=$(ssh "$pguix_host" "guix hash -rx '$remote_tmp/tribes-source'" | tr -d '\r')
source_root=$remote_tmp/tribes-source
guix_load_path=$remote_tmp/guix-tribes
source_hash=$(ssh "$build_host" "guix hash -rx '$source_root'" | tr -d '\r')
}
if [ "$use_remote" = true ]; then
setup_remote
else
source_root=$local_tmp/tribes-source
guix_load_path=$guix_repo
source_hash=$(guix hash -rx "$source_root" | tr -d '\r')
fi
run_scheme() {
remote_run_scheme() {
name=$1
body=$2
if [ "$use_remote" = true ]; then
ssh "$build_host" "cat > '$remote_tmp/$name.scm' <<'EOF'
ssh "$pguix_host" "cat > '$remote_tmp/$name.scm' <<'EOF'
$body
EOF"
ssh "$build_host" "guix build -L '$guix_load_path' -f '$remote_tmp/$name.scm' --no-grafts 2>&1" || true
else
scheme_file=$local_tmp/$name.scm
cat > "$scheme_file" <<EOF
$body
EOF
guix build -L "$guix_load_path" -f "$scheme_file" --no-grafts 2>&1 || true
fi
ssh "$pguix_host" "guix build -L '$remote_tmp/guix-tribes' -f '$remote_tmp/$name.scm' --no-grafts 2>&1" || true
}
extract_hash() {
@@ -189,64 +156,47 @@ extract_hash() {
dummy_hash=0000000000000000000000000000000000000000000000000000
raw_mix_deps_output() {
run_scheme raw-mix-deps "(use-modules (guix gexp) (tribes packages source))
raw_output=$(remote_run_scheme raw-mix-deps "(use-modules (guix gexp) (tribes packages source))
(fetch-mix-deps
(local-file \"$source_root\" #:recursive? #t)
(local-file \"$remote_tmp/tribes-source\" #:recursive? #t)
#:name \"tribes-mix-deps-raw\"
#:version \"$version\"
#:sha256 \"$dummy_hash\")"
#:sha256 \"$dummy_hash\")")
raw_mix_hash=$(printf '%s\n' "$raw_output" | extract_hash) || {
printf 'Failed to extract raw mix deps hash.\n%s\n' "$raw_output" >&2
exit 1
}
mix_deps_output() {
run_scheme mix-deps "(use-modules (guix gexp) (tribes packages source))
mix_output=$(remote_run_scheme mix-deps "(use-modules (guix gexp) (tribes packages source))
(tribes-mix-deps
(local-file \"$source_root\" #:recursive? #t)
(local-file \"$remote_tmp/tribes-source\" #:recursive? #t)
#:name \"tribes-mix-deps\"
#:version \"$version\"
#:raw-sha256 \"$raw_mix_hash\"
#:sha256 \"$dummy_hash\")"
#:sha256 \"$dummy_hash\")")
mix_hash=$(printf '%s\n' "$mix_output" | extract_hash) || {
printf 'Failed to extract prepared mix deps hash.\n%s\n' "$mix_output" >&2
exit 1
}
npm_deps_output() {
run_scheme npm-deps "(use-modules (guix gexp) (tribes packages source))
npm_output=$(remote_run_scheme npm-deps "(use-modules (guix gexp) (tribes packages source))
(fetch-npm-deps
(local-file \"$source_root\" #:recursive? #t)
(local-file \"$remote_tmp/tribes-source\" #:recursive? #t)
#:mix-fod-deps
(tribes-mix-deps
(local-file \"$source_root\" #:recursive? #t)
(local-file \"$remote_tmp/tribes-source\" #:recursive? #t)
#:name \"tribes-mix-deps\"
#:version \"$version\"
#:raw-sha256 \"$raw_mix_hash\"
#:sha256 \"$mix_hash\")
#:name \"tribes-npm-deps\"
#:version \"$version\"
#:sha256 \"$dummy_hash\")"
}
hash_failure_hint() {
label=$1
output=$2
printf 'Failed to extract %s hash.\n' "$label" >&2
if [ "$use_remote" = false ]; then
printf 'Local Guix did not complete the hash refresh. To run this step on a build host, rerun with --build-host HOST.\n' >&2
else
printf 'Build host Guix did not complete the hash refresh.\n' >&2
fi
printf '%s\n' "$output" >&2
#:sha256 \"$dummy_hash\")")
npm_hash=$(printf '%s\n' "$npm_output" | extract_hash) || {
printf 'Failed to extract npm deps hash.\n%s\n' "$npm_output" >&2
exit 1
}
raw_output=$(raw_mix_deps_output)
raw_mix_hash=$(printf '%s\n' "$raw_output" | extract_hash) || hash_failure_hint 'raw mix deps' "$raw_output"
mix_output=$(mix_deps_output)
mix_hash=$(printf '%s\n' "$mix_output" | extract_hash) || hash_failure_hint 'prepared mix deps' "$mix_output"
npm_output=$(npm_deps_output)
npm_hash=$(printf '%s\n' "$npm_output" | extract_hash) || hash_failure_hint 'npm deps' "$npm_output"
COMMIT=$commit \
SOURCE_HASH=$source_hash \
RAW_MIX_HASH=$raw_mix_hash \
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-----
supertest-dev-B19D4784.key
+11
View File
@@ -0,0 +1,11 @@
-----BEGIN PGP PUBLIC KEY BLOCK-----
mDMEafMY7xYJKwYBBAHaRw8BAQdAX7Cs0UPcvEpHOwmTDkjNBfeH6/FH6sqKZbRi
sd3oBCy0U1RyaWJlcyBTdXBlcnRlc3QgRGV2IChBSSBsb2NhbCBkZXZlbG9wbWVu
dCBrZXkpIDx0cmliZXMtc3VwZXJ0ZXN0LWRldkB0ZXJhbGluay5uZXQ+iJYEExYK
AD4WIQTym6baluXsKf3e2ZSPT3WzsZ1HhAUCafMY7wIbAwUJAeEzgAULCQgHAgYV
CgkICwIEFgIDAQIeAQIXgAAKCRCPT3WzsZ1HhMp8AP4gGrPkBoGLKMyubISESFpH
fnqYUGDGucIoLRvtbl+ULQD/SlC9u/Ek9WSYvsskd0jD09lc2TxBnubl8yRi3bTM
sA8=
=JA7U
-----END PGP PUBLIC KEY BLOCK-----
tests/nbde-system-boot-store.scm
-31
View File
@@ -1,31 +0,0 @@
(define-module (tests nbde-system-boot-store)
#:use-module (srfi srfi-64)
#:use-module (tests support)
#:use-module (nbde system boot-store)
#:export (run-tests))
(define (fresh-file name)
(let ((path (string-append "/tmp/" name "-" (number->string (getpid)))))
(when (file-exists? path)
(delete-file path))
path))
(define (run-tests)
(test-begin "nbde-system-boot-store")
(let ((grub-cfg (fresh-file "boot-store-grub.cfg")))
(call-with-output-file grub-cfg
(lambda (port)
(display "linux /gnu/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-linux/bzImage root=x\n" port)
(display "initrd /gnu/store/bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb-raw-initrd/initrd.cpio.gz, /gnu/store/cccccccccccccccccccccccccccccccc-extra)\n" port)
(display "old /gnu/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-linux/bzImage\n" port)))
(test-equal "extracts unique grub store references"
'("/gnu/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-linux/bzImage"
"/gnu/store/bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb-raw-initrd/initrd.cpio.gz"
"/gnu/store/cccccccccccccccccccccccccccccccc-extra")
(grub-config-store-references grub-cfg))
(delete-file grub-cfg))
(test-end "nbde-system-boot-store"))
(run-tests-when-script "tests/nbde-system-boot-store.scm" run-tests)
tests/support.scm
-16
View File
@@ -1,16 +0,0 @@
(define-module (tests support)
#:use-module (ice-9 match)
#:use-module (srfi srfi-13)
#:export (run-tests-when-script))
(define (script-invocation? argv file-name)
(match argv
((program . _)
(and (string? program)
(or (string=? program file-name)
(string-suffix? (string-append "/" file-name) program))))
(_ #f)))
(define (run-tests-when-script file-name thunk)
(when (script-invocation? (command-line) file-name)
(thunk)))
tests/tribes-ci-substitutes.scm
-78
View File
@@ -1,78 +0,0 @@
(define-module (tests tribes-ci-substitutes)
#:use-module (guix gexp)
#:use-module (gnu services)
#:use-module (gnu system)
#:use-module (guix packages)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-64)
#:use-module (tests support)
#:use-module (tribes ci substitutes)
#:use-module (tribes packages kernel)
#:use-module (tribes packages plugins)
#:use-module (tribes services tribes)
#:export (run-tests))
(define (target-names)
(map car %substitute-operating-system-targets))
(define (target-plugin-names os)
(let ((service (find (lambda (service)
(eq? (service-kind service) tribes-service-type))
(operating-system-user-services os))))
(map tribes-external-plugin-name
(tribes-configuration-plugins (service-value service)))))
(define (run-tests)
(test-begin "tribes-ci-substitutes")
(test-equal "substitute OS target names are stable"
'(phase1 base-edge aether-edge kobold-edge sender-edge supertest-edge)
(target-names))
(test-assert "all substitute targets are operating systems"
(every operating-system?
(map cdr %substitute-operating-system-targets)))
(test-assert "substitute targets use the Tribes kernel"
(every (lambda (os)
(string=? (package-name (operating-system-kernel os))
(package-name tribes-linux)))
(map cdr %substitute-operating-system-targets)))
(test-assert "NBDE systems include common provider initrd NIC modules"
(every (lambda (module)
(member module
(operating-system-initrd-modules base-edge-operating-system)))
'("bnxt_en" "ena" "e1000e" "i40e" "ice" "igb" "igc" "ixgbe"
"mlx4_core" "mlx4_en" "mlx5_core" "r8169" "tg3")))
(test-assert "bootloader configuration targets are file-like"
(every file-like?
(list bios-bootloader-configuration
efi-bootloader-configuration
bios-bootloader-configuration-installer
efi-bootloader-configuration-installer)))
(test-equal "kobold target has expected host name"
"tribes-ci-kobold-edge"
(operating-system-host-name kobold-edge-operating-system))
(test-equal "kobold target includes trust provider"
'("trust" "kobold")
(target-plugin-names kobold-edge-operating-system))
(test-equal "sender target has expected host name"
"tribes-ci-sender-edge"
(operating-system-host-name sender-edge-operating-system))
(test-equal "aether target has expected host name"
"tribes-ci-aether-edge"
(operating-system-host-name aether-edge-operating-system))
(test-equal "supertest target has expected host name"
"tribes-ci-supertest-edge"
(operating-system-host-name supertest-edge-operating-system))
(test-end "tribes-ci-substitutes"))
(run-tests-when-script "tests/tribes-ci-substitutes.scm" run-tests)
tests/tribes-config-system-facts.scm
-32
View File
@@ -1,32 +0,0 @@
(define-module (tests tribes-config-system-facts)
#:use-module (srfi srfi-64)
#:use-module (tests support)
#:use-module (tribes config system-facts)
#:export (run-tests))
(define minimal-system-facts-json
'(("schemaVersion" . "1")
("hostName" . "node-a")
("interface" . "eth0")
("bootloaderTargets" . ("/dev/vda"))
("bootPartitionUuid" . "00000000-0000-0000-0000-000000000001")
("rootLuksUuid" . "00000000-0000-0000-0000-000000000002")))
(define (run-tests)
(test-begin "tribes-config-system-facts")
(test-equal "default local boot key lives under /boot"
"/boot/nbde/local-boot.key"
(tribes-system-facts-local-boot-key-file
(json-scm->tribes-system-facts minimal-system-facts-json)))
(test-equal "explicit local boot key path is preserved"
"/boot/custom.key"
(tribes-system-facts-local-boot-key-file
(json-scm->tribes-system-facts
(append minimal-system-facts-json
'(("localBootKeyFile" . "/boot/custom.key"))))))
(test-end "tribes-config-system-facts"))
(run-tests-when-script "tests/tribes-config-system-facts.scm" run-tests)
tests/tribes-deploy-channel-updates.scm
-123
View File
@@ -1,123 +0,0 @@
(define-module (tests tribes-deploy-channel-updates)
#:use-module (ice-9 ftw)
#:use-module (ice-9 popen)
#:use-module (ice-9 textual-ports)
#:use-module (guix build utils)
#:use-module (srfi srfi-64)
#:use-module (tests support)
#:use-module (tribes deploy channel-updates)
#:use-module (tribes deploy json)
#: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-channel-updates-test-"
(number->string (getpid))
"-"
(number->string *fixture-counter*))))
(delete-directory-if-present root)
(mkdir-p root)
root))
(define (run . args)
(let ((status (apply system* args)))
(unless (zero? status)
(error "command failed" args status))))
(define (git-output repo . args)
(let* ((port (apply open-pipe* OPEN_READ "git" "-C" repo args))
(output (string-trim-right (get-string-all port)))
(status (close-pipe port)))
(unless (zero? status)
(error "git command failed" args status))
output))
(define (write-file path text)
(call-with-output-file path
(lambda (port)
(display text port))))
(define (commit! repo text)
(write-file (string-append repo "/file.txt") text)
(run "git" "-C" repo "add" "file.txt")
(run "git" "-C" repo "commit" "-m" text))
(define (with-env name value thunk)
(let ((old (getenv name)))
(dynamic-wind
(lambda () (setenv name value))
thunk
(lambda ()
(if old
(setenv name old)
(unsetenv name))))))
(define (setup-repo root)
(let ((origin (string-append root "/origin"))
(checkout (string-append root "/cache/guix/checkouts/channel")))
(run "git" "init" "-b" "master" origin)
(run "git" "-C" origin "config" "user.email" "test@example.invalid")
(run "git" "-C" origin "config" "user.name" "Tribes Test")
(commit! origin "release 1.0.0")
(run "git" "-C" origin "tag" "v1.0.0")
(commit! origin "release 1.1.0")
(run "git" "-C" origin "tag" "v1.1.0")
(commit! origin "unreleased head")
(mkdir-p (dirname checkout))
(run "git" "clone" origin checkout)
(values origin checkout)))
(define (run-tests)
(test-begin "tribes-deploy-channel-updates")
(let ((root (fresh-root)))
(call-with-values (lambda () (setup-repo root))
(lambda (origin _checkout)
(let ((current (git-output origin "rev-list" "-n" "1" "v1.0.0")))
(with-env "XDG_CACHE_HOME" (string-append root "/cache")
(lambda ()
(let* ((payload `(("mode" . "semver_tags")
("limit" . 5)
("channels" . ((("id" . "channel-1")
("name" . "tribes")
("url" . ,origin)
("branch" . "master")
("current_commit" . ,current))))))
(result (channel-updates-payload payload))
(channels (json-list-ref result "channels"))
(channel (car channels))
(candidates (json-list-ref channel "candidates"))
(candidate (car candidates)))
(test-assert "channel update check succeeds"
(json-ref channel "ok"))
(test-equal "newest semver tag is returned"
"v1.1.0"
(json-ref candidate "tag"))
(test-equal "commit subject is included"
"release 1.1.0"
(json-ref candidate "subject"))
(let* ((commit-payload `(("mode" . "commits")
("limit" . 5)
("channels" . ((("id" . "channel-1")
("name" . "tribes")
("url" . ,origin)
("branch" . "master")
("current_commit" . ,current))))))
(commit-result (channel-updates-payload commit-payload))
(commit-channel (car (json-list-ref commit-result "channels")))
(commit-candidates (json-list-ref commit-channel "candidates"))
(commit-candidate (car commit-candidates)))
(test-equal "commit mode returns branch commits"
"unreleased head"
(json-ref commit-candidate "subject")))))))))
(delete-directory-if-present root))
(test-end "tribes-deploy-channel-updates"))
(run-tests-when-script "tests/tribes-deploy-channel-updates.scm" run-tests)
tests/tribes-deploy-current-guix-worker.scm
-47
View File
@@ -1,47 +0,0 @@
(define-module (tests tribes-deploy-current-guix-worker)
#:use-module (srfi srfi-64)
#:use-module (tests support)
#:use-module (tribes deploy current-guix-worker)
#:export (run-tests))
(define (with-worker-store-mocks ensure-path* references* thunk)
(let* ((worker-module (resolve-module '(tribes deploy current-guix-worker)))
(saved-ensure-path (module-ref worker-module 'ensure-path))
(saved-references (module-ref worker-module 'references)))
(dynamic-wind
(lambda ()
(module-set! worker-module 'ensure-path ensure-path*)
(module-set! worker-module 'references references*))
thunk
(lambda ()
(module-set! worker-module 'ensure-path saved-ensure-path)
(module-set! worker-module 'references saved-references)))))
(define (run-tests)
(test-begin "tribes-deploy-current-guix-worker")
(let ((ensured '())
(references-by-path
'(("system" . ("service-program"))
("service-program" . ("vinyl"))
("vinyl" . ()))))
(with-worker-store-mocks
(lambda (_store path)
(set! ensured (cons path ensured)))
(lambda (_store path)
;; Model substituted/generated store items whose references are only
;; known after the item itself has been realized locally.
(if (member path ensured)
(assoc-ref references-by-path path)
'()))
(lambda ()
((@@ (tribes deploy current-guix-worker) realize-store-closures)
'mock-store
'("system"))))
(test-equal "closure realization discovers references after each ensure"
'("vinyl" "service-program" "system")
ensured))
(test-end "tribes-deploy-current-guix-worker"))
(run-tests-when-script "tests/tribes-deploy-current-guix-worker.scm" run-tests)
tests/tribes-deploy-current-guix.scm
-146
View File
@@ -1,146 +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 (tests support)
#: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))
(test-assert "pulled Guix profile is detected"
(pulled-guix-profile-available?))))
(let* ((root (fresh-root))
(home (string-append root "/home"))
(bin (string-append root "/bin"))
(path-guix (string-append bin "/guix")))
(write-executable path-guix "#!/bin/sh\nexit 0\n")
(with-env (("HOME" home)
("PATH" bin))
(test-assert "missing pulled Guix profile is detected"
(not (pulled-guix-profile-available?)))
(test-equal "current-guix-binary falls back after pulled profile"
(if (file-exists? system-guix-binary)
system-guix-binary
path-guix)
(current-guix-binary))))
(with-env (("GUILE_LOAD_PATH" "bad-load")
("GUILE_LOAD_COMPILED_PATH" "bad-compiled")
("GUIX_PACKAGE_PATH" "bad-package")
("GUIX_UNINSTALLED" "bad-uninstalled"))
(let ((inside
(call-with-clean-guix-environment
(lambda ()
(list (getenv "GUILE_LOAD_PATH")
(getenv "GUILE_LOAD_COMPILED_PATH")
(getenv "GUIX_PACKAGE_PATH")
(getenv "GUIX_UNINSTALLED"))))))
(test-equal "clean Guix environment unsets wrapper paths"
'(#f #f #f #f)
inside)
(test-equal "clean Guix environment restores wrapper paths"
'("bad-load" "bad-compiled" "bad-package" "bad-uninstalled")
(list (getenv "GUILE_LOAD_PATH")
(getenv "GUILE_LOAD_COMPILED_PATH")
(getenv "GUIX_PACKAGE_PATH")
(getenv "GUIX_UNINSTALLED")))))
(let* ((root (fresh-root))
(profile (string-append root "/profile"))
(home (string-append root "/home"))
(pulled (string-append home "/.config/guix/current"))
(guix (string-append profile "/bin/guix"))
(site (string-append pulled "/share/guile/site/3.0"))
(compiled (string-append pulled "/lib/guile/3.0/site-ccache"))
(module (string-append site "/tribes/example.scm")))
(write-executable guix "#!/bin/sh\nexit 0\n")
(mkdir-p (dirname pulled))
(symlink profile pulled)
(mkdir-p (dirname module))
(mkdir-p compiled)
(call-with-output-file module
(lambda (port) (display ";; fixture\n" port)))
(with-env (("HOME" home)
("PATH" (string-append profile "/bin")))
(test-equal "current-guix-module-file resolves under selected profile"
module
(current-guix-module-file "tribes/example.scm"))
(test-equal "current Guix environment selects profile load paths"
(list site compiled #f "1")
(with-env (("GUILE_LOAD_PATH" "bad-load")
("GUILE_LOAD_COMPILED_PATH" "bad-compiled")
("GUIX_PACKAGE_PATH" "bad-package")
("GUIX_UNINSTALLED" "bad-uninstalled"))
(call-with-current-guix-environment
(lambda ()
(list (getenv "GUILE_LOAD_PATH")
(getenv "GUILE_LOAD_COMPILED_PATH")
(getenv "GUIX_PACKAGE_PATH")
(getenv "GUIX_UNINSTALLED"))))))))
(let* ((root (fresh-root))
(current-system (string-append root "/run/current-system"))
(channels-file (string-append current-system "/channels.scm")))
(mkdir-p current-system)
(call-with-output-file channels-file
(lambda (port)
(display "(list)\n" port)))
(test-equal "current system channels file is detected from active system"
channels-file
(current-system-channels-file current-system))
(test-assert "missing current system channels file is not synthesized"
(not (current-system-channels-file (string-append root "/missing")))))
(test-end "tribes-deploy-current-guix"))
(run-tests-when-script "tests/tribes-deploy-current-guix.scm" run-tests)
tests/tribes-deploy-executor.scm
+5 -169
View File
@@ -1,38 +1,8 @@
(define-module (tests tribes-deploy-executor)
#:use-module (srfi srfi-64)
#:use-module (tribes deploy executor)
#:use-module (tribes deploy plan)
#:use-module (tribes packages plugins)
#:use-module (tribes plugins built-ins)
#: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")
@@ -40,20 +10,21 @@
'()
(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")
("tribes" . (("host" . "example.com")
("plugins" . ("aether"))
("disabledPlugins" . ())))
("plugins" . ("aether"))))
("edge" . (("certificateName" . "tribes"))))
(host-config-with-plugins
'(("schemaVersion" . "1")
@@ -62,139 +33,4 @@
("edge" . (("certificateName" . "tribes"))))
'("aether")))
(test-equal "system target plugin names include installed plugins"
'("aether" "disabled")
(system-target-plugin-names
'(("plugins" . ((("plugin_name" . "aether")
("enabled" . #t))
(("plugin_name" . "disabled")
("enabled" . #f)))))))
(test-equal "system target disabled plugin names include disabled plugins"
'("disabled")
(system-target-disabled-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 "runtime capabilities come from built-in Tribes UI manifest"
'("org.tribe-one.caps.ui@1")
(tribes-plugin-definitions-provided-capabilities
guix-tribes-built-in-plugin-definitions))
(test-equal "host manifest requirements are satisfied by built-ins"
'()
guix-tribes-runtime-missing-capabilities)
(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"))
(test-equal "registry version is used"
"0.2.0"
(json-ref package-ref "version"))
(plan-plugins plan)))
(test-equal "resolve-target accepts spaced introduction fingerprints"
'("sender")
(let* ((spaced-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" . "0123 4567 89AB CDEF 0123 4567 89AB CDEF 0123 4567")))))
(plan
(resolve-target
`(("trusted_signers" . (,valid-signer))
("channels" . (,spaced-channel))
("plugins" . ((("plugin_name" . "sender")
("channel_id" . "guix-tribes")
("enabled" . #t))))))))
(plan-plugins plan)))
(test-equal "resolve-target satisfies org.tribe-one.caps.ui@1 from built-in Tribes UI"
'("sender")
(let ((plan
(resolve-target
`(("trusted_signers" . (,valid-signer))
("channels" . (,valid-channel))
("plugins" . ((("plugin_name" . "sender")
("channel_id" . "guix-tribes")
("enabled" . #t))))))))
(plan-plugins plan)))
(test-equal "resolve-target keeps disabled plugins installed but runtime-disabled"
'(("aether") ("aether"))
(let ((plan
(resolve-target
`(("trusted_signers" . (,valid-signer))
("channels" . (,valid-channel))
("plugins" . ((("plugin_name" . "aether")
("channel_id" . "guix-tribes")
("enabled" . #f))))))))
(list (plan-plugins plan) (plan-disabled-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
-530
View File
@@ -1,530 +0,0 @@
(define-module (tests tribes-deploy-operations)
#:use-module (ice-9 ftw)
#: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 (tests support)
#: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-pin
'(("plan_hash" . "plan-with-channel-pin")
("resolved_channels" . #((("channel_id" . "guix-tribes")
("name" . "tribes")
("url" . "https://git.example.test/guix-tribes.git")
("branch" . "master")
("commit" . "abc123")
("position" . 10))))
("resolved_plugins" . ((("name" . "supertest"))))))
(define plan-with-branch-channel
'(("plan_hash" . "plan-with-branch-channel")
("resolved_channels" . #((("channel_id" . "guix-tribes")
("name" . "tribes")
("url" . "https://git.example.test/guix-tribes.git")
("branch" . "master")
("commit" . #f)
("position" . 10))))
("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)
(helper-success-result
'(("event" . "done")
("catalog" . (("schemaVersion" . "2") ("plugins" . #()))))))
(lambda (_cfg _on-frame)
(set! pull-count (+ pull-count 1))
(helper-success-result
'(("event" . "done")
("phase" . "pulling")
("channels" . ((("name" . "tribes")
("url" . "https://git.example.test/guix-tribes.git")
("branch" . "master")
("commit" . "pulled456")))))))
(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
(lambda (port)
(let loop ((chars '()))
(let ((char (read-char port)))
(if (eof-object? char)
(list->string (reverse chars))
(loop (cons char chars))))))))
(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-plan-channels!
(@@ (tribes deploy operations) write-plan-channels!))
(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))
(config (fixture->config fixture))
(channels-file (assq-ref fixture 'channels-file))
(plan `(("plan_hash" . "plan-with-plugin-channel")
("resolved_channels" . ,(vector '(("channel_id" . "guix-tribes")
("name" . "tribes")
("url" . "https://git.example.test/guix-tribes.git")
("branch" . "supertest-dev")
("commit" . "plugin-commit")
("position" . 10)))))))
(call-with-output-file channels-file
(lambda (port)
(display "(list\n" port)
(display " (channel (name 'guix) (url \"https://git.example.test/guix.git\") (branch \"master\") (commit \"guix-commit\"))\n" port)
(display ")\n" port)))
(write-plan-channels! config plan)
(let ((channels (read-text-file channels-file)))
(test-assert "plan channel writer preserves current guix channel"
(string-contains channels "(name (quote guix))"))
(test-assert "plan channel writer includes plugin channel"
(string-contains channels "supertest-dev"))))
(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-with-channel-pin)
(plan-hash plan-with-channel-pin)
no-frame
#:plan plan-with-channel-pin))
(committed (commit-plan! state helper
(plan-hash plan-with-channel-pin)
no-frame))
(generation (find-generation-by-plan-hash
(state-store-read-generations state)
(plan-hash plan-with-channel-pin)))
(channels (json-list-ref generation "channels"))
(channel (car channels)))
(test-equal "prepared generation records channel pins"
"ready"
(json-ref prepared "status"))
(test-equal "active generation keeps channel pins"
"healthy"
(json-ref committed "status"))
(test-equal "generation channel pin records pulled commit"
"pulled456"
(json-ref channel "commit"))))))
(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)
(prepare-plugins! state helper
(plan-plugins plan-with-branch-channel)
(plan-hash plan-with-branch-channel)
no-frame
#:plan plan-with-branch-channel)
(let* ((generation (find-generation-by-plan-hash
(state-store-read-generations state)
(plan-hash plan-with-branch-channel)))
(channels (json-list-ref generation "channels"))
(channel (car channels)))
(test-equal "branch channel records exact pulled commit"
"pulled456"
(json-ref channel "commit"))))))
(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))))
(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-when-script "tests/tribes-deploy-operations.scm" run-tests)
tests/tribes-deploy-worker.scm
-145
View File
@@ -1,145 +0,0 @@
(define-module (tests tribes-deploy-worker)
#:use-module (guix build utils)
#:use-module (ice-9 atomic)
#:use-module (ice-9 threads)
#:use-module (srfi srfi-64)
#:use-module (tests support)
#:use-module (tribes deploy config)
#:use-module (tribes deploy json)
#:use-module (tribes deploy state)
#:use-module (tribes deploy worker)
#: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-worker-test-"
(number->string *fixture-counter*))))
(delete-directory-if-present root)
(mkdir-p root)
root))
(define (fixture-config root)
(deploy-config
(deploy-directory (string-append root "/deploy"))
(host-config-file (string-append root "/host-config.json"))
(channels-file (string-append root "/channels.scm"))
(current-config-file (string-append root "/configuration.scm"))
(current-system-link (string-append root "/run/current-system"))
(system-profile-link (string-append root "/profiles/system"))
(system-profile-directory (string-append root "/profiles"))
(helper-binary "fake-helper-not-used")))
(define (eventually? predicate)
(let loop ((attempts 200))
(cond
((predicate) #t)
((zero? attempts) #f)
(else
(usleep 10000)
(loop (- attempts 1))))))
(define (snapshot-field worker key)
(json-ref (worker-status worker) key))
(define (run-tests)
(test-begin "tribes-deploy-worker")
(let* ((root (fresh-root))
(config (fixture-config root))
(state (make-state-store config))
(worker (make-worker config state))
(release? (make-atomic-box #f)))
(call-with-values
(lambda ()
(worker-submit!
worker 'prepare "plan-a"
(lambda (update!)
(update! "pulling")
(let loop ()
(unless (atomic-box-ref release?)
(usleep 10000)
(loop)))
(update! "building")
(make-job-result
#t
'(("schemaVersion" . "2")
("ok" . #t)
("status" . "completed")
("phase" . "ready")
("plan_hash" . "plan-a"))))))
(lambda (status snapshot)
(test-equal "worker accepts first long-running job"
'accepted status)
(test-equal "accepted job starts queued"
"queued" (json-ref snapshot "phase"))))
(test-assert "worker status reaches helper phase while job runs"
(eventually? (lambda ()
(string=? (or (snapshot-field worker "phase") "")
"pulling"))))
(call-with-values
(lambda ()
(worker-submit! worker 'prepare "plan-a"
(lambda (_update!)
(make-job-result #t '()))))
(lambda (status _snapshot)
(test-equal "same plan is idempotent while running"
'idempotent status)))
(call-with-values
(lambda ()
(worker-submit! worker 'prepare "plan-b"
(lambda (_update!)
(make-job-result #t '()))))
(lambda (status snapshot)
(test-equal "different plan is busy while running"
'busy status)
(test-equal "busy response exposes running phase"
"pulling" (json-ref snapshot "phase"))))
(let ((aborted (worker-abort! worker)))
(test-equal "abort marks snapshot aborted"
"aborted" (json-ref aborted "phase")))
(call-with-values
(lambda ()
(worker-submit! worker 'prepare "plan-c"
(lambda (_update!)
(make-job-result #t '()))))
(lambda (status snapshot)
(test-equal "aborted running job still blocks new work"
'busy status)
(test-equal "busy response preserves aborted phase"
"aborted" (json-ref snapshot "phase"))))
(atomic-box-set! release? #t)
(test-assert "worker records final result after long job exits"
(eventually? (lambda ()
(string=? (or (snapshot-field worker "status") "")
"completed"))))
(worker-shutdown! worker))
(let* ((root (fresh-root))
(config (fixture-config root))
(state (make-state-store config))
(worker (make-worker config state)))
(call-with-values
(lambda ()
(worker-submit! worker 'prepare "plan-error"
(lambda (_update!)
(error "synthetic worker failure"))))
(lambda (status _snapshot)
(test-equal "worker accepts failing job"
'accepted status)))
(test-assert "worker converts job exceptions into failed snapshots"
(eventually? (lambda ()
(string=? (or (snapshot-field worker "status") "")
"failed"))))
(test-equal "worker failure snapshot is machine readable"
"broker_internal" (snapshot-field worker "code"))
(worker-shutdown! worker))
(test-end "tribes-deploy-worker"))
(run-tests-when-script "tests/tribes-deploy-worker.scm" run-tests)
tests/tribes-diagnostics-system-generations.scm
-76
View File
@@ -1,76 +0,0 @@
(define-module (tests tribes-diagnostics-system-generations)
#:use-module (srfi srfi-13)
#:use-module (srfi srfi-64)
#:use-module (tests support)
#: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-when-script "tests/tribes-diagnostics-system-generations.scm" run-tests)
tests/tribes-system-node.scm
-362
View File
@@ -1,362 +0,0 @@
(define-module (tests tribes-system-node)
#:use-module (gnu services)
#:use-module (gnu services monitoring)
#:use-module (gnu services shepherd)
#:use-module (guix gexp)
#:use-module (guix packages)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-13)
#:use-module (srfi srfi-64)
#:use-module (tests support)
#:use-module (tribes plugins sender)
#:use-module (tribes services chrony)
#:use-module (tribes services haproxy)
#:use-module (tribes services lego)
#:use-module (tribes services logging)
#:use-module (tribes services tribes)
#:use-module (tribes services vinyl)
#:use-module (tribes services vinyl-exporter)
#:use-module (tribes services victoriametrics)
#:use-module (tribes system node)
#:export (run-tests))
(define node-module (resolve-module '(tribes system node)))
(define chrony-module (resolve-module '(tribes services chrony)))
(define haproxy-module (resolve-module '(tribes services haproxy)))
(define logging-module (resolve-module '(tribes services logging)))
(define tribes-service-module (resolve-module '(tribes services tribes)))
(define victoriametrics-module (resolve-module '(tribes services victoriametrics)))
(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 chrony-shepherd-services
(module-ref chrony-module 'chrony-shepherd-services))
(define haproxy-config-file (module-ref haproxy-module 'haproxy-config-file))
(define tribes-system-logging-config-text
(module-ref logging-module 'tribes-system-logging-config-text))
(define tribes-root-shepherd-services
(module-ref tribes-service-module 'tribes-root-shepherd-services))
(define tribes-profile-packages
(module-ref tribes-service-module 'tribes-profile-packages))
(define tribes-sender-ffmpeg-package
(module-ref tribes-service-module 'tribes-sender-ffmpeg-package))
(define victoriametrics-shepherd-services
(module-ref victoriametrics-module 'victoriametrics-shepherd-services))
(define vmagent-shepherd-services
(module-ref victoriametrics-module 'vmagent-shepherd-services))
(define (contains? haystack needle)
(and (string-contains haystack needle) #t))
(define (object->string value)
(call-with-output-string
(lambda (port)
(write value port))))
(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")))))
(services (tribes-node-services config))
(chrony-service
(find (lambda (service)
(eq? (service-kind service) chrony-service-type))
services))
(node-exporter-service
(find (lambda (service)
(eq? (service-kind service)
prometheus-node-exporter-service-type))
services))
(network-tools-service
(find (lambda (service)
(let ((value (service-value service)))
(and (list? value)
(any (lambda (package)
(string=? (package-name package) "nftables"))
(filter package? value)))))
services)))
(test-assert "node profile includes nftables for sync partition tests"
network-tools-service)
(test-assert "node includes Chrony service"
chrony-service)
(test-assert "node includes Prometheus node exporter service"
node-exporter-service)
(test-equal "node exporter binds to loopback by default"
"127.0.0.1:9100"
(prometheus-node-exporter-web-listen-address
(service-value node-exporter-service)))
(test-assert "node includes VictoriaMetrics storage service"
(find (lambda (service)
(eq? (service-kind service) victoriametrics-service-type))
services))
(test-assert "node includes vmagent scrape service"
(find (lambda (service)
(eq? (service-kind service) vmagent-service-type))
services)))
(let ((logging-config (tribes-system-logging-configuration)))
(test-equal "syslog-ng combined JSONL path is the importer default"
"/var/log/tribes-combined.jsonl"
(tribes-system-logging-configuration-jsonl-path logging-config))
(let ((text (tribes-system-logging-config-text logging-config)))
(test-assert "syslog-ng listens on /dev/log for syslogd compatibility"
(contains? text "unix-dgram(\"/dev/log\")"))
(test-assert "syslog-ng writes conventional messages log"
(contains? text "file(\"/var/log/messages\" template(t_plain))"))
(test-assert "syslog-ng writes Tribes combined JSONL"
(contains? text "file(\"/var/log/tribes-combined.jsonl\" template(t_json) group(\"tribes\") perm(0640))"))
(test-assert "syslog-ng makes combined JSONL readable by the Tribes importer"
(contains? text "destination d_combined_jsonl { file(\"/var/log/tribes-combined.jsonl\" template(t_json) group(\"tribes\") perm(0640)); };"))
(test-assert "syslog-ng normalizes Shepherd messages copied through kmsg"
(and (contains? text "filter f_kmsg_shepherd")
(contains? text "set(\"shepherd\", value(\"PROGRAM\"))")
(contains? text "set-severity(\"notice\")")))
(test-assert "syslog-ng excludes raw Shepherd kmsg copies from generic system logs"
(contains? text "filter(f_not_kmsg_shepherd); destination(d_combined_jsonl)"))
(test-assert "syslog-ng tails Tribes service log"
(contains? text "file(\"/var/log/tribes.log\" flags(no-parse)"))
(test-assert "syslog-ng tails Prometheus node exporter log"
(contains? text "file(\"/var/log/prometheus-node-exporter.log\" flags(no-parse) program_override(\"prometheus-node-exporter\")"))
(test-assert "syslog-ng writes Chrony native syslog to a per-service log"
(contains? text "filter f_native_chronyd { program(\"chronyd\"); };"))
(test-assert "syslog-ng does not tail Chrony's native syslog destination"
(not (contains? text "file(\"/var/log/chronyd.log\" flags(no-parse)")))))
(let* ((config (chrony-configuration))
(rendered (chrony-config-file config))
(text (plain-file-content rendered))
(services (chrony-shepherd-services config)))
(test-equal "Chrony renders expected configuration file name"
"chrony.conf"
(plain-file-name rendered))
(test-assert "Chrony uses the Guix NTP pool"
(contains? text "pool 2.guix.pool.ntp.org iburst"))
(test-assert "Chrony allows startup clock steps"
(contains? text "makestep 0.1 3"))
(test-assert "Chrony stores drift under its state directory"
(contains? text "driftfile /var/lib/chrony/chrony.drift"))
(test-equal "Chrony renders one shepherd service"
1
(length services))
(test-assert "Chrony shepherd service provides chronyd"
(memq 'chronyd
(shepherd-service-provision (car services)))))
(let ((storage-config (victoriametrics-configuration))
(agent-config (vmagent-configuration))
(scrape-config (default-vmagent-scrape-config-text)))
(test-equal "VictoriaMetrics binds to loopback by default"
"127.0.0.1:8428"
(victoriametrics-configuration-http-listen-address storage-config))
(test-equal "VictoriaMetrics retains node metrics for 90 days"
"90d"
(victoriametrics-configuration-retention-period storage-config))
(test-equal "vmagent binds to loopback by default"
"127.0.0.1:8429"
(vmagent-configuration-http-listen-address agent-config))
(test-equal "vmagent remote-writes to local VictoriaMetrics"
"http://127.0.0.1:8428/api/v1/write"
(vmagent-configuration-remote-write-url agent-config))
(test-assert "default scrape config scrapes node exporter"
(contains? scrape-config "targets: [\"127.0.0.1:9100\"]"))
(test-assert "default scrape config scrapes VictoriaMetrics"
(contains? scrape-config "targets: [\"127.0.0.1:8428\"]"))
(test-assert "default scrape config scrapes Tribes metrics"
(contains? scrape-config "targets: [\"127.0.0.1:4000\"]"))
(test-assert "default scrape config scrapes Vinyl exporter"
(contains? scrape-config "targets: [\"127.0.0.1:9131\"]"))
(test-equal "VictoriaMetrics renders one shepherd service"
1
(length (victoriametrics-shepherd-services storage-config)))
(test-equal "vmagent renders one shepherd service"
1
(length (vmagent-shepherd-services agent-config))))
(let* ((services (tribes-root-shepherd-services
(tribes-configuration (host "example.invalid"))))
(service-by-provision
(lambda (provision)
(find (lambda (service)
(memq provision (shepherd-service-provision service)))
services))))
(for-each
(lambda (provision)
(test-assert
(string-append (symbol->string provision)
" waits for explicit post-secret startup")
(let ((service (service-by-provision provision)))
(and service
(not (shepherd-service-auto-start? service))))))
'(tribes tribes-migrations tribes-plugin-rollback-migrations))
(test-assert "tribes-boot-start starts automatically after secrets exist"
(let ((service (service-by-provision 'tribes-boot-start)))
(and service
(shepherd-service-auto-start? service))))
(test-assert "tribes-boot-start uses Shepherd start-service"
(let* ((service (service-by-provision 'tribes-boot-start))
(start-sexpr (and service
(gexp->approximate-sexp
(shepherd-service-start service))))
(start-text (and start-sexpr
(object->string start-sexpr))))
(and start-text
(contains? start-text "(start-service (lookup-service (quote tribes)))")
(not (contains? start-text "perform-service-action")))))
(test-assert "tribes profile includes inotify-tools for file_system"
(any (lambda (package)
(string=? (package-name package) "inotify-tools"))
(tribes-profile-packages
(tribes-configuration (host "example.invalid")))))
(test-assert "base tribes config does not force ffmpeg into the launcher"
(not (tribes-sender-ffmpeg-package
(tribes-configuration (host "example.invalid")))))
(test-assert "sender-enabled tribes config exposes sender ffmpeg for env override"
(let ((package (tribes-sender-ffmpeg-package
(tribes-configuration
(host "example.invalid")
(plugins (list (sender-external-plugin)))))))
(and package
(string=? (package-name package) "sender-ffmpeg")))))
(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))
(vinyl-exporter-service
(find (lambda (service)
(eq? (service-kind service) vinyl-exporter-service-type))
services))
(haproxy-service (find (lambda (service)
(eq? (service-kind service) haproxy-service-type))
services))
(lego-service (find (lambda (service)
(eq? (service-kind service) lego-service-type))
services))
(vinyl-configs (and vinyl-service
(service-value vinyl-service)))
(vinyl-exporter-config (and vinyl-exporter-service
(service-value vinyl-exporter-service)))
(lego-config (and lego-service
(service-value lego-service)))
(edge-vinyl (and vinyl-configs
(find (lambda (config)
(string=? (vinyl-configuration-name config)
"tribes-edge"))
vinyl-configs))))
(test-equal "edge uses one vinyl cache process"
1
(and vinyl-configs
(length vinyl-configs)))
(test-assert "edge includes Vinyl exporter service"
vinyl-exporter-service)
(test-equal "edge Vinyl exporter uses edge workdir"
"/var/vinyl/tribes-edge"
(and vinyl-exporter-config
(vinyl-exporter-configuration-vinyl-workdir
vinyl-exporter-config)))
(test-equal "edge Vinyl exporter labels Sender HLS streams by stream id"
"/sender/hls/streams/"
(and vinyl-exporter-config
(vinyl-exporter-configuration-hls-path-prefix
vinyl-exporter-config)))
(test-equal "edge Vinyl exporter uses one HLS stream label component"
1
(and vinyl-exporter-config
(vinyl-exporter-configuration-hls-stream-components
vinyl-exporter-config)))
(test-equal "edge Vinyl exporter uses vsid identity"
'("vsid")
(and vinyl-exporter-config
(vinyl-exporter-configuration-hls-query-params
vinyl-exporter-config)))
(test-equal "edge vinyl permits five graceful retries"
'((max_retries . 5))
(and edge-vinyl
(vinyl-configuration-parameters edge-vinyl)))
(test-equal "lego waits for haproxy challenge routing"
'(haproxy)
(and lego-config
(lego-certificate-configuration-requirement
(car (lego-configuration-certificates lego-config)))))
(test-assert "edge uses haproxy for TLS termination"
haproxy-service))
(let* ((config (haproxy-configuration
(backend "127.0.0.1:6081")
(frontends '("0.0.0.0:443" "[::]:443 v6only"))
(http-frontends '("0.0.0.0:80" "[::]:80 v6only"))
(acme-backend "127.0.0.1:8080")
(pem-files '("/var/lib/lego/tribes/full.pem"))))
(rendered (haproxy-config-file config))
(text (plain-file-content rendered)))
(test-equal "haproxy renders expected configuration file name"
"haproxy.conf"
(plain-file-name rendered))
(test-assert "haproxy does not use deprecated master-worker config keyword"
(not (contains? text "master-worker\n")))
(test-assert "haproxy does not require OpenSSL QUIC compatibility mode"
(not (contains? text "limited-quic")))
(test-assert "haproxy logs to syslog-ng"
(contains? text "log /dev/log local0"))
(test-assert "haproxy preserves privileged bind capability for QUIC"
(contains? text "setcap cap_net_bind_service"))
(test-assert "haproxy binds configured certificate"
(contains? text
"bind 0.0.0.0:443 ssl crt /var/lib/lego/tribes/full.pem alpn h2,http/1.1"))
(test-assert "haproxy binds QUIC over IPv4"
(contains? text
"bind quic4@0.0.0.0:443 ssl crt /var/lib/lego/tribes/full.pem alpn h3"))
(test-assert "haproxy binds QUIC over IPv6"
(contains? text
"bind quic6@[::]:443 v6only ssl crt /var/lib/lego/tribes/full.pem alpn h3"))
(test-assert "haproxy advertises HTTP/3"
(contains? text "http-response set-header alt-svc 'h3=\":443\"; ma=86400'"))
(test-assert "haproxy binds public HTTP"
(contains? text "bind 0.0.0.0:80"))
(test-assert "haproxy routes ACME challenges to lego"
(contains? text "use_backend lego_acme if acme_challenge"))
(test-assert "haproxy redirects non-ACME HTTP traffic"
(contains? text
"http-request redirect scheme https code 308 unless acme_challenge"))
(test-assert "haproxy forwards ACME requests to lego challenge server"
(contains? text "server lego 127.0.0.1:8080"))
(test-assert "haproxy forwards to vinyl cache backend"
(contains? text "server vinyl 127.0.0.1:6081 check")))
(test-end "tribes-system-node"))
(run-tests-when-script "tests/tribes-system-node.scm" run-tests)
tribes/ci/artifacts-kexec.scm
-13
View File
@@ -1,13 +0,0 @@
(define-module (tribes ci artifacts-kexec)
#:use-module (tribes ci artifacts)
#:use-module (srfi srfi-1)
#:export (cuirass-jobs))
(define (cuirass-jobs store arguments)
(append-map
(lambda (system)
(list (artifact-job store
"guix-kexec-installer"
guix-kexec-installer-image
system)))
(arguments->systems arguments)))
tribes/ci/artifacts-master.scm
-27
View File
@@ -1,27 +0,0 @@
(define-module (tribes ci artifacts-master)
#:use-module (tribes ci artifacts)
#:use-module (srfi srfi-1)
#:export (cuirass-jobs))
;; Publishable artifacts: the debug Docker image and the Sender runtime pack.
;; Node operating-system closures and bootloader files are warmed by the
;; dedicated (tribes ci artifacts-substitutes) jobset instead.
(define (cuirass-jobs store arguments)
(let ((tribes-commit (arguments->channel-commit arguments 'tribes)))
(append-map
(lambda (system)
(list (artifact-job store
"tribes-debug-docker"
(lambda ()
(tribes-debug-docker-image
#:image-tag
(if tribes-commit
(string-append "tribes-guix-debug:"
tribes-commit)
"tribes-guix-debug:latest")))
system)
(artifact-job store
"tribes-sender-runtime"
tribes-sender-runtime-pack
system)))
(arguments->systems arguments))))
tribes/ci/artifacts-substitutes.scm
-21
View File
@@ -1,21 +0,0 @@
(define-module (tribes ci artifacts-substitutes)
#:use-module (tribes ci artifacts)
#:use-module (srfi srfi-1)
#:export (cuirass-jobs))
;; Warm the substitute mirror with the closures of the real Tribes node
;; operating-systems and their bootloader files, so deployed nodes pull every
;; required store path from guix.tribe-one.org during `guix system
;; init'/reconfigure without depending on upstream availability. This is the
;; authoritative substitute set: it is computed from the very operating-systems
;; nodes materialize, so it cannot drift the way the hand-curated
;; manifests/substitutes/*.scm package lists did, and it transitively covers
;; everything the node closure contains -- including the operator toolkit now
;; carried in the node system profile and the upstream dependencies pulled in
;; while building the closure.
(define (cuirass-jobs store arguments)
(append-map
(lambda (system)
(append (substitute-system-jobs store system)
(substitute-file-jobs store system)))
(arguments->systems arguments)))
tribes/ci/artifacts.scm
-340
View File
@@ -1,340 +0,0 @@
(define-module (tribes ci artifacts)
#:use-module (gnu compression)
#:use-module (gnu packages admin)
#:use-module (gnu packages base)
#:use-module (gnu packages compression)
#:use-module (gnu packages cpio)
#:use-module (gnu packages linux)
#:use-module (gnu packages monitoring)
#:use-module (gnu packages nss)
#:use-module (gnu system)
#:use-module (guix build-system gnu)
#:use-module (guix channels)
#:use-module (guix derivations)
#:use-module (guix gexp)
#:use-module (guix monads)
#:use-module (guix packages)
#:use-module (guix profiles)
#:use-module (guix scripts pack)
#:use-module (guix store)
#:use-module (ice-9 match)
#:use-module (nbde system build-host-kexec-installer)
#:use-module (srfi srfi-1)
#:use-module (tribes ci substitutes)
#:use-module (tribes packages docker)
#:use-module (tribes packages monitoring)
#:use-module (tribes packages sender-runtime)
#:use-module (tribes packages web)
#:export (tribes-debug-docker-image
tribes-sender-runtime-pack
guix-kexec-installer-image
artifact-job
arguments->systems
arguments->channel-commit
substitute-channel-profile-jobs
substitute-system-jobs
substitute-file-jobs))
(define (tribes-debug-docker-profile)
(profile
(content (packages->manifest (list tribes-debug-docker-package)))
(hooks %default-profile-hooks)
(locales? #t)))
(define* (tribes-debug-docker-image
#:key
(image-tag "tribes-guix-debug:latest"))
(docker-image (string-append "tribes-debug-docker-" (%current-system))
(tribes-debug-docker-profile)
#:compressor (lookup-compressor "gzip")
#:symlinks '(("/bin" -> "bin"))
#:entry-point "/bin/tribes"
#:extra-options `(#:image-tag ,image-tag)))
(define (tribes-sender-runtime-profile)
(profile
(content (packages->manifest
(list tribes-sender-runtime
sender-ffmpeg
vinyl
vinyl-exporter
prometheus-node-exporter
victoriametrics
shepherd
nss-certs)))
(hooks %default-profile-hooks)
(locales? #t)))
(define (tribes-sender-runtime-pack)
(self-contained-tarball
(string-append "tribes-sender-runtime-" (%current-system))
(tribes-sender-runtime-profile)
#:compressor (lookup-compressor "zstd")
#:symlinks '(("/opt/tribes-sender-runtime/bin" -> "bin")
("/opt/tribes-sender-runtime/sbin" -> "sbin")
("/opt/tribes-sender-runtime/share" -> "share"))))
(define (guix-kexec-installer-image)
(mlet %store-monad ((system (operating-system-derivation
build-host-kexec-installer-os)))
(gexp->derivation
(string-append "guix-kexec-installer-" (%current-system) ".tar.gz")
(with-imported-modules '((guix build utils))
#~(begin
(use-modules (guix build utils)
(ice-9 match)
(ice-9 popen)
(ice-9 rdelim)
(srfi srfi-1)
(srfi srfi-13))
(define system #$system)
(define tmp (getcwd))
(define kexec-dir (string-append tmp "/kexec"))
(define squashfs-root (string-append tmp "/squashfs-root"))
(define (field name fields)
(match (assoc name fields)
((_ value) value)
(_ (error "missing boot parameter field" name))))
(define (read-lines file)
(call-with-input-file file
(lambda (port)
(let loop ((lines '()))
(let ((line (read-line port)))
(if (eof-object? line)
(reverse lines)
(loop (cons line lines))))))))
(define (store-item-root path)
(let ((prefix "/gnu/store/"))
(unless (string-prefix? prefix path)
(error "not a store item" path))
(let* ((base (string-drop path (string-length prefix)))
(slash (string-index base #\/)))
(string-append prefix
(if slash
(string-take base slash)
base)))))
(define (boot-metadata system)
(match (call-with-input-file (string-append system "/parameters") read)
(('boot-parameters fields ...)
(let* ((kernel (field 'kernel fields))
(initrd (field 'initrd fields))
(root (field 'root-device fields))
(args (field 'kernel-arguments fields))
(boot-path (canonicalize-path (string-append system "/boot")))
(boot-args
(append
(cond
((equal? root "tmpfs")
'("rootfstype=tmpfs"))
((and (string? root) (not (string=? root "none")))
(list (string-append "root=" root)))
(else '()))
(list (string-append "gnu.system=" system)
(string-append "gnu.load=" boot-path))
args)))
(list kernel initrd boot-path (string-join boot-args " "))))
(sexp
(error "unrecognized boot parameters file" sexp))))
(match (boot-metadata system)
((kernel initrd boot-path cmdline)
(let* ((initrd-store (store-item-root initrd))
(parameters-store
(store-item-root
(canonicalize-path (string-append system "/parameters"))))
(excluded-store-items (list initrd-store parameters-store)))
(mkdir-p kexec-dir)
(copy-file kernel (string-append kexec-dir "/bzImage"))
(copy-file initrd (string-append kexec-dir "/initrd"))
(chmod (string-append kexec-dir "/initrd") #o644)
(copy-file #$(file-append (static-package kexec-tools) "/sbin/kexec")
(string-append kexec-dir "/kexec-static"))
(chmod (string-append kexec-dir "/kexec-static") #o755)
(copy-file #$(local-file "../../scripts/kexec-run" "kexec-run")
(string-append kexec-dir "/run"))
(chmod (string-append kexec-dir "/run") #o755)
(call-with-output-file (string-append kexec-dir "/cmdline")
(lambda (port)
(display cmdline port)
(newline port)))
(mkdir-p squashfs-root)
(for-each
(lambda (path)
(when (and (string-prefix? "/gnu/store/" path)
(not (member path excluded-store-items))
(file-exists? path))
(copy-recursively path
(string-append squashfs-root "/"
(basename path))
#:keep-mtime? #t)))
(delete-duplicates
(append (list system boot-path)
(read-lines "system-graph"))))
(invoke #$(file-append squashfs-tools "/bin/mksquashfs")
squashfs-root
(string-append kexec-dir "/gnu-store.squashfs")
"-comp" "gzip"
"-Xcompression-level" "9"
"-no-xattrs"
"-noappend")
(let ((cpio-root (string-append tmp "/squashfs-cpio")))
(mkdir-p cpio-root)
(copy-file (string-append kexec-dir "/gnu-store.squashfs")
(string-append cpio-root "/gnu-store.squashfs"))
(delete-file (string-append kexec-dir "/gnu-store.squashfs"))
(let ((pipe (open-output-pipe
(string-append "cd " cpio-root
" && printf gnu-store.squashfs | "
#$(file-append cpio "/bin/cpio")
" -o -H newc | "
#$(file-append gzip "/bin/gzip")
" -9 >> " kexec-dir "/initrd"))))
(unless (zero? (close-pipe pipe))
(error "failed to append squashfs cpio to initrd"))))
(invoke #$(file-append tar "/bin/tar")
"-C" tmp
"-I" #$(file-append gzip "/bin/gzip")
"-cf" #$output
"kexec"))))))
#:references-graphs `(("system-graph" ,system)))))
(define* (derivation->job name drv
#:key
(max-silent-time 3600)
(timeout (* 5 3600)))
`((#:job-name . ,name)
(#:derivation . ,(derivation-file-name drv))
(#:inputs . ,(map (lambda (input)
(derivation-file-name
(derivation-input-derivation input)))
(derivation-inputs drv)))
(#:outputs . ,(filter-map
(lambda (res)
(match res
((name . path)
`(,name . ,path))))
(derivation->output-paths drv)))
(#:nix-name . ,(derivation-name drv))
(#:system . ,(derivation-system drv))
(#:max-silent-time . ,max-silent-time)
(#:timeout . ,timeout)))
(define (arguments->systems arguments)
(or (assoc-ref arguments 'systems)
(list (%current-system))))
(define (repository-field field repository)
(match (assoc field (cdr repository))
((_ value) value)
(_ #f)))
(define (arguments->channel-commit arguments channel-name)
(match (find (lambda (repository)
(and (pair? repository)
(eq? 'repository (car repository))
(eq? channel-name
(repository-field 'name repository))))
(or (assoc-ref arguments 'channels) '()))
(#f #f)
(repository
(repository-field 'commit repository))))
(define (arguments->channels arguments)
(filter-map sexp->channel (or (assoc-ref arguments 'channels) '())))
(define (canonical-time-machine-channel channel)
;; Cuirass passes channel sexps whose URLs point at its pre-fetched
;; /gnu/store checkouts and whose introductions were dropped when Cuirass
;; created channel instances from those checkouts. That is correct for
;; evaluating custom jobs inside Cuirass, but it does not match the profile
;; computed by `guix time-machine -C channels.scm` on Legion installers,
;; where the channel URLs and introductions come from the public channel
;; file. Reconstruct those canonical fields while preserving the evaluated
;; commits.
(let* ((channel-name* (channel-name channel))
(canonical-url (match channel-name*
('guix "https://git.teralink.net/tribes/guix-fork.git")
('tribes "https://git.teralink.net/tribes/guix-tribes.git")
(_ (channel-url channel))))
(canonical-introduction
(or (channel-introduction channel)
(match channel-name*
('guix
(make-channel-introduction
"093f27dde01cdbda68f2ec4b81e5a34ae180aab9"
(openpgp-fingerprint
"6688 9153 C51C 4613 A493 A525 2F0D FD14 EF99 DAC3")))
('tribes
(make-channel-introduction
"607c69a5c1662acca07ad72c3e18646c73500856"
(openpgp-fingerprint
"6688 9153 C51C 4613 A493 A525 2F0D FD14 EF99 DAC3")))
(_ #f)))))
((@@ (guix channels) make-channel)
channel-name*
canonical-url
(channel-branch channel)
(channel-commit channel)
canonical-introduction
#f)))
(define (substitute-channel-profile-jobs store arguments system)
(let ((channels (map canonical-time-machine-channel
(arguments->channels arguments))))
(if (null? channels)
'()
(list (artifact-job store
"substitute-channel-profile"
(lambda ()
(latest-channel-derivation channels))
system)))))
(define %substitute-file-targets
`((bios-bootloader-configuration . ,bios-bootloader-configuration)
(bios-bootloader-configuration-installer . ,bios-bootloader-configuration-installer)
(efi-bootloader-configuration . ,efi-bootloader-configuration)
(efi-bootloader-configuration-installer . ,efi-bootloader-configuration-installer)))
(define (artifact-job store name proc system)
(let ((drv (parameterize ((%current-system system)
(%graft? #f))
(run-with-store store
(mbegin %store-monad
(set-guile-for-build (default-guile))
(proc))
#:system system))))
(derivation->job (string-append name "." system)
drv
#:max-silent-time 3600
#:timeout 72000)))
(define (substitute-system-jobs store system)
(map (match-lambda
((name . os)
(artifact-job store
(string-append "substitute-system-"
(symbol->string name))
(lambda ()
(operating-system-derivation os))
system)))
%substitute-operating-system-targets))
(define (substitute-file-jobs store system)
(map (match-lambda
((name . file)
(artifact-job store
(string-append "substitute-file-"
(symbol->string name))
(lambda ()
(lower-object file))
system)))
%substitute-file-targets))
tribes/ci/channel.scm
-12
View File
@@ -1,12 +0,0 @@
(define-module (tribes ci channel)
#:use-module (srfi srfi-1)
#:use-module (tribes ci artifacts)
#:export (cuirass-jobs))
;; Cheap canary spec: emit only the channel-instance derivation, so a
;; "tribes modules compile and the checkout is reachable" signal is
;; independent of any package or system build.
(define (cuirass-jobs store arguments)
(append-map (lambda (system)
(substitute-channel-profile-jobs store arguments system))
(arguments->systems arguments)))
tribes/ci/fixtures/root-authorized_keys
-1
View File
@@ -1 +0,0 @@
ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAITestLegionSharedBuilder legion@example.invalid
tribes/ci/substitutes.scm
-281
View File
@@ -1,281 +0,0 @@
(define-module (tribes ci substitutes)
#: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)
#:use-module (gnu system file-systems)
#:use-module (gnu system mapped-devices)
#:use-module (gnu system uuid)
#:use-module (guix scripts system reconfigure)
#:use-module (guix gexp)
#: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 packages plugins)
#:use-module (tribes packages source)
#:use-module (tribes plugins registry)
#:use-module (tribes services tribes)
#:use-module (tribes system installer)
#:use-module (tribes system materialize)
#:use-module (tribes system node)
#:export (phase1-operating-system
base-edge-operating-system
aether-edge-operating-system
kobold-edge-operating-system
sender-edge-operating-system
supertest-edge-operating-system
bios-bootloader-configuration
efi-bootloader-configuration
bios-bootloader-configuration-installer
efi-bootloader-configuration-installer
%substitute-operating-system-targets))
(define %ci-authorized-keys-file
(plain-file
"tribes-ci-authorized_keys"
"ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAITestLegionSharedBuilder legion@example.invalid\n"))
(define %ci-mapped-devices
(list
(mapped-device
(source (uuid "00000000-0000-0000-0000-000000000002" 'luks))
(target "cryptroot")
(type clevis-luks-device-mapping))))
(define %ci-initrd
(lambda (file-systems . rest)
(apply clevis-initrd file-systems
#:mapped-devices %ci-mapped-devices
#:network (nbde-network-configuration
(interface "eth0")
(timeout 20))
rest)))
(define %ci-file-systems
(cons* (file-system
(mount-point "/")
(device "/dev/mapper/cryptroot")
(type "ext4"))
(file-system
(mount-point "/boot")
(device (uuid "00000000-0000-0000-0000-000000000001" 'ext4))
(type "ext4"))
%base-file-systems))
(define %ci-efi-file-systems
(cons* (file-system
(mount-point "/boot/efi")
(device (uuid "0000-0003" 'fat32))
(type "vfat"))
%ci-file-systems))
(define %bootloader-ci-file-systems
(cons* (file-system
(mount-point "/")
(device "/dev/vda1")
(type "ext4"))
%base-file-systems))
(define %bootloader-ci-efi-file-systems
(cons* (file-system
(mount-point "/boot/efi")
(device (uuid "0000-0003" 'fat32))
(type "vfat"))
%bootloader-ci-file-systems))
(define %ci-nbde-services
(list
(service tang-service-type
(tang-configuration
(port 7654)))
(simple-service
'tribes-ci-nbde-packages
profile-service-type
(list clevis cryptsetup curl))))
(define (plugin-by-name name)
(let ((plugin-definition (guix-tribes-plugin-definition-by-name name)))
(unless plugin-definition
(error "unknown guix-tribes plugin" name))
(tribes-plugin-definition-external-plugin plugin-definition)))
(define (ci-tribes-configuration plugins)
(tribes-configuration
(package tribes-package)
(plugins plugins)
(working-directory "/var/lib/tribes")
(user "tribes")
(group "tribes")
(host "node1.example.invalid")
(listen-address "127.0.0.1")
(listen-port 4000)
(scheme "https")
(port 443)
(sync-host "node1.example.invalid")
(sync-port 4413)
(sync-bind-address "0.0.0.0")
(sync-url "wss://node1.example.invalid:4413/relay")
(sync-tls-certfile "/var/lib/tribes/secrets/sync/node.pem")
(sync-tls-keyfile "/var/lib/tribes/secrets/sync/node-key.pem")
(sync-tls-cacertfile "/var/lib/tribes/secrets/sync/ca.pem")
(admin-pubkeys '())
(database-user "tribes")
(database-name "tribes")
(parrhesia-database-name "parrhesia")
(database-host "/var/run/postgresql")
(secret-key-base-file "/var/lib/tribes/secrets/secret_key_base")
(token-signing-secret-file "/var/lib/tribes/secrets/token_signing_secret")
(release-cookie-file "/var/lib/tribes/secrets/release_cookie")
(release-distribution "name")
(release-node "tribes@127.0.0.1")
(extra-environment-variables
'("TRIBES_BOOTSTRAP_FILE=/etc/tribes/bootstrap.json"))
(log-file "/var/log/tribes.log")))
(define (ci-host-configuration plugins)
(tribes-host-configuration
(tribes (ci-tribes-configuration plugins))
(edge
(tribes-edge-configuration
(certificate-name "node1-example-invalid")
(certificate-subjects '("node1.example.invalid"))
(certificate-email "ops@example.invalid")
(certificate-profile "shortlived")
(renew-days 4)
(http-port 80)
(https-port 443)
(challenge-address "127.0.0.1")
(challenge-port 8080)
(cache-address "127.0.0.1")
(cache-port 6081)
(cache-storage '("malloc,256M"))))))
(define (ci-authorized-keys-file-name)
(or (search-path %load-path "tribes/ci/fixtures/root-authorized_keys")
(error "failed to locate CI authorized_keys fixture")))
(define %ci-system-facts
(tribes-system-facts
(host-name "tribes-ci-base-edge")
(interface "eth0")
(boot-mode "bios")
(bootloader-targets (list "/dev/sda"))
(boot-partition-uuid "11111111-2222-3333-4444-555555555555")
(boot-partition-file-system-type "ext4")
(root-luks-uuid "66666666-7777-8888-9999-aaaaaaaaaaaa")
(root-mapper-name "cryptroot")
(root-file-system-type "ext4")
(authorized-keys-file (ci-authorized-keys-file-name))
(local-boot-key-file "/boot/nbde/local-boot.key")
(tang-port 7654)
(initrd-network-timeout-seconds 20)
(enable-bbr? #t)))
(define* (ci-operating-system name plugins
#:key
(bootloader
(bootloader-configuration
(bootloader grub-bootloader)
(targets (list "/dev/vda"))))
(file-systems %ci-file-systems))
(tribes-installer-operating-system
#:host-configuration (ci-host-configuration plugins)
#:host-name name
#:bootloader bootloader
#:mapped-devices %ci-mapped-devices
#:file-systems file-systems
#:initrd %ci-initrd
#:interface "eth0"
#:authorized-keys-file %ci-authorized-keys-file
#:extra-services %ci-nbde-services))
(define (ci-materialized-operating-system plugins)
(tribes-host-configuration+system-facts->operating-system
(ci-host-configuration plugins)
%ci-system-facts))
(define* (bootloader-ci-operating-system name bootloader file-systems)
(operating-system
(host-name name)
(bootloader bootloader)
(file-systems file-systems)
(firmware '())
(packages '())))
(define bios-bootloader-operating-system
(bootloader-ci-operating-system
"tribes-ci-bootloader-bios"
(bootloader-configuration
(bootloader grub-bootloader)
(targets (list "/dev/vda")))
%bootloader-ci-file-systems))
(define efi-bootloader-operating-system
(bootloader-ci-operating-system
"tribes-ci-bootloader-efi"
(bootloader-configuration
(bootloader grub-efi-removable-bootloader)
(targets (list "/boot/efi")))
%bootloader-ci-efi-file-systems))
(define (bootloader-configuration-installer os target)
(let* ((bootloader-config (operating-system-bootloader os))
(bootloader (bootloader-configuration-bootloader bootloader-config))
(bootcfg (operating-system-bootcfg os))
(installer (bootloader-installer bootloader))
(disk-installer (bootloader-disk-image-installer bootloader))
(package (bootloader-package bootloader))
(bootcfg-file (bootloader-configuration-file bootloader))
(devices (bootloader-configuration-targets bootloader-config)))
(install-bootloader-program installer
disk-installer
#~#+package
bootcfg
bootcfg-file
devices
target)))
(define bios-bootloader-configuration
(operating-system-bootcfg bios-bootloader-operating-system))
(define efi-bootloader-configuration
(operating-system-bootcfg efi-bootloader-operating-system))
(define bios-bootloader-configuration-installer
(bootloader-configuration-installer bios-bootloader-operating-system "/"))
(define efi-bootloader-configuration-installer
(bootloader-configuration-installer efi-bootloader-operating-system "/"))
(define phase1-operating-system
(ci-operating-system "tribes-ci-phase1" '()))
(define base-edge-operating-system
(ci-materialized-operating-system '()))
(define aether-edge-operating-system
(ci-operating-system "tribes-ci-aether-edge"
(list (plugin-by-name "aether"))))
(define kobold-edge-operating-system
(ci-operating-system "tribes-ci-kobold-edge"
(list (plugin-by-name "trust")
(plugin-by-name "kobold"))))
(define sender-edge-operating-system
(ci-operating-system "tribes-ci-sender-edge"
(list (plugin-by-name "sender"))))
(define supertest-edge-operating-system
(ci-operating-system "tribes-ci-supertest-edge"
(list (plugin-by-name "supertest"))))
(define %substitute-operating-system-targets
`((phase1 . ,phase1-operating-system)
(base-edge . ,base-edge-operating-system)
(aether-edge . ,aether-edge-operating-system)
(kobold-edge . ,kobold-edge-operating-system)
(sender-edge . ,sender-edge-operating-system)
(supertest-edge . ,supertest-edge-operating-system)))
tribes/config/host.scm
+5 -4
View File
@@ -2,7 +2,7 @@
#:use-module (guix records)
#:use-module (srfi srfi-1)
#:use-module (tribes packages plugins)
#:use-module (tribes plugins discovery)
#:use-module (tribes plugins registry)
#:use-module (tribes packages source)
#:use-module (tribes services tribes)
#:use-module (tribes system node)
@@ -67,7 +67,7 @@
(map
(lambda (plugin-name)
(let ((plugin-definition
(tribes-plugin-definition-by-name plugin-name)))
(guix-tribes-plugin-definition-by-name plugin-name)))
(unless plugin-definition
(error "unknown tribes plugin" plugin-name))
(tribes-plugin-definition-external-plugin plugin-definition)))
@@ -129,8 +129,9 @@
(plugins
(resolve-external-plugins
(optional-string-list tribes-json "plugins" '())))
(disabled-plugins
(optional-string-list tribes-json "disabledPlugins" '()))
(sync-overlap-seconds
(optional-integer tribes-json "syncOverlapSeconds"
(tribes-configuration-sync-overlap-seconds tribes-defaults)))
(database-user
(optional-string tribes-json "databaseUser"
(tribes-configuration-database-user tribes-defaults)))
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 "/boot/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"
"/boot/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/channel-updates.scm
-238
View File
@@ -1,238 +0,0 @@
(define-module (tribes deploy channel-updates)
#:use-module (ice-9 ftw)
#:use-module (ice-9 match)
#:use-module (ice-9 popen)
#:use-module (ice-9 regex)
#:use-module (ice-9 textual-ports)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-13)
#:use-module (srfi srfi-14)
#:use-module (tribes deploy json)
#:export (channel-updates-payload))
(define %semver-tag-rx
(make-regexp "^v[0-9]+\\.[0-9]+\\.[0-9]+([-+][0-9A-Za-z.-]+)?$"))
(define (non-empty-string? value)
(and (string? value) (not (string-null? value))))
(define (trim-trailing-slashes value)
(let loop ((end (string-length value)))
(if (and (> end 0) (char=? (string-ref value (- end 1)) #\/))
(loop (- end 1))
(substring value 0 end))))
(define (normalized-url value)
(and (non-empty-string? value) (trim-trailing-slashes value)))
(define (same-url? left right)
(let ((l (normalized-url left))
(r (normalized-url right)))
(and l r (string=? l r))))
(define (cache-root)
(let ((xdg (getenv "XDG_CACHE_HOME"))
(home (getenv "HOME")))
(cond
((non-empty-string? xdg) (string-append xdg "/guix/checkouts"))
((non-empty-string? home) (string-append home "/.cache/guix/checkouts"))
(else "/root/.cache/guix/checkouts"))))
(define (git-run checkout args)
(let* ((port (apply open-pipe* OPEN_READ "git" "-C" checkout args))
(output (get-string-all port))
(status (close-pipe port)))
(if (zero? status)
(values #t (string-trim-right output))
(values #f (string-trim-right output)))))
(define (git-run* checkout . args)
(call-with-values (lambda () (git-run checkout args))
(lambda (ok? output)
(and ok? output))))
(define (git-success? checkout . args)
(call-with-values (lambda () (git-run checkout args))
(lambda (ok? _output) ok?)))
(define (directory-children path)
(if (file-exists? path)
(filter (lambda (entry) (not (member entry '("." ".."))))
(scandir path))
'()))
(define (git-checkout? path)
(file-exists? (string-append path "/.git")))
(define (checkout-origin-url checkout)
(git-run* checkout "config" "--get" "remote.origin.url"))
(define (find-channel-checkout url)
(let ((root (cache-root)))
(find (lambda (checkout)
(and (git-checkout? checkout)
(same-url? (checkout-origin-url checkout) url)))
(map (lambda (entry) (string-append root "/" entry))
(directory-children root)))))
(define (channel-id channel)
(or (json-ref channel "id")
(json-ref channel "channel_id")
(json-ref channel "channelId")))
(define (channel-name channel)
(or (json-ref channel "name")
(json-ref channel "channel_id")
(json-ref channel "channelId")
"channel"))
(define (channel-url channel)
(json-ref channel "url"))
(define (channel-branch channel)
(or (json-ref channel "branch") "master"))
(define (channel-current-commit channel)
(or (json-ref channel "current_commit")
(json-ref channel "currentCommit")
(json-ref channel "commit")
(json-ref channel "tracked_commit")
(json-ref channel "trackedCommit")))
(define (payload-limit payload)
(let ((value (json-ref payload "limit")))
(if (and (integer? value) (> value 0))
(min value 100)
20)))
(define (payload-mode payload)
(or (json-ref payload "mode") "semver_tags"))
(define (fetch-channel! checkout)
(git-success? checkout "fetch" "--tags" "--prune" "origin"))
(define (branch-ref branch)
(string-append "refs/remotes/origin/" branch "^{commit}"))
(define (resolve-branch-head checkout branch)
(or (git-run* checkout "rev-parse" "--verify" (branch-ref branch))
(git-run* checkout "rev-parse" "--verify" (string-append branch "^{commit}"))))
(define (semver-tag? tag)
(and (string? tag) (regexp-exec %semver-tag-rx tag) #t))
(define (split-output-lines text)
(if (or (not text) (string-null? text))
'()
(string-tokenize text (char-set-complement (char-set #\newline)))))
(define (merged-semver-tags checkout head)
(filter semver-tag?
(split-output-lines
(git-run* checkout "tag" "--list" "v[0-9]*" "--merged" head "--sort=-v:refname"))))
(define (tag-commit checkout tag)
(git-run* checkout "rev-list" "-n" "1" tag))
(define (ancestor? checkout older newer)
(and (non-empty-string? older)
(non-empty-string? newer)
(git-success? checkout "merge-base" "--is-ancestor" older newer)))
(define (candidate-after-current? checkout current commit)
(cond
((not (non-empty-string? current)) #t)
((string=? current commit) #f)
(else (ancestor? checkout current commit))))
(define (commit-field checkout commit format)
(or (git-run* checkout "show" "-s" (string-append "--format=" format) commit) ""))
(define (candidate-payload checkout tag commit)
`(("commit" . ,commit)
("tag" . ,tag)
("short_commit" . ,(commit-field checkout commit "%h"))
("subject" . ,(commit-field checkout commit "%s"))
("message" . ,(commit-field checkout commit "%B"))
("committed_at" . ,(commit-field checkout commit "%cI"))))
(define (semver-candidates checkout head current limit)
(let loop ((tags (merged-semver-tags checkout head))
(candidates '()))
(cond
((or (null? tags) (>= (length candidates) limit))
(reverse candidates))
(else
(let* ((tag (car tags))
(commit (tag-commit checkout tag)))
(if (and commit (candidate-after-current? checkout current commit))
(loop (cdr tags)
(cons (candidate-payload checkout tag commit) candidates))
(loop (cdr tags) candidates)))))))
(define (commit-candidates checkout head current limit)
(let* ((range (if (and (non-empty-string? current)
(ancestor? checkout current head))
(string-append current ".." head)
head))
(commits (split-output-lines
(git-run* checkout "rev-list"
(string-append "--max-count=" (number->string limit))
range))))
(map (lambda (commit)
(candidate-payload checkout #f commit))
commits)))
(define (channel-error-payload channel code message)
`(("id" . ,(channel-id channel))
("name" . ,(channel-name channel))
("url" . ,(or (channel-url channel) ""))
("branch" . ,(channel-branch channel))
("ok" . #f)
("error" . (("code" . ,code) ("message" . ,message)))))
(define (channel-updates channel mode limit)
(let ((url (channel-url channel))
(branch (channel-branch channel))
(current (channel-current-commit channel)))
(cond
((not (non-empty-string? url))
(channel-error-payload channel "invalid_channel" "channel url is required"))
((not (member mode '("semver_tags" "commits")))
(channel-error-payload channel "unsupported_mode" "supported modes are semver_tags and commits"))
(else
(let ((checkout (find-channel-checkout url)))
(cond
((not checkout)
(channel-error-payload channel "checkout_not_found" "no Guix channel checkout matched the channel url"))
((not (fetch-channel! checkout))
(channel-error-payload channel "fetch_failed" "git fetch failed for channel checkout"))
(else
(let ((head (resolve-branch-head checkout branch)))
(if (not head)
(channel-error-payload channel "branch_not_found" "channel branch was not found in checkout")
`(("id" . ,(channel-id channel))
("name" . ,(channel-name channel))
("url" . ,url)
("branch" . ,branch)
("ok" . #t)
("current_commit" . ,current)
("branch_head" . ,head)
("checkout" . ,checkout)
("candidates" . ,(if (string=? mode "commits")
(commit-candidates checkout head current limit)
(semver-candidates checkout head current limit)))))))))))))
(define (channel-updates-payload payload)
(let* ((channels (or (json-list-ref payload "channels") '()))
(mode (payload-mode payload))
(limit (payload-limit payload)))
`(("schemaVersion" . "1")
("ok" . #t)
("mode" . ,mode)
("channels" . ,(map (lambda (channel)
(if (json-object? channel)
(channel-updates channel mode limit)
`(("ok" . #f)
("error" . (("code" . "invalid_channel")
("message" . "channel must be an object"))))))
channels)))))
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
-201
View File
@@ -1,201 +0,0 @@
(define-module (tribes deploy current-guix-worker)
#: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 scripts system reconfigure)
#:use-module (guix store)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-13)
#:export (current-guix-worker-main
realize-system-closure!
realize-service-upgrade-inputs!
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 (realize-store-closures store paths)
"Ensure PATHS and every referenced store item are present in STORE."
(let loop ((pending paths)
(seen '()))
(match pending
(()
#t)
((path . rest)
(if (member path seen)
(loop rest seen)
(begin
;; References may only be known locally after PATH itself has
;; been realized from a substitute or build output.
(ensure-path store path)
(loop (append (references store path) rest)
(cons path seen))))))))
(define realize-store-closures*
(store-lift realize-store-closures))
(define (lowered-gexp-store-paths lowered)
"Return the store paths that LOWERED needs to evaluate without realizing
additional derivations later."
(append (append-map derivation-input-output-paths
(lowered-gexp-inputs lowered))
(lowered-gexp-sources lowered)
(lowered-gexp-load-path lowered)
(lowered-gexp-load-compiled-path lowered)))
(define (local-eval exp)
"Evaluate EXP, a G-Expression, in-place."
(mlet* %store-monad ((lowered (lower-gexp exp))
(_ (built-derivations (lowered-gexp-inputs lowered)))
(_ (realize-store-closures*
(lowered-gexp-store-paths 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 (realize-system-closure! system-path)
"Ensure SYSTEM-PATH and every referenced store item is present locally."
(unless (and (string? system-path) (file-exists? system-path))
(error "system path does not exist" system-path))
(with-store store
(realize-store-closures store (list system-path))))
(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 (service-upgrade-inputs-gexp os)
(let* ((target-services
(shepherd-configuration-services
(service-value
(fold-services (operating-system-services os)
#:target-type shepherd-root-service-type))))
(service-files (map shepherd-service-file target-services)))
#~(parameterize ((current-warning-port (%make-void-port "w")))
(primitive-load #$(upgrade-services-program service-files '() '() '())))))
(define (realize-lowered-file-like! lowered)
(match lowered
((? derivation? drv)
(mbegin %store-monad
(built-derivations (list drv))
(realize-store-closures* (list (derivation->output-path drv)))))
((? string? path)
(realize-store-closures* (list path)))
(_
(with-monad %store-monad
(return #t)))))
(define (realize-file-likes! file-likes)
(match file-likes
(()
(with-monad %store-monad
(return #t)))
((file-like . rest)
(mlet* %store-monad ((lowered (lower-object file-like))
(_ (realize-lowered-file-like! lowered)))
(realize-file-likes! rest)))))
(define (realize-service-upgrade-inputs! config-file)
"Realize the store items needed by the post-switch Shepherd upgrade.
This intentionally runs during prepare, before the system profile is switched.
If substitutes are missing or a large dependency would need local compilation,
the deployment fails while the old generation is still active instead of
stalling halfway through commit."
(let* ((os (load-operating-system config-file))
(target-services
(shepherd-configuration-services
(service-value
(fold-services (operating-system-services os)
#:target-type shepherd-root-service-type))))
(service-files (map shepherd-service-file target-services)))
(with-store store
(run-with-store store
(mlet* %store-monad ((_ (realize-file-likes! service-files))
(lowered (lower-gexp
(service-upgrade-inputs-gexp os)))
(_ (built-derivations
(lowered-gexp-inputs lowered)))
(_ (realize-store-closures*
(lowered-gexp-store-paths lowered))))
(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 COMMAND [ARGS...]~%")
(format (current-error-port)
"Commands: realize-system-closure SYSTEM~%")
(format (current-error-port)
" preload-service-upgrade CONFIG~%")
(format (current-error-port)
" post-switch-activate-and-upgrade GENERATION CONFIG~%")
(exit 64))
(define (current-guix-worker-main args)
(match args
(("realize-system-closure" system-path)
(realize-system-closure! system-path))
(("preload-service-upgrade" config-file)
(realize-service-upgrade-inputs! config-file))
(("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
-144
View File
@@ -1,144 +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
pulled-guix-profile-available?
current-guix-profile-root
current-guix-site-directory
current-guix-compiled-site-directory
current-guix-module-file
current-system-channels-file
call-with-clean-guix-environment
call-with-current-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 (pulled-guix-profile-available?)
(file-exists? (pulled-guix-binary)))
(define system-guix-binary "/run/current-system/profile/bin/guix")
(define default-current-system "/run/current-system")
(define (path-directories)
(string-split (or (getenv "PATH") "") #\:))
(define (guix-on-path)
(search-path (path-directories) "guix"))
(define (current-guix-binary)
(cond
((pulled-guix-profile-available?) (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-site-directory)
(string-append (current-guix-profile-root)
"/share/guile/site/3.0"))
(define (current-guix-compiled-site-directory)
(string-append (current-guix-profile-root)
"/lib/guile/3.0/site-ccache"))
(define (current-guix-module-file relative-path)
(let ((path (string-append (current-guix-site-directory)
"/"
relative-path)))
(unless (file-exists? path)
(error "current Guix profile does not provide required module file"
path))
path))
(define (current-system-channels-file . maybe-current-system)
"Return the channel provenance file recorded by CURRENT-SYSTEM, if present."
(let* ((current-system (if (null? maybe-current-system)
default-current-system
(car maybe-current-system)))
(channels-file (string-append current-system "/channels.scm")))
(and (file-exists? channels-file) channels-file)))
(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"
"GUIX_UNINSTALLED"))
(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 (call-with-current-guix-environment thunk)
"Run THUNK with wrapper load paths replaced by the selected Guix profile.
The local-control command is itself wrapped with packaged Guix modules so it
can bootstrap. Child invocations that evaluate system configuration files must
instead see the pulled channel profile, including the guix-tribes modules that
materialized the active system."
(call-with-clean-guix-environment
(lambda ()
(setenv "GUILE_LOAD_PATH" (current-guix-site-directory))
(let ((compiled (current-guix-compiled-site-directory)))
(when (file-exists? compiled)
(setenv "GUILE_LOAD_COMPILED_PATH" compiled)))
;; The packaged 'guix' command prepends its own module directory unless
;; GUIX_UNINSTALLED is set. Keep the selected profile modules first so
;; channel fixes are actually used by child Guix commands.
(setenv "GUIX_UNINSTALLED" "1")
(thunk))))
(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-current-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 -349
View File
@@ -1,356 +1,58 @@
(define-module (tribes deploy executor)
#:use-module (srfi srfi-1)
#:use-module (ice-9 match)
#: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 built-ins)
#:use-module (tribes plugins discovery)
#: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 (remove-item value items)
(filter (lambda (item) (not (equal? item value))) items))
(define (json-object? value)
(and (list? value) (every pair? value)))
(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 (json-ref object key)
(and (json-object? object)
(let ((entry (assoc key object)))
(and entry (cdr entry)))))
(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-name channel)
(or (json-ref channel "name")
(json-ref channel "guix_name")
(json-ref channel "guixName")
(json-ref channel "channel_id")
(json-ref channel "channelId")
"tribes"))
(define (channel-branch channel)
(or (json-ref channel "branch") "master"))
(define (channel-commit channel)
(or (json-ref channel "commit") ""))
(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 (normalize-fingerprint value)
(and (string? value)
(list->string
(map char-upcase
(filter (lambda (char) (not (char-whitespace? char)))
(string->list value))))))
(define (trusted-signer-fingerprints signers)
(filter-map (lambda (signer) (normalize-fingerprint (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))
("name" . ,(channel-name 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-plugins target)
(filter (lambda (plugin)
(and (json-object? plugin)
(string? (plugin-entry-name plugin))))
(or (json-list-ref target "plugins") '())))
(define (requested-enabled-plugins target)
(filter plugin-entry-enabled? (requested-plugins target)))
(define (plugin-definition name)
(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)))
(tribes-plugin-definitions)))
(define (plugin-definition-dependencies definition)
(let loop ((caps (definition-requires definition))
(deps '()))
(match caps
(() (reverse deps))
((capability . rest)
(cond
((member capability guix-tribes-runtime-provided-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 (normalize-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 (runtime-capability-error)
(and (not (null? guix-tribes-runtime-missing-capabilities))
(resolver-error
"host_capability_missing"
"host and built-in plugin manifests have unsatisfied capabilities"
`(("missing_capabilities" . ,guix-tribes-runtime-missing-capabilities)
("provided_capabilities" . ,guix-tribes-runtime-provided-capabilities)))))
(define (plugin-name-duplicates target)
(duplicates (map plugin-entry-name (requested-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 enabled-plugin-names)
(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)
("enabled" . ,(if (member plugin-name enabled-plugin-names) #t #f))
("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-plugins target))
(trusted-signers (enabled-trusted-signers target))
(requested-names (map plugin-entry-name requested-plugins))
(requested-enabled-names (map plugin-entry-name (requested-enabled-plugins target)))
(duplicate-plugin-names (plugin-name-duplicates target))
(runtime-error (runtime-capability-error))
(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))))
(runtime-error runtime-error)
(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))
(enabled-resolved-names (resolve-plugin-names requested-enabled-names)))
(cond
((resolver-error-object? resolved-names) resolved-names)
((resolver-error-object? enabled-resolved-names) enabled-resolved-names)
(else
(let* ((resolved-channels (map channel->resolved channels))
(resolved-plugins
(map (lambda (name)
(resolved-plugin name channels requested-plugins enabled-resolved-names))
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
-199
View File
@@ -1,199 +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-catalog
helper-backend-pull
helper-backend-build
helper-backend-switch
default-helper-backend
run-catalog!
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-catalog! config #:key (on-frame (lambda (_) #t)))
(run-helper config (list "catalog") #:on-frame on-frame))
(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 catalog pull build switch)
helper-backend?
(catalog helper-backend-catalog) ;; (config on-frame) -> <helper-result>
(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-catalog! config #:on-frame on-frame))
(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
-163
View File
@@ -1,163 +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 channel-updates)
#: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-plugin-catalog
handle-channel-updates
handle-resolve
handle-prepare
handle-commit
handle-rollback
handle-abort
error-payload
validate-channel-updates-input
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-channel-updates-input payload)
(cond
((not (json-object-with-string-keys? payload))
"payload must be a JSON object")
((not (json-list-ref payload "channels"))
"channels must be a JSON array")
(else #f)))
(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-plugin-catalog state helper)
(plugin-catalog-payload state helper))
(define (handle-channel-updates payload)
(let ((err (validate-channel-updates-input payload)))
(cond
(err (values 400 (error-payload "invalid_request" err)))
(else (values 200 (channel-updates-payload payload))))))
(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
-591
View File
@@ -1,591 +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-13)
#: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 default-deploy-directory "/var/lib/tribes/deploy")
(define default-current-system "/run/current-system")
(define default-current-system-channels-snapshot
(string-append default-deploy-directory "/current-system-channels.scm"))
(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 (wait-status->exit-code status)
(cond
((and (integer? status) (status:exit-val status)) => identity)
((and (integer? status) (status:term-sig status))
=> (lambda (signal) (+ 128 signal)))
(else 1)))
(define (open-input-pipe*+stderr command args)
(match (pipe)
((input . output)
(match (primitive-fork)
(0
(dynamic-wind
(const #t)
(lambda ()
(close-port input)
(dup2 (fileno output) 1)
(dup2 (fileno output) 2)
(apply execlp command command args))
(lambda ()
(primitive-exit 127))))
(pid
(close-port output)
(values input pid))))))
(define (capture-status command args)
(format (current-error-port)
"tribes-guix-helper: running command: ~s~%"
(cons command args))
(let ((port pid (open-input-pipe*+stderr command args)))
(let* ((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)))))))
(_ (close-port port))
(status (match (waitpid pid)
((_ . status) status)))
(exit-code (wait-status->exit-code status)))
(format (current-error-port)
"tribes-guix-helper: command exited with status ~s (exit code ~a): ~s~%"
status
exit-code
(cons command args))
(values exit-code
(string-join lines "\n")))))
(define (capture-guix-status command args)
(call-with-clean-guix-environment
(lambda ()
(capture-status command args))))
(define (capture-current-guix-status args)
(call-with-current-guix-environment
(lambda ()
(format (current-error-port)
"tribes-guix-helper: current Guix binary: ~a~%"
(current-guix-binary))
(format (current-error-port)
"tribes-guix-helper: current Guix profile root: ~a~%"
(current-guix-profile-root))
(format (current-error-port)
"tribes-guix-helper: Guix environment: GUIX_UNINSTALLED=~s GUILE_LOAD_PATH=~s GUILE_LOAD_COMPILED_PATH=~s~%"
(getenv "GUIX_UNINSTALLED")
(getenv "GUILE_LOAD_PATH")
(getenv "GUILE_LOAD_COMPILED_PATH"))
(capture-status (current-guix-binary) args))))
(define (write-current-system-channels-snapshot!)
"Write the current system's recorded channel provenance and return its path."
(let ((channels-file (current-system-channels-file default-current-system)))
(and channels-file
(begin
(mkdir-p default-deploy-directory)
(copy-file channels-file default-current-system-channels-snapshot)
default-current-system-channels-snapshot))))
(define (capture-build-guix-status args)
(if (pulled-guix-profile-available?)
(capture-current-guix-status args)
(let ((channels-file (write-current-system-channels-snapshot!)))
(if channels-file
(capture-guix-status
(bootstrap-guix-binary)
(append (list "time-machine" "-C" channels-file "--") args))
(let ((message
(string-append "current system channel provenance is missing: "
default-current-system
"/channels.scm")))
(format (current-error-port) "~a~%" message)
(values 1 message))))))
(define (capture-prepared-guix-status args)
"Run ARGS under the Guix environment used by the last prepare build.
The system profile contains a packaged Guix that may be built from a different
commit than the channel environment used to build the selected generation.
Post-switch activation must keep using the prepare environment; otherwise
re-evaluating service gexps can compute different derivations and start a
local build after the profile has already been switched."
(if (pulled-guix-profile-available?)
(capture-current-guix-status args)
(let ((channels-file
(if (file-exists? default-current-system-channels-snapshot)
default-current-system-channels-snapshot
(write-current-system-channels-snapshot!))))
(if channels-file
(capture-guix-status
(bootstrap-guix-binary)
(append (list "time-machine" "-C" channels-file "--") args))
(let ((message
(string-append "prepared channel provenance is missing: "
default-current-system-channels-snapshot)))
(format (current-error-port) "~a~%" message)
(values 1 message))))))
;; ----- 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 (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 (captured-output-tail captured)
"Return a bounded tail of CAPTURED suitable for failure details."
(let* ((lines (if (string? captured)
(string-split captured #\newline)
'()))
(tail (let loop ((remaining lines)
(count (length lines)))
(if (<= count 120)
remaining
(loop (cdr remaining) (- count 1))))))
(string-join tail "\n")))
(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")))
(define (last-json-line text)
(find (lambda (line)
(let ((trimmed (string-trim-both line)))
(or (string-prefix? "{" trimmed)
(string-prefix? "[" trimmed))))
(reverse (string-split text #\newline))))
(define (current-guix-describe-channels)
(call-with-values
(lambda ()
(capture-current-guix-status (list "describe" "--format=json")))
(lambda (status captured)
(and (zero? status)
(catch #t
(lambda ()
(json-string->scm (or (last-json-line captured) "")))
(lambda _ #f))))))
;; ----- current Guix worker helpers ----------------------------------------
(define (activate-and-upgrade-with-current-guix! generation-path config-file)
"Activate GENERATION-PATH and upgrade Shepherd services with prepared Guix.
This intentionally uses the same channel snapshot as prepare, not necessarily
the packaged Guix in /run/current-system after `switch-generation'."
(let ((script (current-guix-module-file
"tribes/deploy/current-guix-worker.scm")))
(call-with-values
(lambda ()
(capture-prepared-guix-status
(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 (capture-service-upgrade-preload-status config-file)
"Realize post-switch service upgrade inputs for CONFIG-FILE.
Run this under the same Guix environment used for the prepare build. This
keeps expensive or missing build work in the prepare phase, before the system
profile is switched."
(let ((script (current-guix-module-file
"tribes/deploy/current-guix-worker.scm")))
(capture-build-guix-status
(list "repl" "-q" "--"
script
"preload-service-upgrade"
config-file))))
(define (capture-system-closure-preload-status system-path)
"Realize SYSTEM-PATH's full store closure before it becomes active.
`guix system build' realizes the top-level system item. Its referenced store
items may still be absent locally and get fetched or built later when
activation or Shepherd service loading touches them. Keep that work in
prepare so a missing substitute cannot stall the switch phase."
(let ((script (current-guix-module-file
"tribes/deploy/current-guix-worker.scm")))
(capture-build-guix-status
(list "repl" "-q" "--"
script
"realize-system-closure"
system-path))))
(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)
(let ((channels (current-guix-describe-channels)))
(done-frame
`("channels" . ,(or channels #())))
(exit 0)))
(else
(error-frame (classify-pull-error captured)
"guix pull failed"
`(("exit_status" . ,status)))
(exit status))))))
(define (catalog-script-file)
(let ((path (string-append default-deploy-directory "/plugin-catalog.scm")))
(mkdir-p default-deploy-directory)
(call-with-output-file path
(lambda (port)
(display "(use-modules (json) (tribes plugins discovery))\n" port)
(display "(scm->json (tribes-plugin-catalog-payload) (current-output-port))\n" port)
(display "(newline)\n" port)))
path))
(define (cmd-catalog)
(phase-frame "catalog")
(let ((script (catalog-script-file)))
(call-with-values
(lambda ()
(call-with-current-guix-environment
(lambda ()
(capture-status (current-guix-binary)
(list "repl" "-q" "--" script)))))
(lambda (status captured)
(cond
((zero? status)
(call-with-values
(lambda ()
(catch #t
(lambda () (values (json-string->scm (or (last-json-line captured) "")) #f))
(lambda (key . args)
(values #f (format #f "~a: ~s" key args)))))
(lambda (catalog error)
(cond
(error
(error-frame "plugin_catalog_invalid"
"plugin catalog generator returned invalid JSON"
`(("error" . ,error)))
(exit 1))
(else
(done-frame `("catalog" . ,catalog))
(exit 0))))))
(else
(error-frame "plugin_catalog_failed"
"plugin catalog generation failed"
`(("exit_status" . ,status)
("output_tail" . ,(captured-output-tail captured))))
(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-build-guix-status
(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))
"")))
(call-with-values
(lambda ()
(capture-system-closure-preload-status store-path))
(lambda (closure-status closure-captured)
(cond
((zero? closure-status)
(call-with-values
(lambda ()
(capture-service-upgrade-preload-status
(preferred-configuration-file store-path build-config-file)))
(lambda (preload-status preload-captured)
(cond
((zero? preload-status)
(done-frame `("store_path" . ,store-path))
(exit 0))
(else
(error-frame "service_upgrade_preload_failed"
"post-switch service upgrade inputs could not be realized"
`(("exit_status" . ,preload-status)
("output" . ,preload-captured)))
(exit preload-status))))))
(else
(error-frame "system_closure_preload_failed"
"target system closure could not be realized"
`(("exit_status" . ,closure-status)
("output" . ,closure-captured)))
(exit closure-status)))))))
(else
(error-frame "build_failed"
"guix system build failed"
`(("exit_status" . ,status)
("output_tail" . ,(captured-output-tail captured))))
(exit status)))))))
(define (cmd-switch generation-number config-file system-profile-link)
(phase-frame "switching")
(call-with-values
(lambda ()
(capture-current-guix-status
(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)
("output_tail" . ,(captured-output-tail captured))))
(exit status))))))
(define (usage)
(format (current-error-port)
"Usage: tribes-guix-helper catalog~%")
(format (current-error-port)
" | 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
(("catalog") (cmd-catalog))
(("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
-193
View File
@@ -1,193 +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)))
((GET . "/v1/plugins/catalog")
. ,(lambda (_request _body)
(call-with-values (lambda () (handle-plugin-catalog state helper))
json-response)))
((POST . "/v1/channels/updates")
. ,(lambda (request body)
(with-json-body cfg request body
(lambda (payload)
(call-with-values
(lambda () (handle-channel-updates payload))
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
-690
View File
@@ -1,690 +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 current-guix)
#: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
plugin-catalog-payload
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))))))
(define (plugin-catalog-payload state helper)
(let ((result ((helper-backend-catalog helper)
(state-store-config state)
(lambda (_frame) #t))))
(if (helper-result-ok? result)
(let ((catalog (json-ref (helper-result-payload result) "catalog")))
(values 200
`(("schemaVersion" . "2")
("ok" . #t)
("catalog" . ,catalog)
("plugins" . ,(or (json-ref catalog "plugins") #())))))
(values 500 (from-helper-failure 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)
("current_channels" . ,(current-system-channel-pins))
("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 #:key (disabled-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
#:disabled-plugins disabled-plugins)))
(atomic-write-json-file host-config-file updated)))
(define (channel-key channel)
(or (json-ref channel "url")
(json-ref channel "name")
(json-ref channel "channel_id")))
(define (matching-channel channel candidates)
(let ((key (channel-key channel)))
(find (lambda (candidate)
(or (and (json-ref channel "url")
(equal? (json-ref channel "url")
(json-ref candidate "url")))
(and key
(equal? key (channel-key candidate)))))
candidates)))
(define (resolve-pulled-channel-pins plan pulled-channels)
(let ((planned (or (and plan (plan-resolved-channels plan)) '()))
(pulled (cond
((vector? pulled-channels) (vector->list pulled-channels))
((list? pulled-channels) pulled-channels)
(else '()))))
(map (lambda (channel)
(let ((pulled-channel (matching-channel channel pulled)))
(if (and pulled-channel (json-ref pulled-channel "commit"))
(assoc-set channel "commit" (json-ref pulled-channel "commit"))
channel)))
planned)))
(define (channel-field channel key fallback)
(or (json-ref channel key) fallback))
(define (write-scheme-string value port)
(write (or value "") port))
(define (write-channel channel port)
(let* ((name (channel-name channel))
(url (channel-field channel "url" ""))
(branch (channel-field channel "branch" "master"))
(commit (channel-field channel "commit" ""))
(introduction (or (json-ref channel "introduction") '()))
(introduction-commit (json-ref introduction "commit"))
(fingerprint (json-ref introduction "fingerprint")))
(display " (channel\n" port)
(format port " (name '~a)\n" (string->symbol name))
(display " (url " port) (write-scheme-string url port) (display ")\n" port)
(display " (branch " port) (write-scheme-string branch port) (display ")\n" port)
(when (and (string? commit) (not (string=? commit "")))
(display " (commit " port) (write-scheme-string commit port) (display ")\n" port))
(when (and (string? introduction-commit)
(not (string=? introduction-commit ""))
(string? fingerprint)
(not (string=? fingerprint "")))
(display " (introduction\n" port)
(display " (make-channel-introduction\n" port)
(display " " port) (write-scheme-string introduction-commit port) (newline port)
(display " (openpgp-fingerprint\n" port)
(display " " port) (write-scheme-string fingerprint port) (display ")))\n" port))
(display " )" port)))
(define (channel-name channel)
(channel-field channel "name"
(channel-field channel "channel_id" "tribes")))
(define (channel-expression-name expression)
(match expression
(('channel fields ...)
(match (find (match-lambda
(('name _value) #t)
(_ #f))
fields)
(('name ('quote name)) (symbol->string name))
(('name (? symbol? name)) (symbol->string name))
(('name (? string? name)) name)
(_ #f)))
(_ #f)))
(define (read-channel-expressions path)
(catch #t
(lambda ()
(call-with-input-file path
(lambda (port)
(match (read port)
(('list channels ...) channels)
(_ '())))))
(lambda _ '())))
(define (channel-expression-field expression field-name)
(match expression
(('channel fields ...)
(match (find (match-lambda
(((? symbol? name) _value) (eq? name field-name))
(_ #f))
fields)
((_ ('quote value)) (and (symbol? value) (symbol->string value)))
((_ (? symbol? value)) (symbol->string value))
((_ (? string? value)) value)
((_ #f) #f)
(_ #f)))
(_ #f)))
(define (channel-expression->pin expression)
`(("name" . ,(channel-expression-field expression 'name))
("url" . ,(channel-expression-field expression 'url))
("branch" . ,(channel-expression-field expression 'branch))
("commit" . ,(channel-expression-field expression 'commit))))
(define (current-system-channel-pins)
(let ((channels-file (current-system-channels-file)))
(if channels-file
(filter (lambda (pin) (json-ref pin "commit"))
(map channel-expression->pin
(read-channel-expressions channels-file)))
'())))
(define (preserved-channel-expressions path channels)
(let ((channel-names (map channel-name channels)))
(if (member "guix" channel-names)
'()
(filter (lambda (channel)
(equal? (channel-expression-name channel) "guix"))
(read-channel-expressions path)))))
(define (write-channel-expression channel port)
(display " " port)
(write channel port))
(define (ensure-directory path)
(unless (or (string=? path "/") (file-exists? path))
(ensure-directory (dirname path))
(mkdir path)))
(define (write-plan-channels! config plan)
(let* ((channels (or (and plan (plan-resolved-channels plan)) '()))
(path (deploy-config-channels-file config))
(preserved-channels (preserved-channel-expressions path channels)))
(ensure-directory (dirname path))
(call-with-output-file path
(lambda (port)
(display ";; Auto-generated by Tribes local-control from SystemTarget channels.\n" port)
(display "(list\n" port)
(for-each
(lambda (channel)
(write-channel-expression channel port)
(newline port))
preserved-channels)
(for-each
(lambda (channel)
(write-channel channel port)
(newline port))
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))
(disabled-plugins (if plan (plan-disabled-plugins plan) '()))
(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
#:disabled-plugins disabled-plugins)
(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
(when plan (write-plan-channels! cfg plan))
(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
#:disabled-plugins disabled-plugins
#:channels (and plan
(resolve-pulled-channel-pins
plan
(and pull-result
(json-ref (helper-result-payload pull-result)
"channels")))))
(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") '())
#:disabled-plugins
(or (json-string-list-ref existing "disabled_plugins") '())
#:channels
(or (json-list-ref existing "channels") '()))
(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") '()))
(target-disabled-plugins
(or (json-string-list-ref generation "disabled_plugins") '()))
(_ (record-host-config-update! state target-plugins
#:disabled-plugins target-disabled-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
#:disabled-plugins target-disabled-plugins
#:channels
(or (json-list-ref generation "channels") '()))
(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
-158
View File
@@ -1,158 +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
system-target-disabled-plugin-names
plan-plugins
plan-disabled-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
#:key (disabled-plugins '()))
(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
(assoc-set tribes-config "plugins" plugin-names)
"disabledPlugins" disabled-plugins))))
(define (system-target-plugin-names target)
(let ((plugins (or (json-list-ref target "plugins") '())))
(sort
(filter-map
(lambda (plugin)
(and (json-object? plugin)
(let ((name (plugin-entry-name plugin)))
(and (string? name) name))))
plugins)
string<?)))
(define (system-target-disabled-plugin-names target)
(let ((plugins (or (json-list-ref target "plugins") '())))
(sort
(filter-map
(lambda (plugin)
(and (json-object? plugin)
(not (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-disabled-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 ((enabled-entry (assoc "enabled" plugin)))
(and enabled-entry (equal? (cdr enabled-entry) #f)))
(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
-311
View File
@@ -1,311 +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)
(disabled-plugins #f)
(channels #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)) '())
,@(if disabled-plugins `(("disabled_plugins" . ,disabled-plugins)) '())
,@(if channels `(("channels" . ,channels)) '()))))
(state-store-upsert-generation! store generation)
(when (string=? generation-status "active")
(state-store-activate-generation! store store-path))
generation))
tribes/deploy/worker.scm
-254
View File
@@ -1,254 +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"
"aborted"))
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 ci …),
;; (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/(ci/|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/cloud.scm
-78
View File
@@ -1,78 +0,0 @@
(define-module (tribes packages cloud)
#:use-module (gnu packages base)
#:use-module (gnu packages compression)
#:use-module (guix build-system trivial)
#:use-module (guix download)
#:use-module (guix gexp)
#:use-module ((guix licenses) #:prefix license:)
#:use-module (guix packages)
#:export (ovhcloud-cli
scaleway-cli))
(define-public scaleway-cli
(package
(name "scaleway-cli")
(version "2.56.1")
(source
(origin
(method url-fetch)
(uri (string-append
"https://github.com/scaleway/scaleway-cli/releases/download/v"
version "/scaleway-cli_" version "_linux_amd64"))
(sha256
(base32 "0282hhpz524fvs7h89f4x07nhm7xkhqc53fd3zr47fk8yz8519fy"))))
(build-system trivial-build-system)
(arguments
(list
#:modules '((guix build utils))
#:builder
#~(begin
(use-modules (guix build utils))
(let* ((bin (string-append #$output "/bin"))
(scw (string-append bin "/scw")))
(mkdir-p bin)
(copy-file #$source scw)
(chmod scw #o555)
(symlink "scw" (string-append bin "/scaleway-cli"))))))
(home-page "https://github.com/scaleway/scaleway-cli")
(synopsis "Command-line interface for Scaleway")
(description
"Scaleway CLI is a command-line interface for interacting with Scaleway
cloud services. This package installs the @command{scw} binary.")
(supported-systems '("x86_64-linux"))
(license license:asl2.0)))
(define-public ovhcloud-cli
(package
(name "ovhcloud-cli")
(version "0.12.0")
(source
(origin
(method url-fetch)
(uri (string-append
"https://github.com/ovh/ovhcloud-cli/releases/download/v"
version "/ovhcloud-cli_Linux_x86_64.tar.gz"))
(sha256
(base32 "19jypxzzjlshqd0391b01a81d2wckfxi20sz7h29alm59j6j9jsm"))))
(build-system trivial-build-system)
(arguments
(list
#:modules '((guix build utils))
#:builder
#~(begin
(use-modules (guix build utils))
(let ((bin (string-append #$output "/bin")))
(setenv "PATH" #$(file-append gzip "/bin"))
(mkdir-p bin)
(invoke #$(file-append tar "/bin/tar")
"xzf" #$source "ovhcloud")
(install-file "ovhcloud" bin)
(chmod (string-append bin "/ovhcloud") #o555)))))
(native-inputs (list gzip tar))
(home-page "https://github.com/ovh/ovhcloud-cli")
(synopsis "Command-line interface for OVHcloud")
(description
"OVHcloud CLI is a command-line interface for interacting with OVHcloud
services. This package installs the @command{ovhcloud} binary.")
(supported-systems '("x86_64-linux"))
(license license:asl2.0)))
tribes/packages/devtools.scm
-2339
View File
File diff suppressed because it is too large Load Diff
tribes/packages/docker.scm
-73
View File
@@ -1,73 +0,0 @@
(define-module (tribes packages docker)
#:use-module ((guix licenses) #:prefix license:)
#:use-module (guix build-system trivial)
#:use-module (guix gexp)
#:use-module (guix packages)
#:use-module (gnu packages bash)
#:use-module (gnu packages base)
#:use-module (gnu packages certs)
#:use-module (gnu packages gawk)
#:use-module (gnu packages nss)
#:use-module (tribes packages source)
#:export (tribes-debug-docker-package
tribes-debug-package))
(define tribes-debug-package
(tribes-source-package tribes-upstream-source
#:name "tribes-debug"
#:admin-debug-methods? #t))
(define tribes-debug-docker-package
(package
(name "tribes-debug-docker-entrypoint")
(version (package-version tribes-debug-package))
(source #f)
(build-system trivial-build-system)
(arguments
(list
#:builder
(with-imported-modules '((guix build utils))
#~(begin
(use-modules (guix build utils))
(let ((bin (string-append #$output "/bin")))
(mkdir-p bin)
(call-with-output-file (string-append bin "/tribes")
(lambda (port)
(display
(string-append
"#!" #$(file-append bash-minimal "/bin/sh") "\n"
"set -eu\n"
#$(file-append coreutils "/bin/mkdir") " -p /tmp\n"
"export HOME=\"${HOME:-/tmp}\"\n"
"export LANG=\"${LANG:-C.UTF-8}\"\n"
"export LC_ALL=\"${LC_ALL:-C.UTF-8}\"\n"
"export PATH=\""
#$(file-append coreutils "/bin") ":"
#$(file-append grep "/bin") ":"
#$(file-append sed "/bin") ":"
#$(file-append gawk "/bin")
"${PATH:+:$PATH}\"\n"
"export MIX_ENV=\"${MIX_ENV:-prod}\"\n"
"export PHX_SERVER=\"${PHX_SERVER:-true}\"\n"
"export PORT=\"${PORT:-4000}\"\n"
"export RELEASE_DISTRIBUTION=\"${RELEASE_DISTRIBUTION:-none}\"\n"
"export RELEASE_MODE=\"${RELEASE_MODE:-interactive}\"\n"
"export RELEASE_COOKIE=\"${RELEASE_COOKIE:-tribes-e2e-cookie}\"\n"
"export TRIBES_PLUGIN_DIR=\"${TRIBES_PLUGIN_DIR:-"
#$tribes-debug-package
"/plugins}\"\n"
"export SSL_CERT_FILE=\"${SSL_CERT_FILE:-"
#$(file-append nss-certs "/etc/ssl/certs/ca-certificates.crt")
"}\"\n"
"exec " #$tribes-debug-package "/bin/tribes-app \"$@\"\n")
port)))
(chmod (string-append bin "/tribes") #o755))))))
(inputs (list bash-minimal coreutils gawk grep nss-certs sed
tribes-debug-package))
(home-page "https://git.teralink.net/tribes/guix-tribes.git")
(synopsis "Docker entrypoint for the Tribes debug build")
(description
"Small wrapper package used by guix pack to build the debug Tribes Docker
image used by e2e tests.")
(license license:asl2.0)))
tribes/packages/go.scm
+5 -10
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
@@ -21,7 +20,7 @@
name
version
sha256
(go go-1.26)
(go go)
(mod-root ".")
(delete-vendor? #t)
goproxy)
@@ -118,13 +117,9 @@ SOURCE."
(if (string=? #$mod-root ".")
source-dir
(string-append source-dir "/" #$mod-root))
(if #$delete-vendor?
(begin
(when (file-exists? "vendor")
(delete-file-recursively "vendor"))
(invoke "go" "mod" "vendor"))
(unless (file-exists? "vendor")
(error "source does not contain a vendor directory")))
(when (and #$delete-vendor? (file-exists? "vendor"))
(delete-file-recursively "vendor"))
(invoke "go" "mod" "vendor")
(mkdir-p out)
(copy-recursively "vendor" out #:keep-mtime? #t))))
#:options
@@ -143,7 +138,7 @@ SOURCE."
description
license
vendor-sha256
(go go-1.26)
(go go)
(mod-root ".")
(sub-packages '("."))
(build-flags '("-trimpath"))
tribes/packages/kernel.scm
-168
View File
@@ -1,168 +0,0 @@
(define-module (tribes packages kernel)
#:use-module (gnu packages linux)
#:use-module (guix gexp)
#:use-module (guix packages)
#:use-module (guix utils)
#:export (tribes-linux))
(define %tribes-linux-hardening-configs
'(;; Fail closed when the kernel detects internal data-structure corruption
;; instead of trying to continue in an unknown state. For Tribes hosts,
;; availability is handled at the node/deployment level; a loud crash is
;; preferable to silent memory-corruption persistence. This also selects
;; CONFIG_LIST_HARDENED, which provides the cheap linked-list consistency
;; checks we want without the heavier CONFIG_DEBUG_LIST debug machinery.
"CONFIG_BUG_ON_DATA_CORRUPTION=y"
;; Split general kmalloc allocations across randomized slab caches. This
;; raises the cost of heap-spray style kernel exploits while preserving the
;; broad-driver VPS/bare-metal kernel shape; upstream documents the cost as
;; limited memory/CPU overhead, which is acceptable for our server targets.
"CONFIG_RANDOM_KMALLOC_CACHES=y"
;; Compile in software page poisoning so operators can enable
;; `page_poison=1' for suspicious hosts or higher-assurance deployments.
;; It is not active by default, so the normal runtime cost is avoided; Guix
;; already enables init-on-alloc by default, and this gives us an optional
;; stronger freed-page check/sanitization mode when needed.
"CONFIG_PAGE_POISONING=y"
;; Allow CET shadow stacks for userspace on x86_64 CPUs that support them.
;; Applications must opt in, so old userspace is not forced into a new ABI,
;; but hardened runtimes can gain return-address protection against ROP.
"CONFIG_X86_USER_SHADOW_STACK=y"))
(define %tribes-linux-disabled-options
'(;; Keep DRM/KMS enabled so the installer has a local console on generic
;; virtual and real hardware. This costs roughly 15 MiB in the kexec image
;; compared to disabling DRM wholesale, but preserves Proxmox/QEMU VGA and
;; common real-hardware GPU/BMC consoles.
;; No audio output/input stack on Tribes server deployments.
"SOUND"
;; Drop webcams, capture cards, TV/radio tuners, SDR receivers, and remote
;; controls. This keeps storage, networking, USB host, and Wi-Fi intact.
"MEDIA_SUPPORT"
"RC_CORE"
;; Keep ordinary AT/USB keyboards and mice, but drop uncommon local-console
;; input devices that bring many drivers.
"INPUT_JOYSTICK"
"INPUT_TABLET"
"INPUT_TOUCHSCREEN"
"HID_WACOM"
"HID_MULTITOUCH"
;; Targets are USB hosts, not USB devices; USB-IP is also unnecessary for
;; install/operation. Keep USB host, USB storage, HID, and Type-C support.
"USB_GADGET"
"USBIP_CORE"
;; Legacy or non-target interconnects/protocols.
"FIREWIRE"
"BT"
"NFC"
"CAN"
"HAMRADIO"
"ATM"
"ARCNET"
"PHONET"
"INFINIBAND"
;; Non-target network protocols and in-kernel load-balancing stacks. Keep
;; ordinary TCP/UDP/IP, bridge, nftables/netfilter, WireGuard, and Wi-Fi.
"IP_VS"
"ATALK"
"X25"
"LAPB"
"RDS"
"TIPC"
"IP_SCTP"
"AF_KCM"
"MPTCP"
"LLC2"
;; Drop niche overlay/mesh/IoT stacks while keeping Ethernet, Wi-Fi,
;; bridge, VLANs, nftables/netfilter, tunnels, and WireGuard.
"OPENVSWITCH"
"BATMAN_ADV"
"IEEE802154"
"6LOWPAN"
"CAIF"
"MPLS"
;; Cluster/distributed filesystems are not part of the installer or Tribes
;; node runtime. Keep local Linux filesystems and NFS/CIFS available.
"CEPH_FS"
"GFS2_FS"
"OCFS2_FS"
"AFS_FS"
"CODA_FS"
;; Rare local filesystems for our server/text-console targets. Keep ext4,
;; XFS, Btrfs, F2FS, VFAT, exFAT, ISO/UDF, NFS, CIFS, FUSE, and overlayfs.
"JFS_FS"
"NILFS2_FS"
"ZONEFS_FS"
;; Keep local NVMe PCI support, but drop NVMe-over-fabrics clients and
;; target-mode support.
"NVME_FC"
"NVME_TCP"
"NVME_TARGET"
;; Odd local peripherals unrelated to text-console server operation.
"MACINTOSH_DRIVERS"
"FIREWIRE_NOSY"
"USB_APPLEDISPLAY"
"USB_ISIGHTFW"
"USB_IDMOUSE"))
(define tribes-linux/hardened
(customize-linux
#:name "tribes-linux"
#:linux linux-libre
#:extra-version "tribes"
#:configs %tribes-linux-hardening-configs))
(define tribes-linux
(package
(inherit tribes-linux/hardened)
(arguments
(substitute-keyword-arguments (package-arguments tribes-linux/hardened)
((#:phases phases)
#~(modify-phases #$phases
(add-after 'configure 'apply-tribes-slim-config
(lambda _
(use-modules (ice-9 rdelim)
(srfi srfi-1))
(define disabled-options
'#$%tribes-linux-disabled-options)
(define (disabled-line option)
(string-append "# CONFIG_" option " is not set"))
(define config-lines
(call-with-input-file ".config"
(lambda (port)
(let loop ((lines '()))
(let ((line (read-line port)))
(if (eof-object? line)
(reverse lines)
(loop (cons line lines))))))))
(for-each (lambda (option)
(invoke "scripts/config" "--disable" option))
disabled-options)
(invoke "make" "olddefconfig")
(set! config-lines
(call-with-input-file ".config"
(lambda (port)
(let loop ((lines '()))
(let ((line (read-line port)))
(if (eof-object? line)
(reverse lines)
(loop (cons line lines))))))))
(for-each
(lambda (option)
(unless (member (disabled-line option) config-lines)
(error "failed to disable kernel option" option)))
disabled-options)))))))))
tribes/packages/logging.scm
-146
View File
@@ -1,146 +0,0 @@
(define-module (tribes packages logging)
#:use-module (gnu packages autotools)
#:use-module (gnu packages bison)
#:use-module (gnu packages flex)
#:use-module (gnu packages glib)
#:use-module (gnu packages gperf)
#:use-module (gnu packages linux)
#:use-module (gnu packages pcre)
#:use-module (gnu packages perl)
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages python)
#:use-module (gnu packages tls)
#:use-module (gnu packages web)
#:use-module (gnu packages version-control)
#:use-module (gnu packages base)
#:use-module (guix build-system gnu)
#:use-module (guix gexp)
#:use-module (guix git-download)
#:use-module ((guix licenses) #:prefix license:)
#:use-module (guix packages))
(define-public syslog-ng-minimal
(package
(name "syslog-ng-minimal")
(version "4.10.2")
(source
(origin
(method git-fetch)
(uri (git-reference
(url "https://github.com/syslog-ng/syslog-ng")
(commit (string-append "syslog-ng-" version))
(recursive? #t)))
(file-name (git-file-name name version))
(sha256
(base32 "0srqipyqq8xzcj8dgb391b8jdhs2nf6cnviz8hbkipjnj1w86il5"))))
(build-system gnu-build-system)
(arguments
(list
#:tests? #f
#:configure-flags
#~(list
"--disable-fast-install"
"--enable-dynamic-linking"
"--with-ivykis=internal"
"--with-jsonc=system"
"--enable-json=yes"
"--enable-ipv6"
"--enable-linux-caps"
"--disable-python"
"--disable-python-modules"
"--with-python-packages=none"
"--disable-java"
"--disable-java-modules"
"--disable-systemd"
"--disable-http"
"--disable-smtp"
"--disable-mongodb"
"--disable-amqp"
"--disable-stomp"
"--disable-grpc"
"--disable-kafka"
"--disable-afsnmp"
"--disable-geoip2"
"--disable-sql"
"--disable-ebpf"
"--disable-spoof-source"
"--disable-tcp-wrapper"
"--disable-native"
"--disable-manpages"
"--disable-example-modules"
"--without-compile-date")
#:phases
#~(modify-phases %standard-phases
(add-after 'unpack 'bootstrap
(lambda _
(substitute* "scripts/version.sh"
(("/bin/sh") (which "sh")))
(invoke "autoreconf" "-vfi")))
(add-after 'configure 'fix-internal-ivykis-makefile
(lambda _
(substitute* "Makefile"
(((string-append "-L\\$\\(top_builddir\\)/lib/ivykis/src "
"-livykis"))
(string-append "-L$(top_builddir)/lib/ivykis/src/.libs "
"-livykis")))))
(add-after 'build 'fix-internal-ivykis-relink
(lambda _
;; The internal ivykis submodule is built in-tree, but libtool's
;; install-time relink only searches lib/ivykis/src. Point it at
;; the actual build output directory so -livykis can be resolved
;; without adding a separate runtime input.
(for-each (lambda (file)
(substitute* file
(("-L\\./lib/ivykis/src -livykis")
"-L./lib/ivykis/src/.libs -livykis")))
(find-files "." "\\.la$"))))
(add-after 'install 'install-internal-ivykis
(lambda* (#:key outputs #:allow-other-keys)
;; syslog-ng links against the internal ivykis shared library, but
;; upstream's install target does not install it when used as a
;; bundled dependency.
(let* ((libdir (string-append (assoc-ref outputs "out") "/lib"))
(library (car (find-files "lib/ivykis/src/.libs"
"^libivykis\\.so\\.0\\.[0-9]+\\.[0-9]+$")))
(basename (basename library)))
(install-file library libdir)
(with-directory-excursion libdir
(symlink basename "libivykis.so.0")
(symlink basename "libivykis.so")))))
(add-after 'install-internal-ivykis 'remove-python-runtime-hooks
(lambda* (#:key outputs #:allow-other-keys)
;; Python is only a native build tool here. Drop the helper and
;; SCL snippets that would otherwise retain a runtime Python
;; reference despite --disable-python.
(let ((out (assoc-ref outputs "out")))
(delete-file (string-append out "/bin/syslog-ng-update-virtualenv"))
(delete-file (string-append out "/share/syslog-ng/tools/merge-grammar.py"))
(delete-file-recursively
(string-append out "/share/syslog-ng/include/scl/python"))))))))
(native-inputs
(list autoconf
autoconf-archive
automake
bison
flex
gperf
libtool
perl
pkg-config
python
which))
(inputs
(list glib
json-c
libcap
openssl
pcre2
util-linux))
(home-page "https://www.syslog-ng.com/")
(synopsis "System logging daemon")
(description
"syslog-ng is a syslog daemon with flexible sources, filters, parsers, and
file destinations. This Tribes package intentionally omits Python, Java,
systemd journal, database, messaging, cloud, and other remote destination
modules used outside the local node logging path.")
(license (list license:gpl2+ license:lgpl2.1+))))
tribes/packages/mix.scm
+29 -45
View File
@@ -8,12 +8,11 @@
#:use-module (gnu packages bash)
#:use-module (gnu packages base)
#:use-module (gnu packages compression)
#:use-module (gnu packages elixir)
#: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)
#:export (fetch-mix-deps
fetch-npm-deps
mix-release-package))
@@ -43,14 +42,14 @@ SOURCE according to mix.lock."
(define cert-file
(string-append work "/ca-certificates.crt"))
(define hex-lib-dir
(string-append
#$(file-append elixir-hex "/lib/elixir/1.19")
":"
#$(file-append elixir-hex "/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 "/bin")
#$(file-append elixir-hex "/bin")
(list #$(file-append elixir-otp28 "/bin")
#$(file-append elixir-hex-otp28 "/bin")
#$(file-append rebar3 "/bin")
#$(file-append bash-minimal "/bin")
#$(file-append coreutils "/bin")
@@ -110,33 +109,17 @@ SOURCE according to mix.lock."
(mkdir-p out)
(copy-recursively deps-dir out #:follow-symlinks? #t)
;; Keep SCM deps reproducible without making Mix think the checkout is
;; stale. Mix.SCM.Git checks both .git/HEAD and remote.origin.url
;; during later offline builds, so preserve a tiny valid Git directory
;; with just those facts instead of the full fetched repository.
(invoke #$(file-append bash-minimal "/bin/sh")
"-c"
(string-append
"set -eu\n"
"find \"$1\" -type d -name .git -prune -print | "
"while IFS= read -r git_dir; do\n"
" origin=$(git --git-dir=\"$git_dir\" config remote.origin.url || true)\n"
" head=$(cat \"$git_dir/HEAD\")\n"
" rm -rf \"$git_dir\"\n"
" mkdir -p \"$git_dir/objects\" \"$git_dir/refs\"\n"
" printf '%s\\n' \"$head\" > \"$git_dir/HEAD\"\n"
" if [ -n \"$origin\" ]; then\n"
" git config --file \"$git_dir/config\" "
"core.repositoryformatversion 0\n"
" git config --file \"$git_dir/config\" "
"core.filemode false\n"
" git config --file \"$git_dir/config\" core.bare false\n"
" git config --file \"$git_dir/config\" "
"remote.origin.url \"$origin\"\n"
" fi\n"
"done")
"sanitize-git-deps"
out)))
;; Match nixpkgs fetchMixDeps behavior for SCM deps: keep .git/HEAD so
;; Mix still considers the checkout available, but discard the rest of
;; the repository metadata from the fixed-output tree.
(invoke #$(file-append findutils "/bin/find")
out
"-path" "*/.git/*"
"-a" "!" "-name" "HEAD"
"-exec"
#$(file-append coreutils "/bin/rm") "-rf"
"{}"
"+")))
#:options
`(#:hash ,(base32 sha256)
#:hash-algo sha256
@@ -216,7 +199,8 @@ package-lock.json."
(mkdir-p out)
(copy-recursively (string-append plugin-assets-dir "/node_modules")
out)))
out
#:follow-symlinks? #t)))
#:options
`(#:hash ,(base32 sha256)
#:hash-algo sha256
@@ -279,16 +263,16 @@ 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 "/lib/elixir/1.19")
":"
#$(file-append elixir-hex "/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 "/bin")
#$(file-append elixir-hex "/bin")
(list #$(file-append elixir-otp28 "/bin")
#$(file-append elixir-hex-otp28 "/bin")
#$(file-append rebar3 "/bin")
#$(file-append bash-minimal "/bin")
#$(file-append coreutils "/bin")
@@ -328,7 +312,7 @@ MIX-FOD-DEPS as a pre-fetched dependency tree."
(setenv "MIX_ENV" #$mix-env)
(setenv "MIX_TARGET" #$mix-target)
(setenv "MIX_OS_CONCURRENCY_LOCK" "0")
(setenv "MIX_OS_DEPS_COMPILE_PARTITION_COUNT" "6")
(setenv "MIX_OS_DEPS_COMPILE_PARTITION_COUNT" "4")
(setenv "HEX_OFFLINE" "1")
(setenv "MIX_REBAR" #$(file-append rebar3 "/bin/rebar3"))
(setenv "MIX_REBAR3" #$(file-append rebar3 "/bin/rebar3"))
@@ -387,8 +371,8 @@ MIX-FOD-DEPS as a pre-fetched dependency tree."
git-minimal
nss-certs
rebar3
elixir
elixir-hex)
elixir-otp28
elixir-hex-otp28)
native-inputs))
(inputs inputs)
(arguments package-arguments)
tribes/packages/monitoring.scm
-80
View File
@@ -1,80 +0,0 @@
(define-module (tribes packages monitoring)
#:use-module (guix base32)
#:use-module (guix git-download)
#:use-module (guix gexp)
#:use-module (guix packages)
#:use-module ((guix licenses) #:prefix license:)
#:use-module (tribes packages go)
#:export (victoriametrics
vinyl-exporter))
(define-public victoriametrics
(build-go-module
(origin
(method git-fetch)
(uri (git-reference
(url "https://github.com/VictoriaMetrics/VictoriaMetrics")
(commit "v1.143.0")))
(file-name (git-file-name "victoriametrics" "1.143.0"))
(sha256
(base32 "0c6nfnn1lqgdlm5ndacdj471sv7vyy9wv67p1477mmdb1x0nr4rb"))
(modules '((guix build utils)))
(snippet
#~(begin
(use-modules (guix build utils))
(for-each
(lambda (file)
(when (file-exists? file)
(delete-file file)))
'("app/vmui/packages/vmui/web/go.mod"
"app/vmui/packages/vmui/web/main.go"))
(substitute* "go.mod"
(("go 1\\.26\\.[0-9]+") "go 1.26"))
(substitute* "vendor/modules.txt"
(("go 1\\.26\\.[0-9]+") "go 1.26")))))
#:name "victoriametrics"
#:version "1.143.0"
#:vendor-sha256 "0kc1i2whi6fqlh4wzpyrm63s6f89wjbpnvc3hmvbvfj6z870h5ml"
#:delete-vendor? #f
#:sub-packages
'("./app/victoria-metrics"
"./app/vmagent"
"./app/vmbackup"
"./app/vmrestore"
"./app/vmctl")
#:ldflags
'("-s"
"-w"
"-X"
"github.com/VictoriaMetrics/VictoriaMetrics/lib/buildinfo.Version=1.143.0")
#:build-flags '("-trimpath" "-mod=vendor")
#:tests? #f
#:home-page "https://victoriametrics.com/"
#:synopsis "Time series database and monitoring tools"
#:description
"VictoriaMetrics is a time series database and monitoring toolkit. This
package includes the single-node server, vmagent, vmbackup, vmrestore, and
vmctl tools used by Tribes nodes."
#:license license:asl2.0))
(define-public vinyl-exporter
(build-go-module
(origin
(method git-fetch)
(uri (git-reference
(url "https://git.teralink.net/tribes/vinyl_exporter.git")
(commit "v0.2.0")))
(file-name (git-file-name "vinyl_exporter" "0.2.0"))
(sha256
(base32 "13y4kagxbdiwig4pcaqmdbj2prc8i2vpv63k420i9ql692ssm8xw")))
#:name "vinyl-exporter"
#:version "0.2.0"
#:vendor-sha256 "0a7wnm6qxw6ygnhb9jglkqlrm59az6v9spjy82wz8i6f9bdw2yrn"
#:sub-packages '("./cmd/vinyl_exporter")
#:ldflags '("-s" "-w")
#:home-page "https://git.teralink.net/tribes/vinyl_exporter"
#:synopsis "Prometheus exporter for Vinyl Cache"
#:description
"Vinyl Exporter exposes Vinyl Cache counters from vinylstat and HLS viewer
metrics derived from vinyllog."
#:license license:bsd-2))
tribes/packages/node.scm
-117
View File
@@ -1,117 +0,0 @@
(define-module (tribes packages node)
#:use-module (gnu packages compression)
#:use-module (gnu packages libevent)
#:use-module (gnu packages node)
#:use-module (gnu packages tls)
#:use-module (guix download)
#:use-module (guix git-download)
#:use-module (guix packages)
#:use-module (guix utils)
#:export (node-24))
;; Node 24, used by Tribes development shells and by tools that declare a
;; Node 24 engine requirement.
;;
;; This is a version bump of upstream Guix's Node package. Node 24 requires a
;; newer libuv and Brotli than the pinned upstream package currently provides,
;; and its bundled llhttp must be kept because the older Guix replacement does
;; not match Node 24's llhttp ABI.
(define libuv-for-node-24
;; Match Node 24.16.0's bundled deps/uv version.
(package
(inherit libuv-for-node-lts)
(version "1.52.1")
(source
(origin
(method url-fetch)
(uri (string-append "https://dist.libuv.org/dist/v" version
"/libuv-v" version ".tar.gz"))
(sha256
(base32
"1rzrrylgqyjcnjarph3r2h5i3cxjpx7j7svr4bkc0d73wswi3mb6"))))))
(define brotli-for-node-24
;; Node 24 requires brotli/shared_dictionary.h, introduced in 1.1.0.
(package
(inherit brotli)
(version "1.1.0")
(source
(origin
(method git-fetch)
(uri (git-reference
(url "https://github.com/google/brotli")
(commit (string-append "v" version))))
(file-name (git-file-name "brotli" version))
(sha256
(base32
"0cvcq302wpjpd1a2cmxcp9a01lwvc2kkir8vsdb3x11djnxc0nsk"))))
(arguments
(substitute-keyword-arguments (package-arguments brotli)
((#:phases phases)
`(modify-phases ,phases
(delete 'rename-static-libraries)))))))
(define openssl-for-node-24
;; Node 24's Argon2 crypto APIs require OpenSSL with Argon2 KDF support.
;; Keep this local to the package so pinned Guix channels with OpenSSL 3.0
;; still produce an Argon2-capable Node.
(package
(inherit openssl)
(version "3.5.5")
(source
(origin
(inherit (package-source openssl))
(uri (list (string-append "https://www.openssl.org/source/openssl-"
version ".tar.gz")
(string-append "ftp://ftp.openssl.org/source/"
"openssl-" version ".tar.gz")
(string-append "ftp://ftp.openssl.org/source/old/3.5/"
"openssl-" version ".tar.gz")))
(sha256
(base32
"129aphl9yy5xd67cwacf000llkhpi1s8phmlhgws2rcb599r335j"))))))
(define-public node-24
(package
(inherit node)
(name "node")
(version "24.16.0")
(source
(origin
(inherit (package-source node))
(uri (string-append "https://nodejs.org/dist/v" version
"/node-v" version ".tar.gz"))
(sha256
(base32
"0j25mpkmdjn565swb6g4x7myd6k48vfsijnwdpx59jvn70pd64gm"))))
(arguments
(substitute-keyword-arguments (package-arguments node)
((#:phases phases)
`(modify-phases ,phases
(delete 'replace-llhttp-sources)
;; npm 11 ships tar under tar/dist/{esm,commonjs}/write-entry.js,
;; not tar/lib/.
(replace 'ignore-number-of-hardlinks
(lambda* (#:key outputs #:allow-other-keys)
(let ((nm (string-append (assoc-ref outputs "out")
"/lib/node_modules/npm/node_modules")))
(for-each
(lambda (variant)
(let ((file (string-append nm "/tar/dist/"
variant "/write-entry.js")))
(when (file-exists? file)
(substitute* file
(("this.stat.nlink > 1") "false")))))
'("esm" "commonjs")))))))))
(native-inputs
(modify-inputs (package-native-inputs node)
(replace "libuv" libuv-for-node-24)
(replace "brotli" brotli-for-node-24)
(replace "openssl" openssl-for-node-24)))
(inputs
(modify-inputs (package-inputs node)
(replace "libuv" libuv-for-node-24)
(replace "brotli" brotli-for-node-24)
(replace "openssl" openssl-for-node-24)
(delete "llhttp")))))
tribes/packages/npm.scm
-230
View File
@@ -1,230 +0,0 @@
(define-module (tribes packages npm)
#:use-module (guix base32)
#:use-module (guix gexp)
#:use-module (guix packages)
#:use-module (guix build-system trivial)
#:use-module (gnu packages base)
#:use-module (gnu packages bash)
#:use-module (gnu packages compression)
#:use-module (gnu packages node)
#:use-module (gnu packages nss)
#:use-module (gnu packages version-control)
#:export (fetch-npm-deps
npm-binary-package))
;; ---------------------------------------------------------------------------
;; fetch-npm-deps
;;
;; Run `npm ci` in a network-enabled fixed-output derivation against
;; SOURCE/ASSETS-DIR (which must contain package.json + package-lock.json)
;; and return the resulting node_modules tree as a store item. Mirrors the
;; idea of `fetch-mix-deps` (tribes packages mix) for npm. Once the
;; #:sha256 is pinned, all subsequent builds are reproducible and offline.
(define* (fetch-npm-deps source
#:key
(name "npm-deps")
version
sha256
(assets-dir ".")
(omit-dev? #f)
(node node)
(setup-gexp #~(begin)))
"Return a fixed-output node_modules tree for SOURCE/ASSETS-DIR according
to package-lock.json."
(computed-file
(string-append name "-" version)
(with-imported-modules '((guix build utils))
#~(begin
(use-modules (guix build utils))
(define out #$output)
(define work (string-append (getcwd) "/build"))
(define app-dir (string-append work "/app"))
(define assets-subdir (string-append app-dir "/" #$assets-dir))
(define certs-dir
#$(file-append nss-certs "/etc/ssl/certs"))
(define cert-file
(string-append work "/ca-certificates.crt"))
(define path
(string-join
(list #$(file-append node "/bin")
#$(file-append bash-minimal "/bin")
#$(file-append coreutils "/bin")
#$(file-append findutils "/bin")
#$(file-append git-minimal "/bin")
#$(file-append gzip "/bin")
#$(file-append tar "/bin")
(or (getenv "PATH") ""))
":"))
(mkdir-p work)
(copy-recursively #+source app-dir #:follow-symlinks? #t)
(invoke #$(file-append coreutils "/bin/chmod") "-R" "u+w" app-dir)
(invoke #$(file-append bash-minimal "/bin/sh")
"-c"
(string-append
#$(file-append coreutils "/bin/cat")
" "
certs-dir
"/*.pem > "
cert-file))
(setenv "PATH" path)
(setenv "HOME" (string-append work "/home"))
(setenv "XDG_CACHE_HOME" (string-append work "/cache"))
(setenv "npm_config_cache" (string-append work "/npm-cache"))
(setenv "npm_config_userconfig" (string-append work "/npmrc"))
(setenv "SSL_CERT_DIR" certs-dir)
(setenv "SSL_CERT_FILE" cert-file)
(setenv "NODE_ENV" (if #$omit-dev? "production" "development"))
(mkdir-p (getenv "HOME"))
(mkdir-p (getenv "XDG_CACHE_HOME"))
(mkdir-p (getenv "npm_config_cache"))
#$setup-gexp
(with-directory-excursion assets-subdir
(apply invoke
`("npm" "ci"
,@(if #$omit-dev? '("--omit=dev") '("--include=dev"))
"--ignore-scripts"
"--no-audit"
"--no-fund")))
(mkdir-p out)
(copy-recursively (string-append assets-subdir "/node_modules")
out)))
#:options
`(#:hash ,(base32 sha256)
#:hash-algo sha256
#:recursive? #t
#:leaked-env-vars ("http_proxy" "https_proxy"
"LC_ALL" "LC_MESSAGES" "LANG" "COLUMNS"))))
;; ---------------------------------------------------------------------------
;; npm-binary-package
;;
;; Install an npm package (typically the published .tgz, which usually
;; ships a pre-built `dist/`) into $out/lib/node_modules/<install-prefix>/,
;; drop a `node_modules/` tree from FETCH-NPM-DEPS alongside it, and create
;; $out/bin wrappers for each entry in BINARIES.
;;
;; SOURCE may be either:
;; - an .tgz / .tar.gz / .tar tarball (auto-detected), or
;; - an already-extracted directory tree.
;;
;; BINARIES is an alist of (bin-name . relative-js-path-within-install-prefix).
;; PATH-INPUTS is a list of packages whose /bin gets prepended to the
;; wrapper's PATH (e.g. ripgrep for tools that shell out to it).
(define* (npm-binary-package
#:key
name
version
source
node-modules
(binaries '())
(path-inputs '())
(install-prefix #f)
(node node)
(home-page #f)
(synopsis "")
(description "")
license
(build-system trivial-build-system))
(let ((prefix (or install-prefix (string-append name "-" version))))
(package
(name name)
(version version)
(source source)
(build-system build-system)
(arguments
(list
#:modules '((guix build utils))
#:builder
#~(begin
(use-modules (guix build utils)
(ice-9 ftw)
(ice-9 regex))
(define out #$output)
(define lib-root (string-append out "/lib/node_modules"))
(define pkg-dir (string-append lib-root "/" #$prefix))
(define bin-dir (string-append out "/bin"))
(define (looks-like-tarball? p)
(and (string? p)
(or (string-suffix? ".tgz" p)
(string-suffix? ".tar.gz" p)
(string-suffix? ".tar" p))))
;; tar's auto-detection shells out to `gzip` / `xz` etc., so
;; make them resolvable from PATH at build time.
(setenv "PATH"
(string-join
(list #$(file-append gzip "/bin")
#$(file-append coreutils "/bin")
(or (getenv "PATH") ""))
":"))
(mkdir-p lib-root)
(mkdir-p bin-dir)
;; Unpack source into pkg-dir. npm tarballs wrap everything in
;; a "package/" directory; strip it if present.
(if (looks-like-tarball? #$source)
(begin
(mkdir-p pkg-dir)
(invoke #$(file-append tar "/bin/tar")
"-xf" #$source
"-C" pkg-dir
"--strip-components=1"))
(copy-recursively #$source pkg-dir
#:follow-symlinks? #t))
(invoke #$(file-append coreutils "/bin/chmod") "-R" "u+w" pkg-dir)
;; Drop the prefetched node_modules in place.
(let ((nm (string-append pkg-dir "/node_modules")))
(when (file-exists? nm)
(delete-file-recursively nm))
(mkdir-p nm)
(copy-recursively #$node-modules nm
#:follow-symlinks? #t))
;; Create a /bin wrapper for each declared binary. The wrapper
;; invokes node on the target script and prepends PATH-INPUTS.
(let* ((extra-path
(string-join
(list #$@(map (lambda (input)
#~(string-append #$input "/bin"))
path-inputs))
":"))
(path-prefix
(if (string-null? extra-path)
""
(string-append "PATH=\"" extra-path
":$PATH\" "))))
(for-each
(lambda (entry)
(let* ((bin-name (car entry))
(rel-js (cdr entry))
(wrapper (string-append bin-dir "/" bin-name))
(target (string-append pkg-dir "/" rel-js)))
(call-with-output-file wrapper
(lambda (port)
(format port "#!~a/bin/sh~%"
#$(file-append bash-minimal))
(format port "exec env ~a~a ~a \"$@\"~%"
path-prefix
#$(file-append node "/bin/node")
target)))
(chmod wrapper #o755)))
'#$binaries)))))
(inputs (cons* node path-inputs))
(home-page home-page)
(synopsis synopsis)
(description description)
(license license))))
tribes/packages/otp.scm
+76
View File
@@ -0,0 +1,76 @@
(define-module (tribes packages otp)
#:use-module (guix download)
#:use-module (guix git-download)
#:use-module (guix packages)
#:use-module (guix utils)
#:use-module (gnu packages)
#:use-module (gnu packages bash)
#:use-module (gnu packages elixir)
#:use-module (gnu packages erlang)
#:use-module (gnu packages perl)
#:use-module (gnu packages version-control)
#:export (erlang-28
elixir-otp28
elixir-hex-otp28))
(define-public erlang-28
(package
(inherit erlang)
(name "erlang-28")
(version "28.4.1")
(source
(origin
(method git-fetch)
(uri (git-reference
(url "https://github.com/erlang/otp")
(commit (string-append "OTP-" version))))
(file-name (git-file-name name version))
(sha256
(base32
"1lsbmjfraw03d0kcdzmjdjad8b95d630d1jmg8hjklmivc13l6pa"))
(patches (search-patches "erlang-man-path.patch"))))
(native-inputs
`(("perl" ,perl)
("erlang-manpages"
,(origin
(method url-fetch)
(uri (string-append
"https://github.com/erlang/otp/releases/download"
"/OTP-" version "/otp_doc_man_" version ".tar.gz"))
(sha256
(base32
"00simi301qz3ssn71r77jmsyfz8sb61wp7k92j3gh7pq7gmmc40j"))))))))
(define-public elixir-otp28
(package
(inherit elixir)
(name "elixir-otp28")
(version "1.19.5")
(arguments
(substitute-keyword-arguments (package-arguments elixir)
((#:tests? _ #f)
#f)))
(source
(origin
(method url-fetch)
(uri (string-append
"https://github.com/elixir-lang/elixir/archive/refs/tags/v"
version
".tar.gz"))
(file-name (string-append name "-" version ".tar.gz"))
(sha256
(base32
"0dlflwcdx0da09grndgsj2c9k1ix7vq6vaxg4lgaq42bsy5hnx8h"))
(patches (search-patches "elixir-path-length.patch"))))
(inputs
`(("bash-minimal" ,bash-minimal)
("erlang" ,erlang-28)
("rebar3" ,rebar3)
("git" ,git)))))
(define-public elixir-hex-otp28
(package
(inherit elixir-hex)
(name "elixir-hex-otp28")
(inputs
`(("elixir" ,elixir-otp28)))))
tribes/packages/plugins.scm
+219 -593
View File
@@ -1,6 +1,7 @@
(define-module (tribes packages plugins)
#:use-module ((guix licenses) #:prefix license:)
#:use-module (guix build-system trivial)
#:use-module (guix git-download)
#:use-module (guix gexp)
#:use-module (guix packages)
#:use-module (guix records)
@@ -20,8 +21,7 @@
fetch-npm-deps
mix-release-package))
#:use-module ((tribes packages source)
#:select (tribes-package
tribes-source-directory->local-file
#:select (tribes-source-directory->local-file
tribes-upstream-source))
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-13)
@@ -30,18 +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-definition-from-package
tribes-external-plugin-from-package
tribes-plugin-definitions-provided-capabilities
tribes-plugin-definitions-required-capabilities
tribes-plugin-package
tribes-plugin-catalog-file
tribes-external-plugin
tribes-external-plugin?
tribes-external-plugin-name
@@ -119,200 +109,111 @@ tracked in Git."
(default '()))
(external-plugin tribes-plugin-definition-external-plugin))
(define (tribes-plugin-package-metadata package)
(let ((metadata (assoc-ref (package-properties package) 'tribes-plugin)))
(if (and (list? metadata) (every pair? metadata)) metadata '())))
(define* (tribes-plugin-catalog-file plugin-definitions
#:key
(schema-version "1"))
"Return a JSON catalog file describing PLUGIN-DEFINITIONS for node-local UI
and admin API consumption."
(computed-file
"tribes-plugin-catalog.json"
(with-extensions (list guile-json-4)
#~(begin
(use-modules (json)
(srfi srfi-1))
(define (plugin-metadata-ref metadata key fallback)
(let ((entry (assoc key metadata)))
(if entry (cdr entry) fallback)))
(define (json-object? value)
(and (list? value) (every pair? value)))
(define (plugin-metadata-string-list metadata key)
(let ((value (plugin-metadata-ref metadata key '())))
(cond
((and (list? value) (every string? value)) value)
((vector? value) (plugin-metadata-string-list `((,key . ,(vector->list value))) key))
(else '()))))
(define (json-ref object key)
(and (json-object? object)
(let ((entry (assoc key object)))
(and entry (cdr entry)))))
(define (plugin-version-from-package-version version)
"Return the plugin manifest version portion from a Guix package VERSION."
(let ((index (string-contains version "-")))
(if index (substring version 0 index) version)))
(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 '()))))
(define (tribes-external-plugin-from-package package)
"Return a tribes external-plugin record from PACKAGE's plugin metadata
package properties."
(let* ((metadata (tribes-plugin-package-metadata package))
(name (plugin-metadata-ref metadata "slug"
(plugin-metadata-ref metadata "name"
(package-name package))))
(extra-packages
(let ((value (assoc-ref (package-properties package)
'tribes-plugin-extra-packages)))
(if (list? value) value '())))
(extra-services
(let ((value (assoc-ref (package-properties package)
'tribes-plugin-extra-services)))
(if (procedure? value) value (lambda (_node-config) '())))))
(tribes-external-plugin
(name name)
(package package)
(extra-packages extra-packages)
(extra-services extra-services))))
(define plugin-specs
(list #$@(map
(lambda (plugin-definition)
#~(list (cons 'name #$(tribes-plugin-definition-name plugin-definition))
(cons 'package #$(tribes-plugin-definition-package-name plugin-definition))
(cons 'version #$(tribes-plugin-definition-version plugin-definition))
(cons 'synopsis #$(tribes-plugin-definition-synopsis plugin-definition))
(cons 'home-page #$(tribes-plugin-definition-home-page plugin-definition))
(cons 'provides (list #$@(tribes-plugin-definition-provides plugin-definition)))
(cons 'requires (list #$@(tribes-plugin-definition-requires plugin-definition)))))
plugin-definitions)))
(define (tribes-plugin-definition-from-package package)
"Return a plugin definition from PACKAGE's plugin metadata package
properties instead of duplicating manifest fields in per-plugin modules."
(let* ((metadata (tribes-plugin-package-metadata package))
(external-plugin (tribes-external-plugin-from-package package))
(name (tribes-external-plugin-name external-plugin)))
(tribes-plugin-definition
(name name)
(package-name (plugin-metadata-ref metadata "package" (package-name package)))
(version (plugin-metadata-ref metadata "version" (package-version package)))
(synopsis (plugin-metadata-ref metadata "synopsis" (package-synopsis package)))
(home-page (plugin-metadata-ref metadata "homePage" (package-home-page package)))
(provides (plugin-metadata-string-list metadata "provides"))
(requires (plugin-metadata-string-list metadata "requires"))
(external-plugin external-plugin))))
(define plugins
(map
(lambda (plugin-spec)
`(("name" . ,(assoc-ref plugin-spec 'name))
("package" . ,(assoc-ref plugin-spec 'package))
("version" . ,(assoc-ref plugin-spec 'version))
("synopsis" . ,(assoc-ref plugin-spec 'synopsis))
("homePage" . ,(assoc-ref plugin-spec 'home-page))
("provides" . ,(list->vector (assoc-ref plugin-spec 'provides)))
("requires" . ,(list->vector (assoc-ref plugin-spec 'requires)))))
plugin-specs))
(define (tribes-plugin-definitions-provided-capabilities plugin-definitions)
"Return the de-duplicated capability set provided by PLUGIN-DEFINITIONS."
(delete-duplicates
(append-map tribes-plugin-definition-provides plugin-definitions)
string=?))
(call-with-output-file #$output
(lambda (port)
(scm->json
`(("schemaVersion" . ,#$schema-version)
("plugins" . ,(list->vector plugins)))
port)))))))
(define (tribes-plugin-definitions-required-capabilities plugin-definitions)
"Return the de-duplicated capability set required by PLUGIN-DEFINITIONS."
(delete-duplicates
(append-map tribes-plugin-definition-requires plugin-definitions)
string=?))
(define* (tribes-plugin-package plugin-source
#:key
host-package
(reuse-host-libs? #f)
host-source
host-source-directory
mix-deps
mix-deps-sha256
(include-mix-deps? (not reuse-host-libs?))
(compile-mix-deps '())
(build-assets? #f)
(digest-assets? #f)
(native-deps? #f)
asset-deps
asset-deps-sha256
(assets-directory "assets")
asset-build-gexp
name
(version "dev")
(mix-env "prod")
(home-page "https://git.teralink.net/tribes/plugins")
synopsis
description
plugin-id
plugin-slug
(display-name plugin-slug)
(host-api "1")
(provides '())
(requires '())
(enhances-with '())
(extra-packages '())
(extra-services (lambda (_node-config) '())))
"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-host-package
(and reuse-host-libs?
(or host-package tribes-package)))
(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)
;; Plugin builds compile the Tribes host as a Mix dependency
;; under the plugin application's root config. Keep Ash's host
;; domain inclusion check satisfied for that dependency without
;; requiring every plugin source tree to duplicate host config.
(let* ((config-dir (string-append app-dir "/config"))
(config-file (string-append config-dir "/config.exs")))
(mkdir-p config-dir)
(unless (file-exists? config-file)
(call-with-output-file config-file
(lambda (port)
(display "import Config\n" port))))
(let ((port (open-file config-file "a")))
(display
"\nconfig :tribes, :ash_domains, [\n Tribes.Accounts,\n Tribes.Alliance,\n Tribes.Cluster,\n Tribes.ConfigStore.Domain,\n Tribes.Rollout\n]\n"
port)
(close-port port)))))
(source-setup-gexp
(if reuse-host-libs?
#~(begin)
plugin-api-setup-gexp))
#~(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
(and include-mix-deps?
(or mix-deps
(and mix-deps-sha256
(fetch-mix-deps
plugin-source
#:name (string-append name "-mix-deps")
#:version version
#:sha256 mix-deps-sha256
#:setup-gexp source-setup-gexp)))))
(host-release-libs-setup-gexp
(if reuse-host-libs?
#~(let* ((host-lib-dir (string-append #+resolved-host-package "/lib"))
(build-root (string-append app-dir "/_build/" #$mix-env))
(target-lib-dir (string-append build-root "/lib"))
(host-apps-file (string-append build-root "/tribes-host-apps")))
(mkdir-p target-lib-dir)
(let* ((app-files (find-files host-lib-dir "\\.app$" #:directories? #f))
(host-ebin-dirs (map dirname app-files))
(host-apps
(map
(lambda (app-file)
(let* ((app-file-base (basename app-file))
(app-name (substring app-file-base
0
(- (string-length app-file-base) 4)))
(release-dir (dirname (dirname app-file)))
(target-dir (string-append target-lib-dir "/" app-name)))
(unless (file-exists? target-dir)
(symlink release-dir target-dir))
app-name))
app-files)))
(call-with-output-file host-apps-file
(lambda (port)
(write host-apps port)))
(let ((existing-erlang-flags (getenv "ERL_AFLAGS"))
(host-code-path-flags
(string-join
(apply append (map (lambda (dir) (list "-pa" dir)) host-ebin-dirs))
" ")))
(setenv "ERL_AFLAGS"
(if existing-erlang-flags
(string-append host-code-path-flags " " existing-erlang-flags)
host-code-path-flags))))
(let ((existing-erlang-libs (getenv "ERL_LIBS")))
(setenv "ERL_LIBS"
(if existing-erlang-libs
(string-append target-lib-dir ":" existing-erlang-libs)
target-lib-dir)))
(let ((existing-elixir-libs (getenv "GUIX_ELIXIR_LIBS")))
(setenv "GUIX_ELIXIR_LIBS"
(if existing-elixir-libs
(string-append target-lib-dir ":" existing-elixir-libs)
target-lib-dir))))
#~(begin)))
(or mix-deps
(and mix-deps-sha256
(fetch-mix-deps
plugin-source
#:name (string-append name "-mix-deps")
#:version version
#:sha256 mix-deps-sha256
#:setup-gexp plugin-api-setup-gexp))))
(asset-deps-source
(or asset-deps
(and build-assets?
@@ -323,35 +224,21 @@ lib/*/ebin."
#:version version
#:sha256 asset-deps-sha256
#:assets-dir assets-directory
#:setup-gexp source-setup-gexp))))
#:setup-gexp plugin-api-setup-gexp))))
(setup-gexp
(if asset-deps-source
#~(begin
#$source-setup-gexp
#$host-release-libs-setup-gexp
#$plugin-api-setup-gexp
(let* ((assets-dir (string-append work "/app/" #$assets-directory))
(node-modules-dir (string-append assets-dir "/node_modules")))
(mkdir-p assets-dir)
(when (file-exists? node-modules-dir)
(delete-file-recursively node-modules-dir))
(copy-recursively #+asset-deps-source
node-modules-dir)
(invoke "chmod" "-R" "u+w" node-modules-dir)
(invoke "find"
node-modules-dir
"-type" "f"
"-path" "*/.bin/*"
"-exec" "chmod" "+x" "{}" "+")
(let ((bin-dir (string-append node-modules-dir "/.bin")))
(when (file-exists? bin-dir)
(for-each
(lambda (script)
(patch-shebang (canonicalize-path script)
(list #$(file-append node "/bin"))))
(find-files bin-dir))))))
#~(begin
#$source-setup-gexp
#$host-release-libs-setup-gexp)))
node-modules-dir
#:follow-symlinks? #t)
(invoke "chmod" "-R" "u+w" node-modules-dir)))
plugin-api-setup-gexp))
(resolved-asset-build-gexp
(cond
((not build-assets?) #~(begin))
@@ -363,246 +250,101 @@ lib/*/ebin."
(if digest-assets?
#~(invoke "mix"
"run"
"--no-deps-check"
"--no-compile"
"-e"
"Application.put_env(:phoenix, :json_library, JSON); Mix.Task.run(\"phx.digest\", [\"priv/static\", \"-o\", \"priv/static\", \"--no-compile\"])")
#~(begin)))
(native-toolchain-inputs
(if (or native-deps? (not reuse-host-libs?))
(list autoconf
autoconf-wrapper
automake
gcc-toolchain
diffutils
gawk
grep
gnu-make
libtool
linux-libre-headers
m4
perl
pkg-config
sed)
'())))
(let ((built-package
(mix-release-package
plugin-source
#~(begin))))
(mix-release-package
plugin-source
#:mix-fod-deps mix-deps-source
#:name name
#:version version
#:mix-env mix-env
#:home-page home-page
#:synopsis synopsis
#:description description
#:license license:asl2.0
#:native-inputs
(append native-toolchain-inputs
(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 native-toolchain-inputs
(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
(if (or native-deps? (not reuse-host-libs?)) (list automake libtool) '())
(list automake libtool)
#:setup-gexp
#~(begin
#$@(if (or native-deps? (not reuse-host-libs?))
(list
#~(begin
(define kernel-headers-dir
#$(file-append linux-libre-headers "/include"))
(let ((existing-cpath (getenv "CPATH")))
(setenv "CPATH"
(if existing-cpath
(string-append kernel-headers-dir ":" existing-cpath)
kernel-headers-dir)))
(let ((existing-c-include-path (getenv "C_INCLUDE_PATH")))
(setenv "C_INCLUDE_PATH"
(if existing-c-include-path
(string-append kernel-headers-dir ":"
existing-c-include-path)
kernel-headers-dir)))
(setenv "CC" #$(file-append gcc-toolchain "/bin/gcc"))
(setenv "CXX" #$(file-append gcc-toolchain "/bin/g++"))
(setenv "CPP"
(string-append #$(file-append gcc-toolchain "/bin/gcc")
" -E"))))
'())
(define kernel-headers-dir
#$(file-append linux-libre-headers "/include"))
(let ((existing-cpath (getenv "CPATH")))
(setenv "CPATH"
(if existing-cpath
(string-append kernel-headers-dir ":" existing-cpath)
kernel-headers-dir)))
(let ((existing-c-include-path (getenv "C_INCLUDE_PATH")))
(setenv "C_INCLUDE_PATH"
(if existing-c-include-path
(string-append kernel-headers-dir ":"
existing-c-include-path)
kernel-headers-dir)))
(setenv "CC" #$(file-append gcc-toolchain "/bin/gcc"))
(setenv "CXX" #$(file-append gcc-toolchain "/bin/g++"))
(setenv "CPP"
(string-append #$(file-append gcc-toolchain "/bin/gcc")
" -E"))
#$setup-gexp)
#:configure-gexp
(cond
((not reuse-host-libs?) #f)
((null? compile-mix-deps) #~(begin))
(else #~(begin
#$@(map (lambda (dep)
#~(invoke "mix" "deps.compile" #$dep "--no-deps-check"))
compile-mix-deps))))
#:build-gexp
(if reuse-host-libs?
#~(begin
#$resolved-asset-build-gexp
(invoke "mix" "compile" "--no-deps-check" "--no-prune-code-paths" "--no-protocol-consolidation")
#$resolved-asset-digest-gexp)
#~(begin
#$resolved-asset-build-gexp
(invoke "mix" "compile")
(let ((muontrap-dir (string-append "_build/" #$mix-env "/lib/muontrap")))
(when (file-exists? muontrap-dir)
(invoke "test" "-x" (string-append muontrap-dir "/priv/muontrap"))))
#$resolved-asset-digest-gexp))
#~(begin
#$resolved-asset-build-gexp
(invoke "mix" "compile")
#$resolved-asset-digest-gexp)
#:install-gexp
#~(begin
(define (install-common-files)
(mkdir-p out)
(copy-file "manifest.json" (string-append out "/manifest.json"))
(mkdir-p out)
(copy-file "manifest.json" (string-append out "/manifest.json"))
(when (file-exists? "priv")
(copy-recursively "priv"
(string-append out "/priv")
#:follow-symlinks? #t))
(when (file-exists? "priv")
(copy-recursively "priv"
(string-append out "/priv")
#:follow-symlinks? #t))
(when (and (not #$build-assets?)
(or (file-exists? "assets/js")
(file-exists? "assets/css")))
(let ((static-dir (string-append out "/priv/static")))
(mkdir-p static-dir)
(when (file-exists? "assets/js")
(invoke "cp" "-r" "assets/js/." static-dir))
(when (file-exists? "assets/css")
(invoke "cp" "-r" "assets/css/." static-dir)))))
(when (and (not #$build-assets?)
(or (file-exists? "assets/js")
(file-exists? "assets/css")))
(let ((static-dir (string-append out "/priv/static")))
(mkdir-p static-dir)
(when (file-exists? "assets/js")
(invoke "cp" "-r" "assets/js/." static-dir))
(when (file-exists? "assets/css")
(invoke "cp" "-r" "assets/css/." static-dir))))
(define (read-host-apps path)
(if (file-exists? path)
(call-with-input-file path read)
'()))
(define (strip-compiled-lib-artifacts root)
(when (file-exists? root)
(for-each
(lambda (path)
(when (file-exists? path)
(delete-file-recursively path)))
(find-files root "^(consolidated|\\.mix)$" #:directories? #t #:stat lstat))))
(define (copy-filtered-compiled-libs)
(let* ((build-root (string-append "_build/" #$mix-env))
(build-lib-dir (string-append build-root "/lib"))
(host-apps-file (string-append build-root "/tribes-host-apps"))
(host-apps (read-host-apps host-apps-file))
(out-lib-dir (string-append out "/lib")))
(when (file-exists? build-lib-dir)
(mkdir-p out-lib-dir)
(let loop ((app-files (find-files build-lib-dir "\\.app$" #:directories? #f))
(copied '()))
(unless (null? app-files)
(let* ((app-file (car app-files))
(app-file-base (basename app-file))
(app-name (substring app-file-base
0
(- (string-length app-file-base) 4)))
(source-dir (dirname (dirname app-file)))
(target-dir (string-append out-lib-dir "/" app-name)))
(when (and (not (member app-name host-apps))
(not (member app-name copied)))
(copy-recursively source-dir target-dir #:follow-symlinks? #t)
(strip-compiled-lib-artifacts target-dir))
(loop (cdr app-files) (cons app-name copied))))))))
(install-common-files)
(if #$reuse-host-libs?
(copy-filtered-compiled-libs)
(let ((build-lib-dir (string-append "_build/" #$mix-env "/lib")))
(when (file-exists? build-lib-dir)
(copy-recursively build-lib-dir
(string-append out "/lib")
#:follow-symlinks? #t)
(strip-compiled-lib-artifacts (string-append out "/lib")))))))))
(package
(inherit built-package)
(properties
`((tribes-plugin
. (("schemaVersion" . "2")
("id" . ,plugin-id)
("name" . ,plugin-slug)
("slug" . ,plugin-slug)
("displayName" . ,display-name)
("package" . ,name)
("version" . ,(plugin-version-from-package-version version))
("synopsis" . ,synopsis)
("homePage" . ,home-page)
("hostApi" . ,host-api)
("provides" . ,provides)
("requires" . ,requires)
("enhancesWith" . ,enhances-with)))
(tribes-plugin-extra-packages . ,extra-packages)
(tribes-plugin-extra-services . ,extra-services)))))))
(define* (local-tribes-plugin-package directory
#:key
host-package
(reuse-host-libs? #f)
host-source
host-source-directory
mix-deps
mix-deps-sha256
(include-mix-deps? (not reuse-host-libs?))
(compile-mix-deps '())
(build-assets? #f)
(digest-assets? #f)
(native-deps? #f)
asset-deps
asset-deps-sha256
(assets-directory "assets")
asset-build-gexp
name
(version "dev")
(mix-env "prod")
(home-page "https://git.teralink.net/tribes/plugins")
synopsis
description
plugin-id
plugin-slug
(display-name plugin-slug)
(host-api "1")
(provides '())
(requires '())
(enhances-with '())
(extra-packages '())
(extra-services (lambda (_node-config) '())))
"Build DIRECTORY as a standalone Tribes plugin artifact."
(tribes-plugin-package
(plugin-source-directory->local-file directory)
#:host-package host-package
#:reuse-host-libs? reuse-host-libs?
#:host-source host-source
#:host-source-directory host-source-directory
#:mix-deps mix-deps
#:mix-deps-sha256 mix-deps-sha256
#:include-mix-deps? include-mix-deps?
#:compile-mix-deps compile-mix-deps
#:build-assets? build-assets?
#:digest-assets? digest-assets?
#:native-deps? native-deps?
#:asset-deps asset-deps
#:asset-deps-sha256 asset-deps-sha256
#:assets-directory assets-directory
#:asset-build-gexp asset-build-gexp
#:name name
#:version version
#:mix-env mix-env
#:home-page home-page
#:synopsis synopsis
#:description description
#:plugin-id plugin-id
#:plugin-slug plugin-slug
#:display-name display-name
#:host-api host-api
#:provides provides
#:requires requires
#:enhances-with enhances-with
#:extra-packages extra-packages
#:extra-services extra-services))
(when (file-exists? "_build/prod/lib")
(copy-recursively "_build/prod/lib"
(string-append out "/lib")
#:follow-symlinks? #t))))))
(define* (tribes-package-with-external-plugins host-package plugins
#:key
@@ -654,13 +396,6 @@ build."
#~(list (cons 'name #$(tribes-external-plugin-name plugin))
(cons 'path #$(tribes-external-plugin-package plugin))))
plugins)))
(define app-roots
(list
(cons #+host-package "host")
#$@(map (lambda (plugin)
#~(cons #$(tribes-external-plugin-package plugin)
#$(tribes-external-plugin-name plugin)))
plugins)))
(define (json-file->scm file)
(call-with-input-file file json->scm))
@@ -687,8 +422,12 @@ build."
(and (every string? value) value))
(else #f))))
(define cap-rx
(make-regexp "^[a-z][a-z0-9_-]*(\\.[a-z][a-z0-9_-]*)+@[1-9][0-9]*$"))
(define cap-rx (make-regexp "^[a-z][a-z0-9_]*(@[1-9][0-9]*)?$"))
(define (normalize-capability cap)
(if (string-contains cap "@")
cap
(string-append cap "@1")))
(define (validate-capabilities plugin-name field caps)
(for-each
@@ -700,27 +439,29 @@ build."
plugin-name
" -> "
cap))))
caps))
caps))
(define (plugin-manifest-metadata expected-slug path)
(let* ((manifest-path (string-append path "/manifest.json")))
(define (plugin-metadata spec)
(let* ((expected-name (assoc-ref spec 'name))
(path (assoc-ref spec 'path))
(manifest-path (string-append path "/manifest.json")))
(unless (file-exists? manifest-path)
(error "plugin package missing manifest.json" expected-slug path))
(error "plugin package missing manifest.json" expected-name path))
(let* ((manifest (json-file->scm manifest-path))
(id (json-string-ref manifest "id"))
(slug (json-string-ref manifest "slug"))
(display-name (json-string-ref manifest "display_name"))
(name (json-string-ref manifest "name"))
(version (json-string-ref manifest "version"))
(entry-module (json-string-ref manifest "entry_module"))
(plugin-host-api (json-string-ref manifest "host_api"))
(otp-app (json-string-ref manifest "otp_app"))
(provides (json-string-list-ref manifest "provides"))
(requires (json-string-list-ref manifest "requires")))
(provides
(and=> (json-string-list-ref manifest "provides")
(lambda (caps) (map normalize-capability caps))))
(requires
(and=> (json-string-list-ref manifest "requires")
(lambda (caps) (map normalize-capability caps)))))
(unless (and (json-object? manifest)
id
slug
display-name
name
version
entry-module
plugin-host-api
@@ -728,31 +469,24 @@ build."
provides
requires)
(error "plugin manifest failed schema validation"
expected-slug
expected-name
manifest-path))
(unless (string=? slug expected-slug)
(error "plugin package slug does not match manifest slug"
expected-slug
slug))
(unless (string=? name expected-name)
(error "plugin package name does not match manifest name"
expected-name
name))
(unless (string=? plugin-host-api #$host-api)
(error "plugin manifest host_api mismatch"
id
name
plugin-host-api
#$host-api))
(validate-capabilities id "provides" provides)
(validate-capabilities id "requires" requires)
`((id . ,id)
(name . ,slug)
(slug . ,slug)
(display-name . ,display-name)
(validate-capabilities name "provides" provides)
(validate-capabilities name "requires" requires)
`((name . ,name)
(path . ,path)
(provides . ,provides)
(requires . ,requires)))))
(define (plugin-metadata spec)
(plugin-manifest-metadata (assoc-ref spec 'name)
(assoc-ref spec 'path)))
(define (duplicates items)
(delete-duplicates
(filter-map
@@ -761,20 +495,12 @@ build."
item))
items)))
(define (manifest-capabilities path field)
(let* ((manifest (json-file->scm path))
(id (json-string-ref manifest "id"))
(caps (json-string-list-ref manifest field)))
(unless caps
(error "manifest has invalid capability field" path field))
(validate-capabilities id field caps)
caps))
(define (manifest-provides path)
(manifest-capabilities path "provides"))
(define (manifest-requires path)
(manifest-capabilities path "requires"))
(let* ((manifest (json-file->scm path))
(provides (json-string-list-ref manifest "provides")))
(unless provides
(error "host manifest has invalid provides field" path))
(map normalize-capability provides)))
(define (find-host-manifest root)
(let ((matches
@@ -790,27 +516,8 @@ build."
matches)
(error "host package manifest.json not found" root matches))))
(define (find-built-in-plugin-manifests root)
(filter
(lambda (path)
(string-contains path "/plugins/"))
(find-files root
"^manifest\\.json$"
#:directories? #f
#:stat lstat)))
(define (built-in-plugin-metadata manifest-path)
(let* ((plugin-dir
(let ((index (string-rindex manifest-path #\/)))
(if index (substring manifest-path 0 index) ".")))
(manifest (json-file->scm manifest-path))
(slug (json-string-ref manifest "slug")))
(unless slug
(error "built-in plugin manifest missing slug" manifest-path))
(plugin-manifest-metadata slug plugin-dir)))
(define (provider-ids plugins capability)
(map (lambda (plugin) (assoc-ref plugin 'id))
(define (provider-names plugins capability)
(map (lambda (plugin) (assoc-ref plugin 'name))
(filter (lambda (plugin)
(member capability (assoc-ref plugin 'provides)))
plugins)))
@@ -820,8 +527,8 @@ build."
(append-map
(lambda (cap)
(filter (lambda (provider)
(not (string=? provider (assoc-ref plugin 'id))))
(provider-ids plugins cap)))
(not (string=? provider (assoc-ref plugin 'name))))
(provider-names plugins cap)))
(assoc-ref plugin 'requires))))
(define (ordered-plugins plugins)
@@ -829,117 +536,38 @@ build."
(remaining plugins))
(if (null? remaining)
ordered
(let* ((ordered-ids (map (lambda (plugin) (assoc-ref plugin 'id))
ordered))
(let* ((ordered-names (map (lambda (plugin) (assoc-ref plugin 'name))
ordered))
(ready
(filter
(lambda (plugin)
(every (lambda (dep)
(member dep ordered-ids))
(member dep ordered-names))
(plugin-dependencies plugins plugin)))
remaining)))
(if (null? ready)
(error "plugin capability dependency cycle detected"
(map (lambda (plugin)
(assoc-ref plugin 'id))
(assoc-ref plugin 'name))
remaining))
(loop (append ordered ready)
(filter (lambda (plugin)
(not (member plugin ready)))
remaining)))))))
(define app-file-rx (make-regexp "\\.app$"))
(define app-name-rx
(make-regexp "\\{application,[[:space:]\n\r]*'?([A-Za-z0-9_@.-]+)'?"))
(define app-vsn-rx
(make-regexp "\\{vsn,[[:space:]\n\r]*\"([^\"]+)\"\\}"))
(define (regexp-match-submatch rx text index)
(let ((match (regexp-exec rx text)))
(and match (match:substring match index))))
(define (port->string port)
(let loop ((chars '()))
(let ((char (read-char port)))
(if (eof-object? char)
(list->string (reverse chars))
(loop (cons char chars))))))
(define (compiled-app-metadata owner file)
(let* ((content (call-with-input-file file port->string))
(app (regexp-match-submatch app-name-rx content 1))
(vsn (regexp-match-submatch app-vsn-rx content 1)))
(and app
vsn
`((app . ,app)
(version . ,vsn)
(owner . ,owner)
(file . ,file)))))
(define (compiled-apps root owner)
(filter-map
(lambda (file)
(compiled-app-metadata owner file))
(find-files root "\\.app$" #:directories? #f #:stat lstat)))
(define (validate-compiled-app-versions roots)
(let* ((apps
(append-map
(lambda (entry)
(compiled-apps (car entry) (cdr entry)))
roots))
(names (delete-duplicates
(map (lambda (app) (assoc-ref app 'app)) apps))))
(for-each
(lambda (name)
(let* ((matches
(filter (lambda (app)
(string=? name (assoc-ref app 'app)))
apps))
(versions
(delete-duplicates
(map (lambda (app) (assoc-ref app 'version))
matches))))
(when (> (length versions) 1)
(error "compiled OTP application version conflict"
name
(map (lambda (app)
(list (cons 'version (assoc-ref app 'version))
(cons 'owner (assoc-ref app 'owner))
(cons 'file (assoc-ref app 'file))))
matches)))))
names)))
(define host-manifest (find-host-manifest #+host-package))
(define built-in-plugins
(map built-in-plugin-metadata
(find-built-in-plugin-manifests #+host-package)))
(define host-provides (manifest-provides host-manifest))
(define host-requires (manifest-requires host-manifest))
(define plugins (map plugin-metadata plugin-specs))
(define all-plugins (append built-in-plugins plugins))
(define plugin-ids (map (lambda (plugin) (assoc-ref plugin 'id)) all-plugins))
(define duplicate-ids (duplicates plugin-ids))
(define plugin-names (map (lambda (plugin) (assoc-ref plugin 'name)) all-plugins))
(define plugin-names (map (lambda (plugin) (assoc-ref plugin 'name)) plugins))
(define duplicate-names (duplicates plugin-names))
(unless (null? duplicate-ids)
(error "duplicate plugin ids in assembled package" duplicate-ids))
(unless (null? duplicate-names)
(error "duplicate plugin slugs in assembled package" duplicate-names))
(error "duplicate plugin names in assembled package" duplicate-names))
(let ((all-provided
(append host-provides
(append-map (lambda (plugin) (assoc-ref plugin 'provides))
all-plugins))))
(let ((missing-host
(filter (lambda (cap)
(not (member cap all-provided)))
host-requires)))
(unless (null? missing-host)
(error "host capability check failed"
missing-host
all-provided)))
plugins))))
(for-each
(lambda (plugin)
(let ((missing
@@ -953,8 +581,6 @@ build."
all-provided))))
plugins))
(validate-compiled-app-versions app-roots)
(let ((ordered (ordered-plugins plugins)))
(mkdir-p #$output)
(copy-recursively #+host-package #$output #:follow-symlinks? #t)
tribes/packages/sender-runtime.scm
-435
View File
@@ -1,435 +0,0 @@
(define-module (tribes packages sender-runtime)
#:use-module ((guix licenses) #:prefix license:)
#:use-module (guix base32)
#:use-module (guix build-system trivial)
#:use-module (guix download)
#:use-module (guix gexp)
#:use-module (guix packages)
#:use-module (guix utils)
#:use-module (gnu packages admin)
#:use-module (gnu packages algebra)
#:use-module (gnu packages assembly)
#:use-module (gnu packages audio)
#:use-module (gnu packages bash)
#:use-module (gnu packages base)
#:use-module (gnu packages compression)
#:use-module (gnu packages monitoring)
#:use-module (gnu packages mp3)
#:use-module (gnu packages networking)
#:use-module (gnu packages nss)
#:use-module (gnu packages perl)
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages texinfo)
#:use-module (gnu packages tls)
#:use-module (gnu packages video)
#:use-module (gnu packages xiph)
#:use-module (tribes packages monitoring)
#:use-module (tribes packages web)
#:export (sender-ffmpeg
tribes-sender-runtime))
(define-public sender-ffmpeg
(package
(inherit ffmpeg)
(name "sender-ffmpeg")
(version "8.0.2")
(source
(origin
(method url-fetch)
(uri (string-append "https://ffmpeg.org/releases/ffmpeg-"
version ".tar.xz"))
(sha256
(base32 "01cml03fpmfjbn3b220irgi6wv8np49gr1q87mxl4g3068irc5jx"))))
(inputs
(list dav1d
gnutls
opus
lame
libvpx
libx264
x265
soxr
speex
srt
zlib))
(native-inputs
(list bc perl pkg-config texinfo nasm))
(arguments
(substitute-keyword-arguments (package-arguments ffmpeg)
((#:tests? _ #f) #f)
((#:configure-flags _)
#~(list
#$@(if (target-powerpc?)
'("--ignore-tests=checkasm-sw_scale,filter-scale2ref_keep_aspect,sws-floatimg-cmp")
'())
"--enable-gpl"
"--enable-shared"
"--enable-gnutls"
"--enable-libdav1d"
"--enable-libmp3lame"
"--enable-libopus"
"--enable-libsoxr"
"--enable-libspeex"
"--enable-libsrt"
"--enable-libvpx"
"--enable-libx264"
"--enable-libx265"
"--enable-runtime-cpudetect"
"--disable-htmlpages"
"--disable-static"
"--disable-stripping"
#$@(if (target-riscv64?)
'("--extra-cflags=-fPIC")
'())
"--disable-mips32r2"
"--disable-mipsdsp"
"--disable-mipsdspr2"
"--disable-mipsfpu"))))
(synopsis "Headless FFmpeg build for Tribes Sender nodes")
(description
"This FFmpeg variant keeps the codecs and protocols needed by external
Tribes Sender nodes while dropping display, desktop audio, and GPU acceleration
stacks from the default Guix FFmpeg build.")))
(define-public tribes-sender-runtime
(package
(name "tribes-sender-runtime")
(version "0.1.0")
(source #f)
(build-system trivial-build-system)
(arguments
(list
#:builder
(with-imported-modules '((guix build utils))
#~(begin
(use-modules (guix build utils))
(let ((bin (string-append #$output "/bin"))
(share (string-append #$output "/share/tribes-sender-runtime")))
(mkdir-p bin)
(mkdir-p share)
(call-with-output-file (string-append bin "/tribes-sender-runtime")
(lambda (port)
(display
(string-append
"#!" #$(file-append bash-minimal "/bin/sh") "\n"
"set -eu\n"
"\n"
"SHEPHERD=\"" #$(file-append shepherd "/bin/shepherd") "\"\n"
"HERD=\"" #$(file-append shepherd "/bin/herd") "\"\n"
"NODE_EXPORTER=\"" #$(file-append prometheus-node-exporter "/bin/node_exporter") "\"\n"
"VINYLD=\"" #$(file-append vinyl "/sbin/vinyld") "\"\n"
"VINYLSTAT=\"" #$(file-append vinyl "/bin/vinylstat") "\"\n"
"VINYLLOG=\"" #$(file-append vinyl "/bin/vinyllog") "\"\n"
"VINYL_EXPORTER=\"" #$(file-append vinyl-exporter "/bin/vinyl_exporter") "\"\n"
"VMAGENT=\"" #$(file-append victoriametrics "/bin/vmagent") "\"\n"
"CA_CERTS=\"" #$(file-append nss-certs "/etc/ssl/certs/ca-certificates.crt") "\"\n"
"\n"
"PATH=\"" #$(file-append coreutils "/bin") ":" #$(file-append grep "/bin") ":" #$(file-append sed "/bin") "${PATH:+:$PATH}\"\n"
"export PATH\n"
"\n"
"CONFIG_FILE=${TRIBES_SENDER_CONFIG:-/etc/tribes/sender-runtime.env}\n"
"RUN_DIR=${TRIBES_SENDER_RUN_DIR:-/run/tribes-sender-runtime}\n"
"STATE_DIR=${TRIBES_SENDER_STATE_DIR:-/var/lib/tribes-sender-runtime}\n"
"LOG_DIR=${TRIBES_SENDER_LOG_DIR:-/var/log/tribes-sender-runtime}\n"
"SOCKET=$RUN_DIR/shepherd.sock\n"
"PID_FILE=$RUN_DIR/shepherd.pid\n"
"SHEPHERD_CONFIG=$RUN_DIR/shepherd.scm\n"
"VMAGENT_CONFIG=$RUN_DIR/vmagent.yml\n"
"\n"
"usage() {\n"
" cat <<'EOF'\n"
"Usage: tribes-sender-runtime COMMAND [SERVICE]\n"
"\n"
"Commands:\n"
" start Start the private Shepherd and configured services\n"
" stop Stop the private Shepherd and all services\n"
" status Show Shepherd service status\n"
" restart [SVC] Restart one service, or all configured services\n"
" logs Follow the private Shepherd log\n"
" install-boot Install a best-effort host boot hook when supported\n"
"\n"
"Config defaults to /etc/tribes/sender-runtime.env.\n"
"Set TRIBES_SENDER_CONFIG to use another env file.\n"
"EOF\n"
"}\n"
"\n"
"load_config() {\n"
" if [ -r \"$CONFIG_FILE\" ]; then\n"
" set -a\n"
" # shellcheck disable=SC1090\n"
" . \"$CONFIG_FILE\"\n"
" set +a\n"
" fi\n"
"\n"
" TRIBES_SENDER_SERVICES=${TRIBES_SENDER_SERVICES:-node-exporter vinyl vinyl-exporter vmagent}\n"
" TRIBES_NODE_EXPORTER_LISTEN=${TRIBES_NODE_EXPORTER_LISTEN:-127.0.0.1:9100}\n"
" TRIBES_VINYL_NAME=${TRIBES_VINYL_NAME:-tribes-sender}\n"
" TRIBES_VINYL_LISTEN=${TRIBES_VINYL_LISTEN:-0.0.0.0:6081}\n"
" TRIBES_VINYL_BACKEND=${TRIBES_VINYL_BACKEND:-127.0.0.1:4000}\n"
" TRIBES_VINYL_STORAGE=${TRIBES_VINYL_STORAGE:-malloc,1G}\n"
" TRIBES_VINYL_STATE_DIR=${TRIBES_VINYL_STATE_DIR:-$STATE_DIR/vinyl}\n"
" TRIBES_VINYL_EXPORTER_LISTEN=${TRIBES_VINYL_EXPORTER_LISTEN:-127.0.0.1:9131}\n"
" TRIBES_VINYL_EXPORTER_METRICS_PATH=${TRIBES_VINYL_EXPORTER_METRICS_PATH:-/metrics}\n"
" TRIBES_VINYL_EXPORTER_HEALTH_PATH=${TRIBES_VINYL_EXPORTER_HEALTH_PATH:-/-/healthy}\n"
" TRIBES_HLS_PATH_PREFIX=${TRIBES_HLS_PATH_PREFIX:-/sender/hls/streams/}\n"
" TRIBES_HLS_STREAM_COMPONENTS=${TRIBES_HLS_STREAM_COMPONENTS:-1}\n"
" TRIBES_HLS_VIEWER_TTL=${TRIBES_HLS_VIEWER_TTL:-5m}\n"
" TRIBES_VMAGENT_LISTEN=${TRIBES_VMAGENT_LISTEN:-127.0.0.1:8429}\n"
" TRIBES_VMAGENT_REMOTE_WRITE_URL=${TRIBES_VMAGENT_REMOTE_WRITE_URL:-${TRIBES_METRICS_REMOTE_WRITE_URL:-http://127.0.0.1:8428/api/v1/write}}\n"
" TRIBES_VMAGENT_TMP_DATA_PATH=${TRIBES_VMAGENT_TMP_DATA_PATH:-$STATE_DIR/vmagent}\n"
" SSL_CERT_FILE=${SSL_CERT_FILE:-$CA_CERTS}\n"
" export SSL_CERT_FILE\n"
"}\n"
"\n"
"scheme_string() {\n"
" printf '%s' \"$1\" | sed 's/\\\\/\\\\\\\\/g; s/\"/\\\\\"/g; s/^/\"/; s/$/\"/'\n"
"}\n"
"\n"
"normalize_service() {\n"
" case \"$1\" in\n"
" node-exporter|node_exporter) printf '%s\\n' node-exporter ;;\n"
" vinyl) printf '%s\\n' vinyl ;;\n"
" vinyl-exporter|vinyl_exporter) printf '%s\\n' vinyl-exporter ;;\n"
" vmagent) printf '%s\\n' vmagent ;;\n"
" all) printf '%s\\n' node-exporter vinyl vinyl-exporter vmagent ;;\n"
" *) echo \"unknown service: $1\" >&2; return 1 ;;\n"
" esac\n"
"}\n"
"\n"
"start_services_sexp() {\n"
" services=\n"
" for service in $TRIBES_SENDER_SERVICES; do\n"
" for normalized in $(normalize_service \"$service\"); do\n"
" case \" $services \" in\n"
" *\" $normalized \"*) ;;\n"
" *) services=\"$services $normalized\" ;;\n"
" esac\n"
" done\n"
" done\n"
" printf \"'(%s)\" \"$services\"\n"
"}\n"
"\n"
"running() {\n"
" [ -S \"$SOCKET\" ] && \"$HERD\" -s \"$SOCKET\" status root >/dev/null 2>&1\n"
"}\n"
"\n"
"write_vmagent_config() {\n"
" if [ -n \"${TRIBES_VMAGENT_SCRAPE_CONFIG:-}\" ]; then\n"
" VMAGENT_CONFIG=$TRIBES_VMAGENT_SCRAPE_CONFIG\n"
" return\n"
" fi\n"
"\n"
" cat >\"$VMAGENT_CONFIG\" <<EOF\n"
"global:\n"
" scrape_interval: 15s\n"
"scrape_configs:\n"
" - job_name: node-exporter\n"
" static_configs:\n"
" - targets: [\"$TRIBES_NODE_EXPORTER_LISTEN\"]\n"
" - job_name: vinyl-exporter\n"
" static_configs:\n"
" - targets: [\"$TRIBES_VINYL_EXPORTER_LISTEN\"]\n"
"EOF\n"
"}\n"
"\n"
"write_shepherd_config() {\n"
" start_services=$(start_services_sexp)\n"
" cat >\"$SHEPHERD_CONFIG\" <<EOF\n"
"(use-modules (shepherd service))\n"
"\n"
"(register-services\n"
" (list\n"
" (service '(node-exporter)\n"
" #:documentation \"Run Prometheus node_exporter.\"\n"
" #:respawn? #t\n"
" #:start (make-forkexec-constructor\n"
" (list $(scheme_string \"$NODE_EXPORTER\")\n"
" (string-append \"--web.listen-address=\"\n"
" $(scheme_string \"$TRIBES_NODE_EXPORTER_LISTEN\")))\n"
" #:log-file $(scheme_string \"$LOG_DIR/node-exporter.log\"))\n"
" #:stop (make-kill-destructor))\n"
" (service '(vinyl)\n"
" #:documentation \"Run Vinyl Cache.\"\n"
" #:respawn? #t\n"
" #:start (make-forkexec-constructor\n"
" (list $(scheme_string \"$VINYLD\")\n"
" \"-F\"\n"
" \"-n\" $(scheme_string \"$TRIBES_VINYL_STATE_DIR\")\n"
" \"-i\" $(scheme_string \"$TRIBES_VINYL_NAME\")\n"
" \"-b\" $(scheme_string \"$TRIBES_VINYL_BACKEND\")\n"
" \"-a\" $(scheme_string \"$TRIBES_VINYL_LISTEN\")\n"
" \"-s\" $(scheme_string \"$TRIBES_VINYL_STORAGE\")\n"
" \"-p\" \"max_retries=5\")\n"
" #:log-file $(scheme_string \"$LOG_DIR/vinyl.log\"))\n"
" #:stop (make-kill-destructor))\n"
" (service '(vinyl-exporter)\n"
" #:documentation \"Run Vinyl Prometheus exporter.\"\n"
" #:requirement '(vinyl)\n"
" #:respawn? #t\n"
" #:start (make-forkexec-constructor\n"
" (list $(scheme_string \"$VINYL_EXPORTER\")\n"
" (string-append \"-web.listen-address=\" $(scheme_string \"$TRIBES_VINYL_EXPORTER_LISTEN\"))\n"
" (string-append \"-web.telemetry-path=\" $(scheme_string \"$TRIBES_VINYL_EXPORTER_METRICS_PATH\"))\n"
" (string-append \"-web.health-path=\" $(scheme_string \"$TRIBES_VINYL_EXPORTER_HEALTH_PATH\"))\n"
" (string-append \"-vinylstat.path=\" $(scheme_string \"$VINYLSTAT\"))\n"
" (string-append \"-vinyllog.path=\" $(scheme_string \"$VINYLLOG\"))\n"
" (string-append \"-vinyl.workdir=\" $(scheme_string \"$TRIBES_VINYL_STATE_DIR\"))\n"
" (string-append \"-hls.path-prefix=\" $(scheme_string \"$TRIBES_HLS_PATH_PREFIX\"))\n"
" (string-append \"-hls.stream-components=\" $(scheme_string \"$TRIBES_HLS_STREAM_COMPONENTS\"))\n"
" (string-append \"-hls.viewer-ttl=\" $(scheme_string \"$TRIBES_HLS_VIEWER_TTL\"))\n"
" \"-hls.identity.ip-fallback\"\n"
" \"-hls.identity.query-param=vsid\"\n"
" \"-hls.identity.trusted-proxy=127.0.0.1\"\n"
" \"-hls.identity.trusted-proxy=::1\")\n"
" #:log-file $(scheme_string \"$LOG_DIR/vinyl-exporter.log\"))\n"
" #:stop (make-kill-destructor))\n"
" (service '(vmagent)\n"
" #:documentation \"Run vmagent for local metrics scraping.\"\n"
" #:respawn? #t\n"
" #:start (make-forkexec-constructor\n"
" (list $(scheme_string \"$VMAGENT\")\n"
" (string-append \"-httpListenAddr=\" $(scheme_string \"$TRIBES_VMAGENT_LISTEN\"))\n"
" (string-append \"-promscrape.config=\" $(scheme_string \"$VMAGENT_CONFIG\"))\n"
" (string-append \"-remoteWrite.url=\" $(scheme_string \"$TRIBES_VMAGENT_REMOTE_WRITE_URL\"))\n"
" (string-append \"-remoteWrite.tmpDataPath=\" $(scheme_string \"$TRIBES_VMAGENT_TMP_DATA_PATH\")))\n"
" #:environment-variables\n"
" (list (string-append \"SSL_CERT_FILE=\" $(scheme_string \"$SSL_CERT_FILE\")))\n"
" #:log-file $(scheme_string \"$LOG_DIR/vmagent.log\"))\n"
" #:stop (make-kill-destructor))))\n"
"\n"
"(perform-service-action root-service 'daemonize)\n"
"(for-each (lambda (name)\n"
" (start-service (lookup-service name)))\n"
" $start_services)\n"
"EOF\n"
"}\n"
"\n"
"cmd_start() {\n"
" load_config\n"
" mkdir -p \"$RUN_DIR\" \"$STATE_DIR\" \"$LOG_DIR\" \"$TRIBES_VINYL_STATE_DIR\" \"$TRIBES_VMAGENT_TMP_DATA_PATH\"\n"
" if running; then\n"
" echo \"tribes-sender-runtime is already running ($SOCKET)\" >&2\n"
" exit 0\n"
" fi\n"
" rm -f \"$SOCKET\" \"$PID_FILE\"\n"
" write_vmagent_config\n"
" write_shepherd_config\n"
" exec \"$SHEPHERD\" -I -s \"$SOCKET\" -c \"$SHEPHERD_CONFIG\" --pid=\"$PID_FILE\" -l \"$LOG_DIR/shepherd.log\"\n"
"}\n"
"\n"
"cmd_stop() {\n"
" if running; then\n"
" if ! timeout 20 \"$HERD\" -s \"$SOCKET\" stop root; then\n"
" echo \"timed out stopping Shepherd cleanly; killing private Shepherd\" >&2\n"
" if [ -r \"$PID_FILE\" ]; then\n"
" kill \"$(cat \"$PID_FILE\")\" 2>/dev/null || true\n"
" fi\n"
" fi\n"
" else\n"
" echo \"tribes-sender-runtime is not running\" >&2\n"
" fi\n"
"}\n"
"\n"
"cmd_status() {\n"
" if running; then\n"
" \"$HERD\" -s \"$SOCKET\" status\n"
" else\n"
" echo \"tribes-sender-runtime is not running\" >&2\n"
" exit 1\n"
" fi\n"
"}\n"
"\n"
"cmd_restart() {\n"
" if ! running; then\n"
" cmd_start\n"
" fi\n"
" if [ $# -gt 0 ]; then\n"
" service=$(normalize_service \"$1\" | head -n 1)\n"
" \"$HERD\" -s \"$SOCKET\" restart \"$service\"\n"
" else\n"
" load_config\n"
" for service in $TRIBES_SENDER_SERVICES; do\n"
" for normalized in $(normalize_service \"$service\"); do\n"
" \"$HERD\" -s \"$SOCKET\" restart \"$normalized\"\n"
" done\n"
" done\n"
" fi\n"
"}\n"
"\n"
"cmd_logs() {\n"
" mkdir -p \"$LOG_DIR\"\n"
" touch \"$LOG_DIR/shepherd.log\"\n"
" tail -f \"$LOG_DIR/shepherd.log\"\n"
"}\n"
"\n"
"cmd_install_boot() {\n"
" self=${TRIBES_SENDER_RUNTIME_BIN:-/opt/tribes-sender-runtime/bin/tribes-sender-runtime}\n"
" if command -v systemctl >/dev/null 2>&1 && [ -d /etc/systemd/system ]; then\n"
" cat >/etc/systemd/system/tribes-sender-runtime.service <<EOF\n"
"[Unit]\n"
"Description=Tribes Sender Runtime\n"
"After=network-online.target\n"
"Wants=network-online.target\n"
"\n"
"[Service]\n"
"Type=oneshot\n"
"RemainAfterExit=yes\n"
"ExecStart=$self start\n"
"ExecStop=$self stop\n"
"\n"
"[Install]\n"
"WantedBy=multi-user.target\n"
"EOF\n"
" systemctl daemon-reload\n"
" systemctl enable tribes-sender-runtime.service\n"
" echo \"installed systemd boot hook: tribes-sender-runtime.service\"\n"
" elif command -v crontab >/dev/null 2>&1; then\n"
" tmp=$(mktemp)\n"
" crontab -l 2>/dev/null | grep -v 'tribes-sender-runtime start' >\"$tmp\" || true\n"
" printf '@reboot %s start\\n' \"$self\" >>\"$tmp\"\n"
" crontab \"$tmp\"\n"
" rm -f \"$tmp\"\n"
" echo \"installed crontab @reboot hook\"\n"
" else\n"
" echo \"no supported boot hook found; add this to your provider startup script:\" >&2\n"
" echo \"$self start\" >&2\n"
" fi\n"
"}\n"
"\n"
"command=${1:-}\n"
"case \"$command\" in\n"
" start) shift; cmd_start \"$@\" ;;\n"
" stop) shift; cmd_stop \"$@\" ;;\n"
" status) shift; cmd_status \"$@\" ;;\n"
" restart) shift; cmd_restart \"$@\" ;;\n"
" logs) shift; cmd_logs \"$@\" ;;\n"
" install-boot) shift; cmd_install_boot \"$@\" ;;\n"
" -h|--help|help) usage ;;\n"
" *) usage >&2; exit 2 ;;\n"
"esac\n")
port)))
(chmod (string-append bin "/tribes-sender-runtime") #o755)
(call-with-output-file (string-append share "/sender-runtime.env.example")
(lambda (port)
(display
(string-append
"TRIBES_SENDER_SERVICES=\"node-exporter vinyl vinyl-exporter vmagent\"\n"
"TRIBES_METRICS_REMOTE_WRITE_URL=\"https://cluster.example/api/v1/write\"\n"
"TRIBES_VINYL_LISTEN=\"0.0.0.0:6081\"\n"
"TRIBES_VINYL_BACKEND=\"127.0.0.1:4000\"\n"
"TRIBES_VINYL_STORAGE=\"malloc,1G\"\n"
"TRIBES_NODE_EXPORTER_LISTEN=\"127.0.0.1:9100\"\n"
"TRIBES_VINYL_EXPORTER_LISTEN=\"127.0.0.1:9131\"\n"
"TRIBES_VMAGENT_LISTEN=\"127.0.0.1:8429\"\n")
port))))))))
(inputs
(list bash-minimal coreutils grep nss-certs sed shepherd
prometheus-node-exporter victoriametrics vinyl vinyl-exporter))
(home-page "https://git.teralink.net/tribes/guix-tribes.git")
(synopsis "Launcher for external Tribes Sender runtime nodes")
(description
"This package provides the tribes-sender-runtime command, a small launcher
that starts a private GNU Shepherd supervising the runtime daemons used by
external Tribes Sender nodes.")
(license license:asl2.0)))
tribes/packages/source.scm
+11 -151
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)
@@ -26,35 +25,34 @@
fetch-npm-deps
local-tribes-package
tribes-package
tribes-plugin-api-package
tribes-mix-deps
tribes-upstream-source
tribes-source-package
tribes-source-directory->local-file))
;; Recursive sha256 of the raw deps tree produced by `mix deps.get --only prod`
;; from the current Tribes mix.lock, with git metadata minimized for SCM
;; dependencies.
;; from the current Tribes mix.lock, with git metadata stripped except for
;; .git/HEAD in SCM dependencies.
(define %tribes-raw-mix-deps-sha256
"1b6hwd2ii5323d4a4dq57dr6g5vnjn16c7bfffc7f8j6l2kmy93x")
"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
"158k8zlmzv6y1abhqj20l14y172ndw1y4p5yr51jpf12a5gs4193")
"1jzfsh3d2h6f30dq9i9kb13zglvifk7ap8inm106plamc1rmajbj")
;; Recursive sha256 of assets/node_modules generated from assets/package-lock.json
;; in an isolated build environment, with local file dependencies resolved from
;; the vendored Mix dependency tree.
(define %tribes-npm-deps-sha256
"18fzdwirgsq14ncd8xy1yyiyjhp0msf5qv51zhml0rgn2lqg6rg8")
"1my46nw162265y8xh0xxfhbm3hd1d9vj3nkd9s1nrrida66siw91")
(define %tribes-home-page
"https://git.teralink.net/tribes/tribes.git")
(define %tribes-commit
"f096578ec153342b29abfc5e900a82aefa378cb7")
"497c02d3b84fdb6f4289ad2276638fb557b90572")
(define %tribes-revision "1")
@@ -62,7 +60,7 @@
(git-version "0.2.0" %tribes-revision %tribes-commit))
(define %tribes-source-sha256
"0hcrf3b8ddp6a65si92slr3vrnvib855h4pyccgrsk10q34qapas")
"0118rdpnpn3qnm3r7v9fhys760sq1nw9590z41ly6ydj4zwyyb9m")
(define %tribes-upstream-source
(origin
@@ -309,7 +307,6 @@ resolution by injecting extra pre-fetched sources needed for offline builds."
(npm-deps-sha256 %tribes-npm-deps-sha256)
(name "tribes")
(version %tribes-version)
(admin-debug-methods? #f)
(home-page %tribes-home-page)
(synopsis "Tribes social app")
(description
@@ -317,8 +314,7 @@ resolution by injecting extra pre-fetched sources needed for offline builds."
production Elixir release using vendored Mix and npm dependency trees."))
"Return a Guix package that builds a production Tribes release from SOURCE,
using MIX-DEPS and NPM-DEPS as pre-fetched dependency trees resolved from
mix.lock and assets/package-lock.json. When ADMIN-DEBUG-METHODS? is true,
compile admin-only debug methods into the release for e2e test images."
mix.lock and assets/package-lock.json."
(let* ((mix-deps-source
(or mix-deps
(tribes-mix-deps source
@@ -388,8 +384,6 @@ compile admin-only debug methods into the release for e2e test images."
(string-append kernel-headers-dir ":"
existing-c-include-path)
kernel-headers-dir)))
(setenv "TRIBES_ADMIN_DEBUG_METHODS"
#$(if admin-debug-methods? "1" "0"))
(setenv "CC" #$(file-append gcc-toolchain "/bin/gcc"))
(setenv "CXX" #$(file-append gcc-toolchain "/bin/g++"))
(setenv "CPP"
@@ -417,15 +411,6 @@ compile admin-only debug methods into the release for e2e test images."
#~(begin
(invoke "mix" "compile")
(when (file-exists? "plugins")
(for-each
(lambda (mix-file)
(with-directory-excursion
(let ((index (string-rindex mix-file #\/)))
(if index (substring mix-file 0 index) "."))
(invoke "mix" "compile")))
(find-files "plugins" "^mix\\.exs$")))
(let ((assets-node-modules "assets/node_modules"))
(when (file-exists? assets-node-modules)
(delete-file-recursively assets-node-modules))
@@ -477,62 +462,20 @@ compile admin-only debug methods into the release for e2e test images."
(invoke "mix" "phx.digest"))
#:install-gexp
#~(begin
(use-modules (ice-9 regex))
(define otp-app-rx
(make-regexp "\"otp_app\"[[:space:]]*:[[:space:]]*\"([^\"]+)\""))
(define (port->string port)
(let loop ((chars '()))
(let ((char (read-char port)))
(if (eof-object? char)
(list->string (reverse chars))
(loop (cons char chars))))))
(define (manifest-otp-app plugin-dir fallback)
(let ((manifest-path (string-append plugin-dir "/manifest.json")))
(if (file-exists? manifest-path)
(let* ((content (call-with-input-file manifest-path port->string))
(match (regexp-exec otp-app-rx content)))
(if match (match:substring match 1) fallback))
fallback)))
(invoke "mix" "release" "--path" out)
(let ((launcher (string-append out "/bin/tribes"))
(launcher-app (string-append out "/bin/tribes-app")))
(let ((launcher (string-append out "/bin/" #$name))
(launcher-app (string-append out "/bin/" #$name "-app")))
(when (file-exists? launcher)
(rename-file launcher launcher-app)))
(when (file-exists? "plugins")
(copy-recursively "plugins"
(string-append out "/plugins")
#:follow-symlinks? #t)
(for-each
(lambda (mix-file)
(let* ((plugin-dir
(let ((index (string-rindex mix-file #\/)))
(if index (substring mix-file 0 index) ".")))
(plugin-name
(let ((index (string-rindex plugin-dir #\/)))
(if index
(substring plugin-dir (+ index 1))
plugin-dir)))
(otp-app (manifest-otp-app plugin-dir plugin-name))
(compiled-ebin
(string-append "_build/prod/lib/" otp-app "/ebin"))
(plugin-ebin
(string-append out "/plugins/" plugin-name "/ebin")))
(when (file-exists? compiled-ebin)
(copy-recursively compiled-ebin
plugin-ebin
#:follow-symlinks? #t))))
(find-files "plugins" "^mix\\.exs$")))))))
#:follow-symlinks? #t))))))
(define* (local-tribes-package directory
#:key
(version "dev")
(admin-debug-methods? #f)
(mix-deps-sha256 #f)
(raw-mix-deps-sha256 #f)
(npm-deps-sha256 #f))
@@ -542,95 +485,12 @@ package pin."
(tribes-source-package
(tribes-source-directory->local-file directory)
#:version version
#:admin-debug-methods? admin-debug-methods?
#:mix-deps-sha256 (or mix-deps-sha256 %tribes-mix-deps-sha256)
#:raw-mix-deps-sha256
(or raw-mix-deps-sha256 %tribes-raw-mix-deps-sha256)
#:npm-deps-sha256
(or npm-deps-sha256 %tribes-npm-deps-sha256)))
(define (tribes-plugin-api-source source version)
"Return the tribes_plugin_api subproject source, with the root lockfile copied
beside its mix.exs for offline dependency resolution."
(computed-file
(string-append "tribes-plugin-api-source-" version)
(with-imported-modules '((guix build utils))
#~(begin
(use-modules (guix build utils))
(define source #+source)
(copy-recursively (string-append source "/tribes_plugin_api")
#$output
#:follow-symlinks? #t)
(copy-file (string-append source "/mix.lock")
(string-append #$output "/mix.lock"))))))
(define* (tribes-plugin-api-package-from-source source
#:key
(mix-deps #f)
(mix-deps-sha256
%tribes-mix-deps-sha256)
(raw-mix-deps-sha256
%tribes-raw-mix-deps-sha256)
(version "0.1.0"))
"Return a Guix package for the standalone tribes_plugin_api Mix package."
(let* ((api-source (tribes-plugin-api-source source version))
(mix-deps-source
(or mix-deps
(tribes-mix-deps source
#:name "tribes-plugin-api-mix-deps"
#:version version
#:sha256 mix-deps-sha256
#:raw-sha256 raw-mix-deps-sha256))))
(mix:mix-release-package
api-source
#:mix-fod-deps mix-deps-source
#:name "tribes-plugin-api"
#:version version
#:home-page %tribes-home-page
#:synopsis "Public API package for Tribes plugins"
#:description
"tribes_plugin_api is the public compile-time contract for Tribes plugins."
#:license license:asl2.0
#:native-inputs (list gcc-toolchain gnu-make linux-libre-headers)
#:path-inputs (list gcc-toolchain gnu-make)
#:setup-gexp
#~(begin
(define kernel-headers-dir
#$(file-append linux-libre-headers "/include"))
(let ((existing-cpath (getenv "CPATH")))
(setenv "CPATH"
(if existing-cpath
(string-append kernel-headers-dir ":" existing-cpath)
kernel-headers-dir)))
(let ((existing-c-include-path (getenv "C_INCLUDE_PATH")))
(setenv "C_INCLUDE_PATH"
(if existing-c-include-path
(string-append kernel-headers-dir ":"
existing-c-include-path)
kernel-headers-dir)))
(setenv "CC" #$(file-append gcc-toolchain "/bin/gcc"))
(setenv "CXX" #$(file-append gcc-toolchain "/bin/g++")))
#:configure-gexp
#~(invoke "mix" "deps.compile" "--skip-umbrella-children")
#:build-gexp
#~(invoke "mix" "compile" "--no-protocol-consolidation")
#:install-gexp
#~(begin
(use-modules (guix build utils))
(let ((source-dir "_build/prod/lib/tribes_plugin_api")
(target-dir (string-append out "/lib/tribes_plugin_api")))
(mkdir-p (dirname target-dir))
(copy-recursively source-dir target-dir #:follow-symlinks? #t)
(for-each
(lambda (path)
(when (file-exists? path)
(delete-file-recursively path)))
(find-files target-dir "^(consolidated|\\.mix)$" #:directories? #t #:stat lstat)))))))
(define tribes-package
(tribes-source-package %tribes-upstream-source
#:version %tribes-version))
(define tribes-plugin-api-package
(tribes-plugin-api-package-from-source %tribes-upstream-source))
tribes/packages/web.scm
+90 -94
View File
@@ -2,14 +2,13 @@
#:use-module (gnu packages)
#:use-module (gnu packages bash)
#:use-module (gnu packages base)
#:use-module (gnu packages compression)
#:use-module (gnu packages crypto)
#:use-module (gnu packages curl)
#:use-module (gnu packages jemalloc)
#:use-module (gnu packages libevent)
#:use-module (gnu packages linux)
#:use-module (gnu packages lua)
#:use-module (gnu packages lsof)
#:use-module (gnu packages ncurses)
#:use-module (gnu packages pcre)
#:use-module (gnu packages perl)
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages python)
#:use-module (gnu packages python-xyz)
@@ -18,7 +17,6 @@
#:use-module (gnu packages tls)
#:use-module ((guix licenses) #:prefix license:)
#:use-module (guix base32)
#:use-module (guix build-system cmake)
#:use-module (guix build-system gnu)
#:use-module (guix download)
#:use-module (guix gexp)
@@ -26,89 +24,97 @@
#:use-module (guix packages)
#:use-module (guix utils)
#:use-module (tribes packages go)
#:export (aws-lc-for-haproxy
haproxy
#:export (hitch
vinyl
lego))
(define-public aws-lc-for-haproxy
(define-public hitch
(package
(name "aws-lc")
(version "1.73.0")
(source
(origin
(method url-fetch)
(uri (string-append "https://codeload.github.com/aws/aws-lc/tar.gz/refs/tags/v"
version))
(file-name (string-append name "-" version ".tar.gz"))
(sha256
(base32 "1qycxd03bvj3wlbb0r6518k3r0fqi0hbcs0gj0xb5mq9gngfhfp3"))))
(build-system cmake-build-system)
(native-inputs (list perl))
(arguments
(list
#:configure-flags
#~(list "-DBUILD_SHARED_LIBS=ON"
"-DBUILD_TESTING=OFF"
"-DDISABLE_GO=ON")
#:tests? #f))
(home-page "https://github.com/aws/aws-lc")
(synopsis "General purpose cryptographic library for HAProxy")
(description "AWS-LC contains portable C implementations of cryptographic
algorithms needed for TLS and common applications, with optimized assembly
versions for x86 and ARM. This variant is kept in guix-tribes for HAProxy
QUIC support.")
(license license:asl2.0)))
(define-public haproxy
(package
(name "haproxy")
(version "3.3.10")
(source
(origin
(method url-fetch)
(uri (string-append "https://www.haproxy.org/download/"
(version-major+minor version)
"/src/haproxy-" version ".tar.gz"))
(sha256
(base32 "1wlid1j3xdg99xldsha6026ilpxkxjh5vr0axwb58mrs7yhikaba"))))
(name "hitch")
(version "1.8.0")
(home-page "https://hitch-tls.org/")
(build-system gnu-build-system)
(arguments
(list
#:tests? #f ; there are only regression tests, using varnishtest
#:make-flags
#~(list "LUA_LIB_NAME=lua"
"TARGET=linux-glibc"
"USE_LINUX_CAP=1"
"USE_LUA=1"
"USE_OPENSSL_AWSLC=1"
"USE_PCRE2=1"
"USE_PCRE2_JIT=1"
"USE_PROMEX=1"
"USE_QUIC=1"
"USE_ZLIB=1"
(string-append "CC=" #$(cc-for-target))
(string-append "DOCDIR=" #$output "/share/" #$name)
(string-append "LUA_INC=" #$(this-package-input "lua") "/include")
(string-append "LUA_LIB=" #$(this-package-input "lua") "/lib")
(string-append "SSL_INC=" #$(this-package-input "aws-lc") "/include")
(string-append "SSL_LIB=" #$(this-package-input "aws-lc") "/lib")
(string-append "PREFIX=" #$output))
#:phases
#~(modify-phases %standard-phases
(delete 'configure))))
`(#:phases
(modify-phases %standard-phases
(add-before 'check 'pre-check
(lambda _
;; Our grep is compiled without perl regexp support. Rewrite the
;; command to not use it. Literal tabs are supported only in perl
;; regexps, so inject one with printf instead.
(substitute* "src/tests/test32-proxy-authority.sh"
(("grep -Pq") "grep -q")
(("extension:\\\\tdefault")
"extension:$(printf '\\011')default"))
;; Most tests attempt to access hitch-tls.org, which is
;; unavailable in the build container. Run them against a dummy
;; local web server instead.
(for-each (lambda (test)
(substitute* test
(("\\[hitch-tls\\.org\\]:80")
"[localhost]:8000")))
(find-files "src/tests" "\\.sh$"))
;; This test still relies on live external DNS/backend behavior
;; via HOSTALIASES and is too environment-dependent for a
;; reproducible build.
(substitute* "src/tests/test25-dynamic-backend-address.sh"
(("\\. hitch_test\\.sh")
". hitch_test.sh\nskip \"dynamic backend address test requires live external backends\""))
;; The build container does not reap zombie processes, causing
;; stop_hitch to hang indefinitely while waiting for the process
;; to terminate because 'kill -0' never succeeds. Use a
;; different test to see whether the process has shut down.
(substitute* "src/tests/hitch_test.sh"
(("kill -0 \"\\$HITCH_PID\"")
"$(ps -p $HITCH_PID -o state= | grep -qv '^Z$')"))))
(replace 'check
(lambda* (#:key tests? #:allow-other-keys)
(if (not tests?)
#t
(dynamic-wind
(lambda ()
;; Keep the dummy backend out of the build log pipe and
;; tear it down explicitly after the suite so the daemon
;; can observe EOF and finalize the derivation.
(system* (which "sh") "-c"
"python3 -m http.server >/dev/null 2>&1 & echo $! > .guix-hitch-test-http-server.pid")
(invoke "sleep" "1"))
(lambda ()
(invoke "make" "check"))
(lambda ()
(when (file-exists? ".guix-hitch-test-http-server.pid")
(system* (which "sh") "-c"
"kill $(cat .guix-hitch-test-http-server.pid) >/dev/null 2>&1 || true")
(delete-file ".guix-hitch-test-http-server.pid"))))))))))
(source
(origin
(method url-fetch)
(uri (string-append "https://hitch-tls.org/source/hitch-"
version
".tar.gz"))
(sha256
(base32 "0klg2pfsbhjdabjv52i0gfjfv23r45n4vs3965xa5zkzpj299jfz"))))
(native-inputs
(list pkg-config
;; For tests.
curl
grep
lsof
procps
python))
(inputs
(list aws-lc-for-haproxy libxcrypt lua pcre2 zlib))
(home-page "https://www.haproxy.org/")
(synopsis "Reliable, high performance TCP/HTTP load balancer")
(description "HAProxy offers @acronym{HA, high availability}, load
balancing, and proxying for TCP and HTTP-based applications. It is particularly
suited to Web sites crawling under very high loads while needing persistence or
Layer 7 processing. Supporting tens of thousands of connections is clearly
realistic with today's hardware.")
(license (list license:gpl2+
license:lgpl2.1
license:lgpl2.1+))))
(list libev openssl))
(synopsis "Scalable TLS proxy")
(description
"Hitch is a performant TLS proxy based on @code{libev}. It terminates
SSL/TLS connections and forwards the unencrypted traffic to a backend such
as a web server. It is designed to handle many thousand connections on
multicore machines.")
(license license:bsd-2)))
(define-public vinyl
(package
@@ -131,10 +137,6 @@ realistic with today's hardware.")
(list "CFLAGS+=-fexcess-precision=standard"))
'())
(list
;; Vinyl's upstream integration suite is very large and can take hours
;; in constrained builders. Keep channel substitute builds focused on
;; producing the runtime package; exercise service behavior separately.
#:tests? #f
#:configure-flags
#~(list (string-append "LDFLAGS=-Wl,-rpath=" #$output "/lib")
(string-append "CC=" #$(cc-for-target))
@@ -142,19 +144,11 @@ realistic with today's hardware.")
(string-append "PTHREAD_CC="
(search-input-file %build-inputs
"/bin/gcc"))
;; The runtime package does not build docs or man pages below,
;; but upstream still probes for these documentation tools.
"--with-rst2man=true"
"--with-rst2html=true"
"--with-sphinx-build=true"
"--localstatedir=/var")
#:phases
#~(modify-phases %standard-phases
(add-after 'unpack 'use-absolute-file-names
(lambda _
(substitute* "Makefile.in"
(("^SUBDIRS = include lib bin vmod etc doc man contrib")
"SUBDIRS = include lib bin vmod etc contrib"))
(substitute* '("bin/vinyltest/vtc_vinyl.c"
"bin/vinyltest/vtest2/src/vtc_process.c"
"bin/vinyltest/vtest2/src/vtc_haproxy.c"
@@ -191,7 +185,9 @@ realistic with today's hardware.")
(,(dirname
(search-input-file inputs "lib/libc.so")))))))))))
(native-inputs
(list pkg-config))
(list pkg-config
python-sphinx
python-docutils))
(inputs
(list bash-minimal
coreutils-minimal
tribes/plugins/aether.scm
+19 -85
View File
@@ -1,81 +1,11 @@
(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
"80101b7e78808cea9151f1827777edea5c08ba1f")
(define %aether-revision "1")
(define %aether-version
(git-version "0.2.0" %aether-revision %aether-commit))
(define %aether-source-sha256
"0shylw4s75djanqm7h82j8advjg96im6n4wr6fz6kwbj5hs8aq4b")
(define %aether-mix-deps-sha256
"1pk1qv8skbgzi0wg59zj9aiyxx2hxl2k6ngxqqbwvj7wsbiz95bb")
(define %aether-npm-deps-sha256
"10cwajh8yfdfd9znhibnbali1i8bk7wxrviih03n67lfkmxmghz2")
(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-package tribes-package)
(reuse-host-libs? #t)
(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-package host-package
#:reuse-host-libs? reuse-host-libs?
#: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."
#:plugin-id "org.tribe-one.plugins.aether"
#:plugin-slug "aether"
#:display-name "Aether"
#:provides '("org.tribe-one.caps.social@1" "org.tribe-one.caps.chat@1")
#:requires '("org.tribe-one.caps.ui@1")
#:enhances-with '()))
(define aether-package
(aether-package-from-source %aether-source))
"008s3k3ry3jy13q1gx7l5i0ygr012xqybm8l0zaf1cxbx6mw9nfr")
(define* (local-aether-package directory
#:key
@@ -84,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."
@@ -95,25 +24,30 @@ 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."
#:plugin-id "org.tribe-one.plugins.aether"
#:plugin-slug "aether"
#:display-name "Aether"
#:provides '("org.tribe-one.caps.social@1" "org.tribe-one.caps.chat@1")
#:requires '("org.tribe-one.caps.ui@1")
#:enhances-with '()))
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-from-package package))
(tribes-plugin-definition
(name "aether")
(package-name "tribes-plugin-aether")
(version "dev")
(synopsis "Aether timeline UI plugin for Tribes")
(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)
"Return the channel-owned Guix integration record for the Aether plugin."
(tribes-external-plugin-from-package package))
(tribes-external-plugin
(name "aether")
(package package)
(extra-packages '())
(extra-services (lambda (_node-config) '()))))
tribes/plugins/built-ins.scm
-54
View File
@@ -1,54 +0,0 @@
(define-module (tribes plugins built-ins)
#:use-module (srfi srfi-1)
#:use-module (tribes packages plugins)
#:export (guix-tribes-host-definition
guix-tribes-built-in-plugin-definitions
guix-tribes-runtime-plugin-definitions
guix-tribes-runtime-provided-capabilities
guix-tribes-runtime-required-capabilities
guix-tribes-runtime-missing-capabilities))
;; These records mirror the manifests shipped by the pinned Tribes package.
;; Package assembly still validates the actual release manifests; these records
;; let rollout preview use the same host/built-in capability model before a new
;; release closure has been built.
(define guix-tribes-host-definition
(tribes-plugin-definition
(name "org.tribe-one.hosts.tribes")
(package-name "tribes")
(version "0.2.0")
(synopsis "Tribes host plugin API foundation")
(home-page "https://git.teralink.net/tribes/tribes")
(provides '())
(requires '("org.tribe-one.caps.ui@1"))
(external-plugin #f)))
(define guix-tribes-built-in-plugin-definitions
(list
(tribes-plugin-definition
(name "tribes_ui")
(package-name "tribes")
(version "0.1.0")
(synopsis "Default Tribes UI capability provider")
(home-page "https://git.teralink.net/tribes/tribes")
(provides '("org.tribe-one.caps.ui@1"))
(requires '())
(external-plugin #f))))
(define guix-tribes-runtime-plugin-definitions
(cons guix-tribes-host-definition
guix-tribes-built-in-plugin-definitions))
(define guix-tribes-runtime-provided-capabilities
(tribes-plugin-definitions-provided-capabilities
guix-tribes-runtime-plugin-definitions))
(define guix-tribes-runtime-required-capabilities
(tribes-plugin-definitions-required-capabilities
guix-tribes-runtime-plugin-definitions))
(define guix-tribes-runtime-missing-capabilities
(filter (lambda (capability)
(not (member capability guix-tribes-runtime-provided-capabilities)))
guix-tribes-runtime-required-capabilities))
tribes/plugins/discovery.scm
-129
View File
@@ -1,129 +0,0 @@
(define-module (tribes plugins discovery)
#:use-module (gnu packages)
#:use-module (guix discovery)
#:use-module (guix packages)
#:use-module (srfi srfi-1)
#:use-module (tribes packages plugins)
#:export (tribes-plugin-packages
tribes-plugin-definitions
tribes-plugin-catalog-payload
tribes-plugin-definition-by-name
tribes-plugin-external-plugin-by-name))
(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 (string-list value)
(cond
((and (list? value) (every string? value)) value)
((vector? value) (string-list (vector->list value)))
(else '())))
(define (plugin-metadata package)
(let ((metadata (assoc-ref (package-properties package) 'tribes-plugin)))
(and (json-object? metadata) metadata)))
(define (plugin-extra-packages package)
(let ((value (assoc-ref (package-properties package)
'tribes-plugin-extra-packages)))
(if (list? value) value '())))
(define (plugin-extra-services package)
(let ((value (assoc-ref (package-properties package)
'tribes-plugin-extra-services)))
(if (procedure? value) value (lambda (_node-config) '()))))
(define (metadata-name metadata)
(or (json-ref metadata "slug")
(json-ref metadata "name")))
(define (metadata-package-name metadata package)
(or (json-ref metadata "package")
(package-name package)))
(define (plugin-module-path-entry directory)
(and (string? directory)
(file-exists? (string-append directory "/tribes/plugins"))
(cons directory "tribes/plugins")))
(define (plugin-package-module-path)
(delete-duplicates
(filter-map plugin-module-path-entry %load-path)
equal?))
(define (plugin-package-modules)
(all-modules (plugin-package-module-path)))
(define (tribes-plugin-packages)
"Return all packages in the current Guix channel environment that advertise
Tribes plugin metadata through the 'tribes-plugin package property."
(sort
(fold-packages
(lambda (package acc)
(if (plugin-metadata package)
(cons package acc)
acc))
'()
(plugin-package-modules))
(lambda (left right)
(string<? (or (metadata-name (plugin-metadata left)) (package-name left))
(or (metadata-name (plugin-metadata right)) (package-name right))))))
(define (package->catalog-entry package)
(let* ((metadata (plugin-metadata package))
(name (metadata-name metadata)))
`(("id" . ,(or (json-ref metadata "id") name))
("name" . ,name)
("slug" . ,name)
("displayName" . ,(or (json-ref metadata "displayName") name))
("package" . ,(metadata-package-name metadata package))
("version" . ,(or (json-ref metadata "version")
(package-version package)))
("synopsis" . ,(or (json-ref metadata "synopsis")
(package-synopsis package)))
("homePage" . ,(or (json-ref metadata "homePage")
(package-home-page package)))
("hostApi" . ,(or (json-ref metadata "hostApi") "1"))
("provides" . ,(list->vector (string-list (json-ref metadata "provides"))))
("requires" . ,(list->vector (string-list (json-ref metadata "requires"))))
("enhancesWith" . ,(list->vector (string-list (json-ref metadata "enhancesWith")))))))
(define (tribes-plugin-catalog-payload)
(let ((plugins (map package->catalog-entry (tribes-plugin-packages))))
`(("schemaVersion" . "2")
("plugins" . ,(list->vector plugins)))))
(define (package->plugin-definition package)
(let* ((metadata (plugin-metadata package))
(plugin-name (metadata-name metadata)))
(tribes-plugin-definition
(name plugin-name)
(package-name (metadata-package-name metadata package))
(version (or (json-ref metadata "version") (package-version package)))
(synopsis (or (json-ref metadata "synopsis") (package-synopsis package)))
(home-page (or (json-ref metadata "homePage") (package-home-page package)))
(provides (string-list (json-ref metadata "provides")))
(requires (string-list (json-ref metadata "requires")))
(external-plugin
(tribes-external-plugin
(name plugin-name)
(package package)
(extra-packages (plugin-extra-packages package))
(extra-services (plugin-extra-services package)))))))
(define (tribes-plugin-definitions)
(map package->plugin-definition (tribes-plugin-packages)))
(define (tribes-plugin-definition-by-name name)
(find (lambda (definition)
(string=? (tribes-plugin-definition-name definition) name))
(tribes-plugin-definitions)))
(define (tribes-plugin-external-plugin-by-name name)
(let ((definition (tribes-plugin-definition-by-name name)))
(and definition (tribes-plugin-definition-external-plugin definition))))
tribes/plugins/kobold.scm
-118
View File
@@ -1,118 +0,0 @@
(define-module (tribes plugins kobold)
#:use-module (guix git-download)
#:use-module (guix packages)
#:use-module (guix utils)
#:use-module (tribes packages plugins)
#:use-module (tribes packages source)
#:export (kobold-package
kobold-plugin-definition
kobold-external-plugin
local-kobold-package))
(define %kobold-home-page
"https://git.teralink.net/tribes/tribes-plugin-kobold")
(define %kobold-source-url
%kobold-home-page)
(define %kobold-commit
"74b6c44e4dcfbeaf02f77620b5675f11781ad1eb")
(define %kobold-revision "1")
(define %kobold-version
(git-version "0.1.0" %kobold-revision %kobold-commit))
(define %kobold-source-sha256
"1xxysbslh1fa57873n4669mi874byv861w934mz9g3zszr120ijn")
(define %kobold-mix-deps-sha256
"1pk1qv8skbgzi0wg59zj9aiyxx2hxl2k6ngxqqbwvj7wsbiz95bb")
(define %kobold-npm-deps-sha256
"1mzf6ld6br2y7x3lb67jpis9y5lis1r01ldmdqvf4lhrrfvrzrlb")
(define %kobold-source
(origin
(method git-fetch)
(uri (git-reference
(url %kobold-source-url)
(commit %kobold-commit)))
(file-name (git-file-name "tribes-plugin-kobold" %kobold-version))
(sha256
(base32 %kobold-source-sha256))))
(define* (kobold-package-from-source source
#:key
(host-package tribes-package)
(reuse-host-libs? #t)
(host-source tribes-upstream-source)
(mix-deps-sha256 %kobold-mix-deps-sha256)
(asset-deps-sha256 %kobold-npm-deps-sha256)
(version %kobold-version))
"Build the pinned Kobold source as an external Tribes plugin artifact."
(tribes-plugin-package
source
#:host-package host-package
#:reuse-host-libs? reuse-host-libs?
#: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-kobold"
#:version version
#:home-page %kobold-home-page
#:synopsis "Distributed dataset plugin for Tribes"
#:description
"External Tribes plugin artifact for Kobold distributed datasets,
packaged as a Guix-managed plugin directory."
#:plugin-id "org.tribe-one.plugins.kobold"
#:plugin-slug "kobold"
#:display-name "Kobold"
#:provides '("org.tribes.kobold.dataset@1")
#:requires '("org.tribe-one.caps.ui@1" "org.tribes.alliance.trust@1")
#:enhances-with '()))
(define kobold-package
(kobold-package-from-source %kobold-source))
(define* (local-kobold-package directory
#:key
host-source
host-source-directory
(build-assets? #t)
(digest-assets? #t)
(mix-deps-sha256 %kobold-mix-deps-sha256)
(asset-deps-sha256 %kobold-npm-deps-sha256)
(version "dev"))
"Build a local checkout of tribes-plugin-kobold 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? build-assets?
#:digest-assets? digest-assets?
#:asset-deps-sha256 asset-deps-sha256
#:name "tribes-plugin-kobold"
#:version version
#:home-page %kobold-home-page
#:synopsis "Distributed dataset plugin for Tribes"
#:description
"External Tribes plugin artifact for Kobold distributed datasets,
packaged as a Guix-managed plugin directory."
#:plugin-id "org.tribe-one.plugins.kobold"
#:plugin-slug "kobold"
#:display-name "Kobold"
#:provides '("org.tribes.kobold.dataset@1")
#:requires '("org.tribe-one.caps.ui@1" "org.tribes.alliance.trust@1")
#:enhances-with '()))
(define* (kobold-plugin-definition #:key (package kobold-package))
"Return the channel-owned plugin definition for Kobold."
(tribes-plugin-definition-from-package package))
(define* (kobold-external-plugin #:key package)
"Return the channel-owned Guix integration record for the Kobold plugin."
(tribes-external-plugin-from-package package))
tribes/plugins/registry.scm
+7 -24
View File
@@ -1,40 +1,23 @@
(define-module (tribes plugins registry)
#:use-module (tribes packages plugins)
#:use-module (tribes plugins aether)
#:use-module (tribes plugins kobold)
#:use-module (tribes plugins sender)
#:use-module (tribes plugins supertest)
#:use-module (tribes plugins trust)
#:use-module (srfi srfi-1)
#:export (guix-tribes-plugin-definition-by-name
#:export (guix-tribes-plugin-catalog
guix-tribes-plugin-definition-by-name
guix-tribes-plugin-definitions
guix-tribes-external-plugins
guix-tribes-plugin-substitute-packages))
guix-tribes-external-plugins))
(define guix-tribes-plugin-definitions
(list
(aether-plugin-definition)
(kobold-plugin-definition)
(sender-plugin-definition)
(supertest-plugin-definition)
(trust-plugin-definition)))
(aether-plugin-definition)))
(define guix-tribes-plugin-catalog
(tribes-plugin-catalog-file guix-tribes-plugin-definitions))
(define (guix-tribes-external-plugins)
(map tribes-plugin-definition-external-plugin
guix-tribes-plugin-definitions))
(define (guix-tribes-plugin-substitute-packages)
"Return packages needed to prebuild channel-owned plugin closures."
(delete-duplicates
(append-map
(lambda (plugin)
(let ((external-plugin
(tribes-plugin-definition-external-plugin plugin)))
(cons (tribes-external-plugin-package external-plugin)
(tribes-external-plugin-extra-packages external-plugin))))
guix-tribes-plugin-definitions)
eq?))
(define (guix-tribes-plugin-definition-by-name name)
(find (lambda (plugin-definition)
(string=? (tribes-plugin-definition-name plugin-definition) name))
tribes/plugins/sender.scm
-128
View File
@@ -1,128 +0,0 @@
(define-module (tribes plugins sender)
#:use-module (guix git-download)
#:use-module (guix packages)
#:use-module (guix utils)
#:use-module (tribes packages plugins)
#:use-module (tribes packages sender-runtime)
#:use-module (tribes packages source)
#:export (sender-package
sender-plugin-definition
sender-external-plugin
local-sender-package))
(define %sender-home-page
"https://git.teralink.net/tribes/tribes-plugin-sender")
(define %sender-source-url
%sender-home-page)
(define %sender-commit
"ee7d0ac29fb583e1c5f75001984622c2ba7e56b1")
(define %sender-revision "1")
(define %sender-version
(git-version "0.1.0" %sender-revision %sender-commit))
(define %sender-source-sha256
"1bbgi20j99ym9yiv78w3j590wpf400bdkfiqf9s1ra31dgfzzq4v")
(define %sender-mix-deps-sha256
"08mdy38247dqni8f84y09m8vz6hvjakvc4ml28x1jxqvq53s4nq3")
(define %sender-npm-deps-sha256
"1ksryrfzhs2jdlq4prj04725i5fcdvhslamfzl77i7knsh5sclfd")
(define %sender-source
(origin
(method git-fetch)
(uri (git-reference
(url %sender-source-url)
(commit %sender-commit)))
(file-name (git-file-name "tribes-plugin-sender" %sender-version))
(sha256
(base32 %sender-source-sha256))))
(define* (sender-package-from-source source
#:key
(host-package tribes-package)
(reuse-host-libs? #t)
(host-source tribes-upstream-source)
(mix-deps-sha256 %sender-mix-deps-sha256)
(asset-deps-sha256 %sender-npm-deps-sha256)
(version %sender-version))
"Build the pinned Sender source as an external Tribes plugin artifact."
(tribes-plugin-package
source
#:host-package host-package
#:reuse-host-libs? reuse-host-libs?
#:host-source host-source
#:mix-deps-sha256 mix-deps-sha256
#:include-mix-deps? #t
#:compile-mix-deps '("elixir_make" "muontrap")
#:native-deps? #t
#:build-assets? #t
#:digest-assets? #t
#:asset-deps-sha256 asset-deps-sha256
#:name "tribes-plugin-sender"
#:version version
#:home-page %sender-home-page
#:synopsis "RTMP ingest and HLS streaming plugin for Tribes"
#:description
"External Tribes plugin artifact for RTMP ingest and HLS streaming,
packaged as a Guix-managed plugin directory."
#:plugin-id "org.tribe-one.plugins.sender"
#:plugin-slug "sender"
#:display-name "Sender"
#:provides '("org.tribe-one.caps.sender@1")
#:requires '("org.tribe-one.caps.ui@1")
#:enhances-with '("org.tribe-one.caps.chat@1")
#:extra-packages (list sender-ffmpeg)))
(define sender-package
(sender-package-from-source %sender-source))
(define* (local-sender-package directory
#:key
host-source
host-source-directory
(build-assets? #t)
(digest-assets? #t)
(mix-deps-sha256 %sender-mix-deps-sha256)
(asset-deps-sha256 %sender-npm-deps-sha256)
(version "dev"))
"Build a local checkout of tribes-plugin-sender 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
#:include-mix-deps? #t
#:compile-mix-deps '("elixir_make" "muontrap")
#:native-deps? #t
#:build-assets? build-assets?
#:digest-assets? digest-assets?
#:asset-deps-sha256 asset-deps-sha256
#:name "tribes-plugin-sender"
#:version version
#:home-page %sender-home-page
#:synopsis "RTMP ingest and HLS streaming plugin for Tribes"
#:description
"External Tribes plugin artifact for RTMP ingest and HLS streaming,
packaged as a Guix-managed plugin directory."
#:plugin-id "org.tribe-one.plugins.sender"
#:plugin-slug "sender"
#:display-name "Sender"
#:provides '("org.tribe-one.caps.sender@1")
#:requires '("org.tribe-one.caps.ui@1")
#:enhances-with '("org.tribe-one.caps.chat@1")
#:extra-packages (list sender-ffmpeg)))
(define* (sender-plugin-definition #:key (package sender-package))
"Return the channel-owned plugin definition for Sender."
(tribes-plugin-definition-from-package package))
(define* (sender-external-plugin #:key (package sender-package))
"Return the channel-owned Guix integration record for the Sender plugin."
(tribes-external-plugin-from-package package))
tribes/plugins/supertest.scm
-110
View File
@@ -1,110 +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
"afc38412c4362ea2e5b1fe9fe08f1cffe60edf34")
(define %supertest-revision "1")
(define %supertest-version
(git-version "0.1.1" %supertest-revision %supertest-commit))
(define %supertest-source-sha256
"1si0bis5k47j22cv7cbbah86ilrxvrbncld4isvyb17zan7ig0q6")
(define %supertest-mix-deps-sha256
"1pk1qv8skbgzi0wg59zj9aiyxx2hxl2k6ngxqqbwvj7wsbiz95bb")
(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-package tribes-package)
(reuse-host-libs? #t)
(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-package host-package
#:reuse-host-libs? reuse-host-libs?
#: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."
#:plugin-id "org.tribe-one.plugins.supertest"
#:plugin-slug "supertest"
#:display-name "Supertest"
#:provides '()
#:requires '()
#:enhances-with '()))
(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."
#:plugin-id "org.tribe-one.plugins.supertest"
#:plugin-slug "supertest"
#:display-name "Supertest"
#:provides '()
#:requires '()
#:enhances-with '()))
(define* (supertest-plugin-definition #:key (package supertest-package))
"Return the channel-owned plugin definition for Supertest."
(tribes-plugin-definition-from-package package))
(define* (supertest-external-plugin #:key package)
"Return the channel-owned Guix integration record for the Supertest plugin."
(tribes-external-plugin-from-package package))
tribes/plugins/trust.scm
-116
View File
@@ -1,116 +0,0 @@
(define-module (tribes plugins trust)
#:use-module (guix git-download)
#:use-module (guix packages)
#:use-module (guix utils)
#:use-module (tribes packages plugins)
#:use-module (tribes packages source)
#:export (trust-package
trust-plugin-definition
trust-external-plugin
local-trust-package))
(define %trust-home-page
"https://git.teralink.net/tribes/tribes-plugin-trust")
(define %trust-source-url
%trust-home-page)
(define %trust-commit
"f08af20cd5cd2dbbb50e4472bf1a5d8ed1b73c21")
(define %trust-revision "1")
(define %trust-version
(git-version "0.1.0" %trust-revision %trust-commit))
(define %trust-source-sha256
"1zsg57mr3bjxrxvim77z2as1jqr8a3anfp0jgqz0ycz6rzai58dp")
(define %trust-mix-deps-sha256
"1pk1qv8skbgzi0wg59zj9aiyxx2hxl2k6ngxqqbwvj7wsbiz95bb")
(define %trust-npm-deps-sha256
"145cwhyqknf51fqsqv1qj3l5b7bymwwxj4dlg3mpqd6nxd0x003c")
(define %trust-source
(origin
(method git-fetch)
(uri (git-reference
(url %trust-source-url)
(commit %trust-commit)))
(file-name (git-file-name "tribes-plugin-trust" %trust-version))
(sha256
(base32 %trust-source-sha256))))
(define* (trust-package-from-source source
#:key
(host-package tribes-package)
(reuse-host-libs? #t)
(host-source tribes-upstream-source)
(mix-deps-sha256 %trust-mix-deps-sha256)
(asset-deps-sha256 %trust-npm-deps-sha256)
(version %trust-version))
"Build the pinned Trust source as an external Tribes plugin artifact."
(tribes-plugin-package
source
#:host-package host-package
#:reuse-host-libs? reuse-host-libs?
#: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-trust"
#:version version
#:home-page %trust-home-page
#:synopsis "Tribe-to-tribe trust and federation plugin for Tribes"
#:description
"External Tribes plugin artifact for tribe-to-tribe trust, alliance, and federation provider behavior."
#:plugin-id "org.tribe-one.plugins.trust"
#:plugin-slug "trust"
#:display-name "Trust"
#:provides '("org.tribes.alliance.trust@1" "org.tribes.federation.provider@1" "org.tribes.access.trust_provider@1")
#:requires '("org.tribe-one.caps.ui@1")
#:enhances-with '()))
(define trust-package
(trust-package-from-source %trust-source))
(define* (local-trust-package directory
#:key
host-source
host-source-directory
(build-assets? #t)
(digest-assets? #t)
(mix-deps-sha256 %trust-mix-deps-sha256)
(asset-deps-sha256 %trust-npm-deps-sha256)
(version "dev"))
"Build a local checkout of tribes-plugin-trust 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? build-assets?
#:digest-assets? digest-assets?
#:asset-deps-sha256 asset-deps-sha256
#:name "tribes-plugin-trust"
#:version version
#:home-page %trust-home-page
#:synopsis "Tribe-to-tribe trust and federation plugin for Tribes"
#:description
"External Tribes plugin artifact for tribe-to-tribe trust, alliance, and federation provider behavior."
#:plugin-id "org.tribe-one.plugins.trust"
#:plugin-slug "trust"
#:display-name "Trust"
#:provides '("org.tribes.alliance.trust@1" "org.tribes.federation.provider@1" "org.tribes.access.trust_provider@1")
#:requires '("org.tribe-one.caps.ui@1")
#:enhances-with '()))
(define* (trust-plugin-definition #:key (package trust-package))
"Return the channel-owned plugin definition for Trust."
(tribes-plugin-definition-from-package package))
(define* (trust-external-plugin #:key package)
"Return the channel-owned Guix integration record for the Trust plugin."
(tribes-external-plugin-from-package package))
tribes/services/chrony.scm
-177
View File
@@ -1,177 +0,0 @@
(define-module (tribes services chrony)
#:use-module (gnu packages admin)
#:use-module (gnu packages ntp)
#:use-module (gnu services)
#:use-module (gnu services networking)
#:use-module (gnu services shepherd)
#:use-module (gnu system shadow)
#:use-module (guix gexp)
#:use-module (guix records)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-13)
#:export (chrony-configuration
chrony-configuration?
chrony-configuration-package
chrony-configuration-servers
chrony-configuration-user
chrony-configuration-group
chrony-configuration-state-directory
chrony-configuration-runtime-directory
chrony-configuration-makestep?
chrony-configuration-makestep-threshold
chrony-configuration-makestep-limit
chrony-configuration-extra-config
chrony-configuration-extra-options
chrony-config-text
chrony-config-file
chrony-service-type))
(define-record-type* <chrony-configuration>
chrony-configuration make-chrony-configuration
chrony-configuration?
(package chrony-configuration-package
(default chrony))
(servers chrony-configuration-servers
(default %ntp-servers))
(user chrony-configuration-user
(default "chrony"))
(group chrony-configuration-group
(default "chrony"))
(state-directory chrony-configuration-state-directory
(default "/var/lib/chrony"))
(runtime-directory chrony-configuration-runtime-directory
(default "/var/run/chrony"))
(makestep? chrony-configuration-makestep?
(default #t))
(makestep-threshold chrony-configuration-makestep-threshold
(default "0.1"))
(makestep-limit chrony-configuration-makestep-limit
(default 3))
(extra-config chrony-configuration-extra-config
(default ""))
(extra-options chrony-configuration-extra-options
(default '())))
(define %chrony-server-types
'(pool server peer))
(define (flatten-options options)
(reverse
(let loop ((values options)
(result '()))
(if (list? values)
(fold loop result values)
(cons (format #f "~a" values) result)))))
(define (chrony-server->string server)
(let ((type (ntp-server-type server))
(address (ntp-server-address server))
(options (ntp-server-options server)))
(unless (memq type %chrony-server-types)
(error "Invalid Chrony server type" type))
(string-join
(cons* (symbol->string type)
address
(flatten-options options)))))
(define (ensure-trailing-newline text)
(if (or (string-null? text)
(string-suffix? "\n" text))
text
(string-append text "\n")))
(define (chrony-config-text config)
(string-append
(string-join
(map chrony-server->string
(chrony-configuration-servers config))
"\n")
"\n"
(if (chrony-configuration-makestep? config)
(format #f "makestep ~a ~a\n"
(chrony-configuration-makestep-threshold config)
(chrony-configuration-makestep-limit config))
"")
"driftfile "
(chrony-configuration-state-directory config)
"/chrony.drift\n"
"keyfile "
(chrony-configuration-state-directory config)
"/chrony.keys\n"
(ensure-trailing-newline
(chrony-configuration-extra-config config))))
(define (chrony-config-file config)
(plain-file "chrony.conf" (chrony-config-text config)))
(define (chrony-accounts config)
(list
(user-group
(name (chrony-configuration-group config))
(system? #t))
(user-account
(name (chrony-configuration-user config))
(group (chrony-configuration-group config))
(system? #t)
(comment "Chrony daemon user")
(home-directory (chrony-configuration-state-directory config))
(shell (file-append shadow "/sbin/nologin")))))
(define (chrony-activation config)
#~(begin
(use-modules (guix build utils))
(define (ensure-file file mode uid gid)
(unless (file-exists? file)
(call-with-output-file file
(lambda _
#t)))
(chown file uid gid)
(chmod file mode))
(let* ((user #$(chrony-configuration-user config))
(group #$(chrony-configuration-group config))
(state-directory #$(chrony-configuration-state-directory config))
(runtime-directory #$(chrony-configuration-runtime-directory config))
(uid (passwd:uid (getpwnam user)))
(gid (group:gid (getgrnam group))))
(for-each mkdir-p (list state-directory runtime-directory))
(for-each (lambda (directory)
(chown directory uid gid)
(chmod directory #o750))
(list state-directory runtime-directory))
(ensure-file (string-append state-directory "/chrony.drift")
#o640 uid gid)
(ensure-file (string-append state-directory "/chrony.keys")
#o640 0 gid))))
(define (chrony-shepherd-services config)
(let ((config-file (chrony-config-file config)))
(list
(shepherd-service
(documentation "Run the Chrony NTP daemon.")
(provision '(chronyd))
(requirement '(user-processes networking))
(actions (list (shepherd-configuration-action config-file)))
(start
#~(make-forkexec-constructor
(list #$(file-append (chrony-configuration-package config)
"/sbin/chronyd")
"-n"
"-u" #$(chrony-configuration-user config)
"-f" #$config-file
#$@(chrony-configuration-extra-options config))
#:log-file "/var/log/chronyd.log"))
(stop #~(make-kill-destructor))))))
(define chrony-service-type
(service-type
(name 'chrony)
(extensions
(list (service-extension account-service-type chrony-accounts)
(service-extension activation-service-type chrony-activation)
(service-extension shepherd-root-service-type
chrony-shepherd-services)
(service-extension profile-service-type
(compose list chrony-configuration-package))))
(default-value (chrony-configuration))
(description "Run Chrony to synchronize the system clock with NTP servers.")))
tribes/services/haproxy.scm
-237
View File
@@ -1,237 +0,0 @@
(define-module (tribes services haproxy)
#:use-module (gnu packages admin)
#:use-module (gnu packages base)
#:use-module (gnu services)
#:use-module (gnu services shepherd)
#:use-module (gnu system shadow)
#:use-module (guix gexp)
#:use-module (guix records)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-13)
#:use-module (tribes packages web)
#:export (haproxy-configuration
haproxy-configuration?
haproxy-configuration-package
haproxy-configuration-backend
haproxy-configuration-frontends
haproxy-configuration-quic-frontends
haproxy-configuration-http-frontends
haproxy-configuration-acme-backend
haproxy-configuration-pem-files
haproxy-configuration-user
haproxy-configuration-group
haproxy-configuration-runtime-dir
haproxy-configuration-extra-global
haproxy-configuration-extra-defaults
haproxy-configuration-extra-frontend
haproxy-configuration-open-files-soft-limit
haproxy-configuration-open-files-hard-limit
haproxy-service-type))
(define-record-type* <haproxy-configuration>
haproxy-configuration make-haproxy-configuration
haproxy-configuration?
(package haproxy-configuration-package
(default haproxy))
(backend haproxy-configuration-backend
(default "127.0.0.1:6081"))
(frontends haproxy-configuration-frontends
(default '("0.0.0.0:443" "[::]:443 v6only")))
(quic-frontends haproxy-configuration-quic-frontends
(default '("quic4@0.0.0.0:443"
"quic6@[::]:443 v6only")))
(http-frontends haproxy-configuration-http-frontends
(default '()))
(acme-backend haproxy-configuration-acme-backend
(default #f))
(pem-files haproxy-configuration-pem-files
(default '()))
(user haproxy-configuration-user
(default "haproxy"))
(group haproxy-configuration-group
(default "haproxy"))
(runtime-dir haproxy-configuration-runtime-dir
(default "/var/run/haproxy"))
(extra-global haproxy-configuration-extra-global
(default '()))
(extra-defaults haproxy-configuration-extra-defaults
(default '()))
(extra-frontend haproxy-configuration-extra-frontend
(default '()))
(open-files-soft-limit haproxy-configuration-open-files-soft-limit
(default 32768))
(open-files-hard-limit haproxy-configuration-open-files-hard-limit
(default 65535)))
(define %haproxy-accounts
(list
(user-group
(name "haproxy")
(system? #t))
(user-account
(name "haproxy")
(group "haproxy")
(system? #t)
(comment "HAProxy service user")
(home-directory "/var/empty")
(shell (file-append shadow "/sbin/nologin")))))
(define (haproxy-indent line)
(string-append " " line "\n"))
(define (haproxy-lines lines)
(string-concatenate (map haproxy-indent lines)))
(define (haproxy-http-frontend http-frontends acme-backend)
(if (null? http-frontends)
""
(string-append
"frontend tribes_http\n"
(haproxy-lines
(append
(map (lambda (frontend)
(string-append "bind " frontend))
http-frontends)
(if acme-backend
'("acl acme_challenge path_beg /.well-known/acme-challenge/"
"http-request redirect scheme https code 308 unless acme_challenge"
"use_backend lego_acme if acme_challenge")
'("http-request redirect scheme https code 308"))))
"\n"
(if acme-backend
(string-append
"backend lego_acme\n"
(haproxy-lines
(list (string-append "server lego " acme-backend)))
"\n")
""))))
(define (haproxy-config-file config)
(match config
(($ <haproxy-configuration> _ backend frontends quic-frontends http-frontends
acme-backend pem-files user group runtime-dir
extra-global extra-defaults extra-frontend)
(plain-file
"haproxy.conf"
(string-append
"global\n"
(haproxy-lines
(append
(list "log /dev/log local0"
"setcap cap_net_bind_service"
(string-append "user " user)
(string-append "group " group)
"maxconn 32768"
(string-append "stats socket " runtime-dir
"/admin.sock mode 660 level admin expose-fd listeners")
"tune.ssl.default-dh-param 2048")
extra-global))
"\n"
"defaults\n"
(haproxy-lines
(append
'("log global"
"mode http"
"option httplog"
"option dontlognull"
"option forwardfor"
"timeout connect 5s"
"timeout client 50s"
"timeout server 50s")
extra-defaults))
"\n"
(haproxy-http-frontend http-frontends acme-backend)
"frontend tribes_tls\n"
(haproxy-lines
(append
(append-map
(lambda (frontend)
(map
(lambda (pem-file)
(string-append "bind " frontend
" ssl crt " pem-file
" alpn h2,http/1.1"))
pem-files))
frontends)
(append-map
(lambda (frontend)
(map
(lambda (pem-file)
(string-append "bind " frontend
" ssl crt " pem-file
" alpn h3"))
pem-files))
quic-frontends)
'("http-response set-header alt-svc 'h3=\":443\"; ma=86400'")
'("default_backend tribes_edge_cache")
extra-frontend))
"\n"
"backend tribes_edge_cache\n"
(haproxy-lines
(list (string-append "server vinyl " backend " check"))))))))
(define (haproxy-activation config)
(let ((runtime-dir (haproxy-configuration-runtime-dir config))
(user (haproxy-configuration-user config))
(group (haproxy-configuration-group config)))
#~(begin
(use-modules (guix build utils))
(mkdir-p #$runtime-dir)
(let ((uid (passwd:uid (getpwnam #$user)))
(gid (group:gid (getgrnam #$group))))
(chown #$runtime-dir uid gid)))))
(define (haproxy-resource-limits config)
`((nofile
,(haproxy-configuration-open-files-soft-limit config)
,(haproxy-configuration-open-files-hard-limit config))))
(define (haproxy-reload-procedure package config-file)
#~(lambda (running)
(and (zero? (system* #$(file-append package "/sbin/haproxy")
"-c"
"-f"
#$config-file))
(begin
(kill (process-id running) SIGUSR2)
#t))))
(define (haproxy-shepherd-services config)
(let ((config-file (haproxy-config-file config))
(package (haproxy-configuration-package config)))
(list
(shepherd-service
(documentation "Run HAProxy as the Tribes TLS edge proxy.")
(provision '(haproxy))
(requirement '(user-processes networking))
(start
#~(make-forkexec-constructor
(list #$(file-append package "/sbin/haproxy")
"-W"
"-db"
"-f"
#$config-file)
#:resource-limits '#$(haproxy-resource-limits config)))
(stop #~(make-kill-destructor))
(actions
(list
(shepherd-action
(name 'reload)
(documentation "Validate configuration and reload HAProxy.")
(procedure (haproxy-reload-procedure package config-file)))))))))
(define haproxy-service-type
(service-type
(name 'haproxy)
(extensions
(list (service-extension account-service-type
(const %haproxy-accounts))
(service-extension activation-service-type
haproxy-activation)
(service-extension shepherd-root-service-type
haproxy-shepherd-services)
(service-extension profile-service-type
(compose list haproxy-configuration-package))))
(default-value (haproxy-configuration))
(description "Run HAProxy as a TLS proxy.")))
tribes/services/hitch.scm
+137
View File
@@ -0,0 +1,137 @@
(define-module (tribes services hitch)
#:use-module (gnu packages admin)
#:use-module (gnu packages base)
#:use-module (gnu packages linux)
#:use-module (gnu services)
#:use-module (gnu services shepherd)
#:use-module (gnu system shadow)
#:use-module (guix gexp)
#:use-module (guix records)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-13)
#:use-module (tribes packages web)
#:export (hitch-configuration
hitch-configuration?
hitch-configuration-package
hitch-configuration-backend
hitch-configuration-frontends
hitch-configuration-pem-files
hitch-configuration-ciphers
hitch-configuration-user
hitch-configuration-group
hitch-configuration-pid-file
hitch-configuration-ocsp-dir
hitch-configuration-extra-config
hitch-service-type))
(define-record-type* <hitch-configuration>
hitch-configuration make-hitch-configuration
hitch-configuration?
(package hitch-configuration-package
(default hitch))
(backend hitch-configuration-backend
(default "[127.0.0.1]:6081"))
(frontends hitch-configuration-frontends
(default '("[0.0.0.0]:443" "[::]:443")))
(pem-files hitch-configuration-pem-files
(default '()))
(ciphers hitch-configuration-ciphers
(default "EECDH+AESGCM:EDH+AESGCM:AES256+EECDH:AES256+EDH"))
(user hitch-configuration-user
(default "hitch"))
(group hitch-configuration-group
(default "hitch"))
(pid-file hitch-configuration-pid-file
(default "/var/run/hitch/hitch.pid"))
(ocsp-dir hitch-configuration-ocsp-dir
(default "/var/cache/hitch/ocsp"))
(extra-config hitch-configuration-extra-config
(default '())))
(define %hitch-accounts
(list
(user-group
(name "hitch")
(system? #t))
(user-account
(name "hitch")
(group "hitch")
(system? #t)
(comment "Hitch TLS proxy user")
(home-directory "/var/empty")
(shell (file-append shadow "/sbin/nologin")))))
(define (hitch-config-file config)
(match config
(($ <hitch-configuration> _ backend frontends pem-files ciphers user group
pid-file ocsp-dir extra-config)
(plain-file
"hitch.conf"
(string-append
"backend = \"" backend "\"\n"
(string-concatenate
(map (lambda (frontend)
(string-append "frontend = \"" frontend "\"\n"))
frontends))
(string-concatenate
(map (lambda (pem-file)
(string-append "pem-file = \"" pem-file "\"\n"))
pem-files))
"ciphers = \"" ciphers "\"\n"
"user = \"" user "\"\n"
"group = \"" group "\"\n"
"ocsp-dir = \"" ocsp-dir "\"\n"
(string-concatenate
(map (lambda (line)
(string-append line "\n"))
extra-config)))))))
(define (hitch-activation config)
#~(begin
(use-modules (guix build utils))
(mkdir-p "/var/run/hitch")
(mkdir-p #$(hitch-configuration-ocsp-dir config))))
(define (hitch-reload-procedure package)
#~(lambda _
(zero? (system* #$(file-append procps "/bin/pkill")
"-HUP"
"-x"
"hitch"))))
(define (hitch-shepherd-services config)
(let ((config-file (hitch-config-file config))
(package (hitch-configuration-package config)))
(list
(shepherd-service
(documentation "Run the Hitch TLS proxy.")
(provision '(hitch))
(requirement '(user-processes networking))
(start
#~(make-forkexec-constructor
(list #$(file-append package "/sbin/hitch")
"--config"
#$config-file)))
(stop #~(make-kill-destructor))
(actions
(list
(shepherd-action
(name 'reload)
(documentation "Reload Hitch certificates and listeners.")
(procedure (hitch-reload-procedure package)))))))))
(define hitch-service-type
(service-type
(name 'hitch)
(extensions
(list (service-extension account-service-type
(const %hitch-accounts))
(service-extension activation-service-type
hitch-activation)
(service-extension shepherd-root-service-type
hitch-shepherd-services)
(service-extension profile-service-type
(compose list hitch-configuration-package))))
(default-value (hitch-configuration))
(description "Run the Hitch TLS proxy.")))
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/logging.scm
-225
View File
@@ -1,225 +0,0 @@
(define-module (tribes services logging)
#:use-module (gnu services)
#:use-module (gnu services admin)
#:use-module (gnu services base)
#:use-module (gnu services shepherd)
#:use-module (guix gexp)
#:use-module (guix records)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-13)
#:use-module (tribes packages logging)
#:export (tribes-system-logging-configuration
tribes-system-logging-configuration?
tribes-system-logging-configuration-package
tribes-system-logging-configuration-jsonl-path
tribes-system-logging-configuration-persist-file
tribes-system-logging-configuration-control-socket
tribes-system-logging-configuration-pid-file
tribes-system-logging-configuration-tailed-log-files
tribes-system-logging-configuration-native-program-log-files
tribes-system-logging-config-text
tribes-system-logging-config-file
tribes-system-logging-service-type
tribes-base-services))
(define %default-tailed-log-files
'(("tribes" . "/var/log/tribes.log")
("tribes-migrations" . "/var/log/tribes-migrations.log")
("tribes-local-control" . "/var/log/tribes-local-control.log")
("prometheus-node-exporter" . "/var/log/prometheus-node-exporter.log")
("victoria-metrics" . "/var/log/victoria-metrics.log")
("vmagent" . "/var/log/vmagent.log")
("vinyl-tribes-edge" . "/var/log/vinyl-tribes-edge.log")
("vinyl-exporter" . "/var/log/vinyl-exporter.log")
("lego" . "/var/log/lego.log")
("tang" . "/var/log/tang.log")))
(define %default-native-program-log-files
'(("chronyd" . "/var/log/chronyd.log")
("haproxy" . "/var/log/haproxy.log")
("postgres" . "/var/log/postgresql.log")))
(define-record-type* <tribes-system-logging-configuration>
tribes-system-logging-configuration make-tribes-system-logging-configuration
tribes-system-logging-configuration?
(package tribes-system-logging-configuration-package
(default syslog-ng-minimal))
(jsonl-path tribes-system-logging-configuration-jsonl-path
(default "/var/log/tribes-combined.jsonl"))
(persist-file tribes-system-logging-configuration-persist-file
(default "/var/lib/syslog-ng/syslog-ng.persist"))
(control-socket tribes-system-logging-configuration-control-socket
(default "/var/run/syslog-ng.ctl"))
(pid-file tribes-system-logging-configuration-pid-file
(default "/var/run/syslog-ng.pid"))
(tailed-log-files tribes-system-logging-configuration-tailed-log-files
(default %default-tailed-log-files))
(native-program-log-files
tribes-system-logging-configuration-native-program-log-files
(default %default-native-program-log-files)))
(define (syslog-ng-quote value)
(call-with-output-string
(lambda (port)
(write value port))))
(define (syslog-ng-id prefix value)
(string-append
prefix
"_"
(list->string
(map (lambda (char)
(if (or (char-alphabetic? char)
(char-numeric? char))
char
#\_))
(string->list value)))))
(define (syslog-ng-source-file-stanza entry)
(match entry
((program . path)
(format #f
"source ~a { file(~a flags(no-parse) program_override(~a) default-facility(local0) default-priority(info) follow-freq(1)); };\n"
(syslog-ng-id "s_file" program)
(syslog-ng-quote path)
(syslog-ng-quote program)))))
(define (syslog-ng-source-name entry)
(match entry
((program . _path)
(syslog-ng-id "s_file" program))))
(define (syslog-ng-native-program-log-stanza entry)
(match entry
((program . path)
(let ((id (syslog-ng-id "native" program)))
(format #f
"filter f_~a { program(~a); };\ndestination d_~a { file(~a template(t_plain)); };\nlog { source(s_sys); filter(f_~a); destination(d_~a); };\n"
id
(syslog-ng-quote program)
id
(syslog-ng-quote path)
id
id)))))
(define (tribes-system-logging-config-text config)
(let ((jsonl-path (tribes-system-logging-configuration-jsonl-path config))
(tail-files (tribes-system-logging-configuration-tailed-log-files config))
(native-program-logs
(tribes-system-logging-configuration-native-program-log-files config)))
(string-append
"@version: 4.10\n"
"@include \"scl.conf\"\n\n"
"options {\n"
" chain_hostnames(no);\n"
" create_dirs(yes);\n"
" dir_perm(0755);\n"
" group(\"root\");\n"
" keep_hostname(yes);\n"
" owner(\"root\");\n"
" perm(0640);\n"
" stats(freq(0));\n"
" use_dns(no);\n"
"};\n\n"
"source s_sys {\n"
" unix-dgram(\"/dev/log\");\n"
" internal();\n"
" file(\"/proc/kmsg\" program_override(\"kernel\"));\n"
"};\n\n"
(string-concatenate (map syslog-ng-source-file-stanza tail-files))
"\n"
"template t_plain { template(\"${ISODATE} ${HOST} ${PROGRAM}[${PID}]: ${MESSAGE}\\n\"); };\n"
"template t_json { template(\"$(format-json timestamp=${ISODATE} host=${HOST} program=${PROGRAM} pid=${PID} facility=${FACILITY} severity=${LEVEL} message=${MESSAGE})\\n\"); };\n\n"
"destination d_combined_jsonl { file("
(syslog-ng-quote jsonl-path)
" template(t_json) group(\"tribes\") perm(0640)); };\n"
"destination d_messages { file(\"/var/log/messages\" template(t_plain)); };\n"
"destination d_debug { file(\"/var/log/debug\" template(t_plain)); };\n"
"destination d_secure { file(\"/var/log/secure\" template(t_plain)); };\n\n"
"filter f_messages { level(info..emerg); };\n"
"filter f_debug { level(debug); };\n"
"filter f_secure { facility(auth, authpriv); };\n"
"filter f_kmsg_shepherd { program(\"kernel\") and message(\"^[0-9]+\\\\.[0-9]+\\\\] shepherd\\\\[1\\\\]:\"); };\n"
"filter f_not_kmsg_shepherd { not filter(f_kmsg_shepherd); };\n"
"rewrite r_kmsg_shepherd { subst(\"^[0-9]+\\\\.[0-9]+\\\\] shepherd\\\\[1\\\\]: ?\", \"\", value(\"MESSAGE\")); set(\"shepherd\", value(\"PROGRAM\")); set-severity(\"notice\"); };\n\n"
"log { source(s_sys); filter(f_not_kmsg_shepherd); destination(d_combined_jsonl); };\n"
"log { source(s_sys); filter(f_not_kmsg_shepherd); filter(f_messages); destination(d_messages); };\n"
"log { source(s_sys); filter(f_not_kmsg_shepherd); filter(f_debug); destination(d_debug); };\n"
"log { source(s_sys); filter(f_not_kmsg_shepherd); filter(f_secure); destination(d_secure); };\n"
"log { source(s_sys); filter(f_kmsg_shepherd); rewrite(r_kmsg_shepherd); destination(d_combined_jsonl); destination(d_messages); };\n"
(string-concatenate
(map (lambda (entry)
(format #f
"log { source(~a); destination(d_combined_jsonl); };\nlog { source(~a); filter(f_messages); destination(d_messages); };\nlog { source(~a); filter(f_debug); destination(d_debug); };\n"
(syslog-ng-source-name entry)
(syslog-ng-source-name entry)
(syslog-ng-source-name entry)))
tail-files))
"\n"
(string-concatenate
(map syslog-ng-native-program-log-stanza native-program-logs)))))
(define (tribes-system-logging-config-file config)
(plain-file "syslog-ng.conf"
(tribes-system-logging-config-text config)))
(define (logging-activation config)
#~(begin
(use-modules (guix build utils))
(define (ensure-file path)
(mkdir-p (dirname path))
(unless (file-exists? path)
(call-with-output-file path (const #t)))
(chmod path #o640))
(define (ensure-combined-jsonl path)
(ensure-file path)
(let ((group (getgrnam "tribes")))
(chown path 0 (group:gid group))))
(mkdir-p "/var/lib/syslog-ng")
(mkdir-p "/var/log")
(ensure-combined-jsonl #$(tribes-system-logging-configuration-jsonl-path config))
(for-each ensure-file
'#$(append (list "/var/log/messages"
"/var/log/debug"
"/var/log/secure")
(map cdr (tribes-system-logging-configuration-tailed-log-files config))
(map cdr (tribes-system-logging-configuration-native-program-log-files config))))))
(define (syslog-ng-shepherd-services config)
(let ((config-file (tribes-system-logging-config-file config))
(package (tribes-system-logging-configuration-package config)))
(list
(shepherd-service
(documentation "Run syslog-ng for system, service, and Tribes JSONL logs.")
(provision '(syslogd syslog-ng))
(requirement '(user-processes))
(actions (list (shepherd-configuration-action config-file)))
(start
#~(make-forkexec-constructor
(list #$(file-append package "/sbin/syslog-ng")
"--foreground"
"--cfgfile" #$config-file
"--persist-file" #$(tribes-system-logging-configuration-persist-file config)
"--control" #$(tribes-system-logging-configuration-control-socket config)
"--pidfile" #$(tribes-system-logging-configuration-pid-file config))))
(stop #~(make-kill-destructor))))))
(define tribes-system-logging-service-type
(service-type
(name 'tribes-system-logging)
(extensions
(list (service-extension activation-service-type logging-activation)
(service-extension shepherd-root-service-type
syslog-ng-shepherd-services)
(service-extension profile-service-type
(compose list
tribes-system-logging-configuration-package))))
(default-value (tribes-system-logging-configuration))
(description "Run syslog-ng and produce conventional plus Tribes JSONL logs.")))
(define (tribes-base-services)
(append
(list (service tribes-system-logging-service-type))
(modify-services %base-services
(delete shepherd-system-log-service-type))))

Some files were not shown because too many files have changed in this diff Show More