fix: keep DRM enabled for installer consoles

Keep DRM/KMS support in tribes-linux so the kexec installer can show a local console on Proxmox/QEMU and generic real hardware.

This restores VGA console output while retaining the other kernel slimming options.

.gitea/workflows/pinned-e2e.yml

@@ -0,0 +1,110 @@
+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

@@ -0,0 +1,8 @@
+;; 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

@@ -0,0 +1,6 @@
+;; This is a Guix channel.
+
+(channel
+  (version 0)
+  (keyring-reference "keyring")
+  (url "https://git.teralink.net/tribes/guix-tribes.git"))

README.md

@@ -1,58 +1,120 @@
-## NBDE Channel
+# Guix Tribes Channel
 
-This repository provides the Guix-side pieces for network-bound disk
-encryption:
+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.
 
-- `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.
+## Contents
 
-It now also carries the first Tribes deployment substrate:
+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:
 
-- `tribes/packages/release.scm`
-  A deployment-bridge package wrapper for a prebuilt Tribes release tree.
 - `tribes/packages/source.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.
+- `tribes/plugins/sender.scm`
+- `tribes/plugins/aether.scm`
+- `tribes/plugins/supertest.scm`
+- `tribes/plugins/kobold.scm`
+- `tribes/plugins/trust.scm`
 
-Current development status:
+For one-off updates, use `scripts/update-tribes-pin` or
+`scripts/update-plugin-pin --help` directly.
 
-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.
+## Channel files
 
-For pinned bootstrap usage, generate a `channels.scm` that combines upstream
-Guix with this repository's current commit.
+Checked-in channel files serve different roles:
 
-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`.
+- `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 current Legion kexec image path is based on:
+For pinned bootstrap usage, generate a `channels.scm` that combines the pinned
+upstream Guix channel with this repository's current commit.
 
-- `examples/build-host-kexec-installer.scm`
-- `nbde/system/build-host-kexec-installer.scm`
+## Current development status
 
-That build-host installer is the active kexec image definition used for
-Legion deployment bootstrapping.
+- 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.

docs/LOCAL_CONTROL_API.md

@@ -0,0 +1,329 @@
+# 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

@@ -0,0 +1,95 @@
+# 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

@@ -17,7 +17,6 @@
     "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",
@@ -25,7 +24,8 @@
     "secretKeyBaseFile": "/var/lib/tribes/secrets/secret_key_base",
     "tokenSigningSecretFile": "/var/lib/tribes/secrets/token_signing_secret",
     "releaseCookieFile": "/var/lib/tribes/secrets/release_cookie",
-    "releaseDistribution": "none",
+    "releaseDistribution": "name",
+    "releaseNode": "tribes@127.0.0.1",
     "extraEnvironmentVariables": [
       "TRIBES_BOOTSTRAP_FILE=/etc/tribes/bootstrap.json"
     ],

examples/legion-phase1-system.sexp

@@ -13,6 +13,7 @@
              (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

@@ -0,0 +1,18 @@
+(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

@@ -0,0 +1,54 @@
+;;; 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

@@ -1,44 +0,0 @@
-(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

@@ -1,44 +0,0 @@
-(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

@@ -1,47 +0,0 @@
-(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

@@ -18,7 +18,6 @@
   #: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

@@ -23,7 +23,8 @@
 
 (define (tang-activation config)
   #~(begin
-      (use-modules (guix build utils))
+      (use-modules (guix build utils)
+                   (ice-9 ftw))
       (let ((key-directory #$(tang-configuration-key-directory config))
             (keygen (string-append
                      #$(tang-configuration-package config)
@@ -45,7 +46,8 @@
                     "-l"
                     "-p" #$(number->string
                             (tang-configuration-port config))
-                    #$(tang-configuration-key-directory config))))
+                    #$(tang-configuration-key-directory config))
+              #:log-file "/var/log/tang.log"))
     (stop #~(make-kill-destructor))
     (respawn? #f))))
 

nbde/system/boot-store.scm

@@ -1,49 +1,87 @@
 (define-module (nbde system boot-store)
   #:use-module (gnu services)
+  #:use-module (guix build utils)
   #:use-module (guix gexp)
-  #:export (boot-store-staging-service))
+  #: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)))
 
 (define (boot-store-staging-gexp)
-  (with-imported-modules '((guix build utils)
-                           (ice-9 regex)
-                           (ice-9 rdelim)
-                           (srfi srfi-1))
+  (with-imported-modules (source-module-closure
+                          '((nbde system boot-store)))
     #~(begin
-        (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)))))))
+        (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))))))
 
 (define (boot-store-staging-service)
   (simple-service 'stage-grub-visible-store-items

nbde/system/build-host-kexec-installer.scm

@@ -14,6 +14,7 @@
   #: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
@@ -54,7 +55,10 @@
          util-linux)))
 
 (define %build-host-kexec-initrd-modules
-  '("ahci"
+  '(;; Common block/storage basics.
+    "ahci"
+    "ata_piix"
+    "cdrom"
     "dm-crypt"
     "fat"
     "loop"
@@ -63,13 +67,19 @@
     "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"))
+    "virtio_scsi"
+    "e1000"
+    "e1000e"
+    "r8169"))
 
 (define build-host-kexec-installer-os
   (operating-system
@@ -77,14 +87,16 @@
     (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=ttyS0,115200n8"
+     '("console=tty0"
+       "console=ttyS0,115200n8"
        "net.ifnames=0"
        "panic=30"
-       "loglevel=4"))
+       "loglevel=6"))
     (bootloader
      (bootloader-configuration
       (bootloader grub-bootloader)

nbde/system/build-host.scm

@@ -3,6 +3,7 @@
   #: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
@@ -25,6 +26,7 @@
                                            authorized-keys-file
                                            (timezone "Etc/UTC")
                                            (locale "en_US.UTF-8")
+                                           (kernel tribes-linux)
                                            (kernel-arguments
                                             (list "console=tty0"
                                                   "console=ttyS0,115200n8"))
@@ -50,6 +52,7 @@ 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

@@ -5,6 +5,9 @@
   #: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
@@ -15,6 +18,24 @@
    "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
@@ -25,11 +46,12 @@
                                           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 '("nvme" "sd_mod" "virtio_scsi")
+                                           (append %nbde-initrd-modules
                                                    %base-initrd-modules))
                                           (extra-services '()))
   "Return a base installed Guix system for the NBDE flow, parameterized by the
@@ -39,6 +61,7 @@ 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)
@@ -48,7 +71,8 @@ runtime-discovered boot and filesystem values from the installer."
     (services
      (append
      extra-services
-      (list (service dhcpcd-service-type)
+      (list (boot-store-staging-service)
+            (service dhcpcd-service-type)
             (service elogind-service-type)
             (service agetty-service-type
                      (agetty-configuration
@@ -66,4 +90,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)))))
-      %base-services))))
+      (tribes-base-services)))))

nbde/system/mapped-devices.scm

@@ -13,20 +13,31 @@
                                   #: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 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."
+  "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."
   (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))
+               (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"))
            (mkdir-p "/run/cryptsetup/")
 
            (let* ((partition
@@ -60,7 +71,65 @@ keeps a manual recovery slot available."
                         '())
                     '#$extra-options
                     (list partition #$target))))
-             (or (zero? (system* shell-bin "-c"
+             (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"
                                  (string-append
                                   "attempt=0; "
                                   "while :; do "
@@ -80,10 +149,6 @@ keeps a manual recovery slot available."
                                   "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)))))))))
 
@@ -99,6 +164,9 @@ keeps a manual recovery slot available."
    (close close-clevis-luks-device)
    (modules '((rnrs bytevectors)
               ((gnu build file-systems)
-               #:select (find-partition-by-luks-uuid system*/tty))
+               #:select (find-partition-by-luks-uuid find-partition-by-uuid
+                         system*/tty))
+              ((guix build syscalls)
+               #:select (MS_RDONLY))
               ((guix build utils)
                #:select (mkdir-p))))))

pins/base-channels.sexp

@@ -1,12 +1,12 @@
 (list (channel
         (name 'guix)
         (url "https://git.teralink.net/tribes/guix-fork.git")
-        (branch "master")
-        ;; Guix v1.5.0
+        (branch "feature/substitute-read-timeout")
+        ;; guix-fork feature/substitute-read-timeout
         (commit
-          "6f9c3cd1761f0a3f8b70223cb0e0f47e29582d90")
+          "4574af27f27c7a5d2dc4d4823ef4518a392dc973")
         (introduction
           (make-channel-introduction
-            "6f9c3cd1761f0a3f8b70223cb0e0f47e29582d90"
+            "093f27dde01cdbda68f2ec4b81e5a34ae180aab9"
             (openpgp-fingerprint
               "6688 9153 C51C 4613 A493  A525 2F0D FD14 EF99 DAC3")))))

pins/legion-channels.sexp

@@ -0,0 +1,22 @@
+(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

@@ -0,0 +1,278 @@
+#!/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

@@ -0,0 +1,70 @@
+#!/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

@@ -0,0 +1,73 @@
+#!/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

@@ -0,0 +1,18 @@
+#!/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

@@ -0,0 +1,67 @@
+#!/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

@@ -3,16 +3,205 @@ set -eu
 
 script_dir=$(CDPATH= cd -- "$(dirname "$0")" && pwd)
 root_dir=$(CDPATH= cd -- "$script_dir/.." && pwd)
-output="${1:-$root_dir/pins/base-channels.sexp}"
-channels_source_host="${NBDE_GUIX_CHANNELS_SOURCE_HOST:-pguix}"
+base_output="${NBDE_BASE_CHANNELS_OUTPUT:-$root_dir/pins/base-channels.sexp}"
+legion_output="${NBDE_LEGION_CHANNELS_OUTPUT:-$root_dir/pins/legion-channels.sexp}"
 
-mkdir -p "$(dirname "$output")"
+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"
 
-if command -v guix >/dev/null 2>&1; then
-  guix describe -f channels >"$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"
 else
-  ssh -o BatchMode=yes -o ConnectTimeout=10 \
-    "$channels_source_host" 'guix describe -f channels' >"$output"
+  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
 fi
 
-printf '%s\n' "$output"
+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"

scripts/update-plugin-pin

@@ -0,0 +1,513 @@
+#!/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

@@ -0,0 +1,113 @@
+#!/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

@@ -8,13 +8,14 @@ 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.
+By default, REV is "master" resolved from the local Tribes checkout. Hashing and
+Guix builds run with local `guix` unless --build-host is provided.
 
 Options:
-  --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
+  --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
 EOF
 }
 
@@ -24,7 +25,7 @@ default_tribes_repo=$(CDPATH= cd -- "$default_guix_repo/../tribes" && pwd)
 
 tribes_repo=$default_tribes_repo
 guix_repo=$default_guix_repo
-pguix_host=pguix
+build_host=
 rev=master
 
 while [ "$#" -gt 0 ]; do
@@ -37,8 +38,8 @@ while [ "$#" -gt 0 ]; do
       guix_repo=$2
       shift 2
       ;;
-    --pguix-host)
-      pguix_host=$2
+    --build-host)
+      build_host=$2
       shift 2
       ;;
     -h|--help)
@@ -88,12 +89,17 @@ 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")
 
@@ -107,7 +113,7 @@ remote_tmp=
 
 cleanup() {
   if [ -n "${remote_tmp:-}" ]; then
-    ssh "$pguix_host" "rm -rf '$remote_tmp'" >/dev/null 2>&1 || true
+    ssh "$build_host" "rm -rf '$remote_tmp'" >/dev/null 2>&1 || true
   fi
   rm -rf "$local_tmp"
 }
@@ -117,22 +123,49 @@ trap cleanup EXIT INT TERM
 mkdir -p "$local_tmp/tribes-source"
 git -C "$tribes_repo" archive "$commit" | tar -x -C "$local_tmp/tribes-source"
 
-remote_tmp=$(ssh "$pguix_host" 'mktemp -d /tmp/tribes-pin.XXXXXX')
+setup_remote() {
+  require_tool rsync
+  require_tool ssh
 
-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/"
+  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')
 
-source_hash=$(ssh "$pguix_host" "guix hash -rx '$remote_tmp/tribes-source'" | tr -d '\r')
+    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
 
-remote_run_scheme() {
+  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() {
   name=$1
   body=$2
 
-  ssh "$pguix_host" "cat > '$remote_tmp/$name.scm' <<'EOF'
+  if [ "$use_remote" = true ]; then
+    ssh "$build_host" "cat > '$remote_tmp/$name.scm' <<'EOF'
 $body
 EOF"
 
-  ssh "$pguix_host" "guix build -L '$remote_tmp/guix-tribes' -f '$remote_tmp/$name.scm' --no-grafts 2>&1" || true
+    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
 }
 
 extract_hash() {
@@ -156,47 +189,64 @@ extract_hash() {
 
 dummy_hash=0000000000000000000000000000000000000000000000000000
 
-raw_output=$(remote_run_scheme raw-mix-deps "(use-modules (guix gexp) (tribes packages source))
+raw_mix_deps_output() {
+  run_scheme raw-mix-deps "(use-modules (guix gexp) (tribes packages source))
 (fetch-mix-deps
-  (local-file \"$remote_tmp/tribes-source\" #:recursive? #t)
+  (local-file \"$source_root\" #:recursive? #t)
   #:name \"tribes-mix-deps-raw\"
   #:version \"$version\"
-  #: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
+  #:sha256 \"$dummy_hash\")"
 }
 
-mix_output=$(remote_run_scheme mix-deps "(use-modules (guix gexp) (tribes packages source))
+mix_deps_output() {
+  run_scheme mix-deps "(use-modules (guix gexp) (tribes packages source))
 (tribes-mix-deps
-  (local-file \"$remote_tmp/tribes-source\" #:recursive? #t)
+  (local-file \"$source_root\" #:recursive? #t)
   #:name \"tribes-mix-deps\"
   #:version \"$version\"
   #:raw-sha256 \"$raw_mix_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
+  #:sha256 \"$dummy_hash\")"
 }
 
-npm_output=$(remote_run_scheme npm-deps "(use-modules (guix gexp) (tribes packages source))
+npm_deps_output() {
+  run_scheme npm-deps "(use-modules (guix gexp) (tribes packages source))
 (fetch-npm-deps
-  (local-file \"$remote_tmp/tribes-source\" #:recursive? #t)
+  (local-file \"$source_root\" #:recursive? #t)
   #:mix-fod-deps
   (tribes-mix-deps
-    (local-file \"$remote_tmp/tribes-source\" #:recursive? #t)
+    (local-file \"$source_root\" #: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\")")
-npm_hash=$(printf '%s\n' "$npm_output" | extract_hash) || {
-  printf 'Failed to extract npm deps hash.\n%s\n' "$npm_output" >&2
+  #: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
   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 \

tests/nbde-system-boot-store.scm

@@ -0,0 +1,31 @@
+(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

@@ -0,0 +1,16 @@
+(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

@@ -0,0 +1,78 @@
+(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

@@ -0,0 +1,32 @@
+(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

@@ -0,0 +1,123 @@
+(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

@@ -0,0 +1,47 @@
+(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

@@ -0,0 +1,146 @@
+(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

@@ -1,8 +1,38 @@
 (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")
 
@@ -10,21 +40,20 @@
     '()
     (deployment-request-plugins
      '(("schemaVersion" . "1")
-       ("action" . "apply")
-       ("deploymentProfile" . (("schemaVersion" . "1"))))))
+       ("action" . "apply"))))
 
   (test-equal "deployment request plugins preserve names"
     '("aether")
     (deployment-request-plugins
      '(("schemaVersion" . "1")
        ("action" . "apply")
-       ("deploymentProfile" . (("schemaVersion" . "1")
-                               ("plugins" . ("aether")))))))
+       ("plugins" . ("aether")))))
 
   (test-equal "host config plugins are updated in tribes block"
     '(("schemaVersion" . "1")
       ("tribes" . (("host" . "example.com")
-                   ("plugins" . ("aether"))))
+                   ("plugins" . ("aether"))
+                   ("disabledPlugins" . ())))
       ("edge" . (("certificateName" . "tribes"))))
     (host-config-with-plugins
      '(("schemaVersion" . "1")
@@ -33,4 +62,139 @@
        ("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

@@ -0,0 +1,530 @@
+(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

@@ -0,0 +1,145 @@
+(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

@@ -0,0 +1,76 @@
+(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

@@ -0,0 +1,362 @@
+(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

@@ -0,0 +1,13 @@
+(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

@@ -0,0 +1,27 @@
+(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

@@ -0,0 +1,21 @@
+(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

@@ -0,0 +1,340 @@
+(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

@@ -0,0 +1,12 @@
+(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

@@ -0,0 +1 @@
+ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAITestLegionSharedBuilder legion@example.invalid

tribes/ci/substitutes.scm

@@ -0,0 +1,281 @@
+(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

@@ -2,7 +2,7 @@
   #:use-module (guix records)
   #:use-module (srfi srfi-1)
   #:use-module (tribes packages plugins)
-  #:use-module (tribes plugins registry)
+  #:use-module (tribes plugins discovery)
   #: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
-            (guix-tribes-plugin-definition-by-name plugin-name)))
+            (tribes-plugin-definition-by-name plugin-name)))
        (unless plugin-definition
          (error "unknown tribes plugin" plugin-name))
        (tribes-plugin-definition-external-plugin plugin-definition)))
@@ -129,9 +129,8 @@
        (plugins
         (resolve-external-plugins
          (optional-string-list tribes-json "plugins" '())))
-       (sync-overlap-seconds
-        (optional-integer tribes-json "syncOverlapSeconds"
-                          (tribes-configuration-sync-overlap-seconds tribes-defaults)))
+       (disabled-plugins
+        (optional-string-list tribes-json "disabledPlugins" '()))
        (database-user
         (optional-string tribes-json "databaseUser"
                          (tribes-configuration-database-user tribes-defaults)))

tribes/config/system-facts.scm

@@ -0,0 +1,134 @@
+(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

@@ -0,0 +1,238 @@
+(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

@@ -0,0 +1,129 @@
+(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

@@ -0,0 +1,194 @@
+(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

@@ -0,0 +1,201 @@
+(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

@@ -0,0 +1,144 @@
+(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

@@ -0,0 +1,22 @@
+(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

@@ -1,58 +1,356 @@
 (define-module (tribes deploy executor)
   #:use-module (srfi srfi-1)
-  #:export (deployment-request-plugins
-            host-config-with-plugins
-            json-object?
-            json-ref
-            json-string-list-ref))
+  #: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))
 
-(define (json-object? value)
-  (and (list? value) (every pair? value)))
+(define (remove-item value items)
+  (filter (lambda (item) (not (equal? item value))) items))
 
-(define (json-ref object key)
-  (and (json-object? object)
-       (let ((entry (assoc key object)))
-         (and entry (cdr entry)))))
+(define (string-prefix? prefix value)
+  (and (string? prefix)
+       (string? value)
+       (<= (string-length prefix) (string-length value))
+       (string=? prefix (substring value 0 (string-length prefix)))))
 
-(define (json-string-list-ref object key)
-  (let ((value (json-ref object key)))
+(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)))
     (cond
-     ((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))
+     ((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)
      (else
-      (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))))
+      (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))))))))))

tribes/deploy/guix-helper.scm

@@ -0,0 +1,199 @@
+(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

@@ -0,0 +1,163 @@
+(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

@@ -0,0 +1,591 @@
+(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

@@ -0,0 +1,193 @@
+(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

@@ -0,0 +1,164 @@
+(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

@@ -0,0 +1,690 @@
+(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

@@ -0,0 +1,158 @@
+(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

@@ -0,0 +1,311 @@
+(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

@@ -0,0 +1,254 @@
+(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

@@ -0,0 +1,407 @@
+(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

@@ -1,326 +1,184 @@
 (define-module (tribes packages cli)
   #:use-module ((guix licenses) #:prefix license:)
-  #:use-module (guix build-system trivial)
+  #:use-module (guix build-system guile)
   #: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))
 
-(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")
+;; 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 (home-directory)
-           (or (getenv "HOME") "/root"))
+;; ---------------------------------------------------------------------------
+;; 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 (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-shell-program
+  (program-file "tribes"
+    #~(begin (use-modules (tribes deploy entry)) (main 'shell))
+    #:guile guile-for-guix))
 
 (define tribes-deploy-exec-program
-  (with-extensions
-   (list guile-json-4)
-   (program-file
-    "tribes-deploy-exec"
+  (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"
     #~(begin
-        (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"))
+        (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))
 
-          (define (home-directory)
-            (or (getenv "HOME") "/root"))
+(define tribes-modules-source
+  (local-file ".." "tribes-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 nbde-modules-source
+  (local-file "../../nbde" "nbde-modules" #:recursive? #t))
 
 (define tribes-command-package
   (package
     (name "tribes-command")
-    (version "0.1")
+    (version "0.2")
     (source #f)
-    (build-system trivial-build-system)
+    (build-system guile-build-system)
     (arguments
      (list
-      #: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)))))
+      #: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))
     (home-page "https://git.teralink.net/tribes/guix-tribes.git")
     (synopsis "Tribes node administration command")
     (description
-     "Command-line helper for updating and inspecting a deployed Tribes node.")
+     "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.")
     (license license:asl2.0)))

tribes/packages/cloud.scm

@@ -0,0 +1,78 @@
+(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/docker.scm

@@ -0,0 +1,73 @@
+(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

@@ -9,6 +9,7 @@
   #: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
@@ -20,7 +21,7 @@
                            name
                            version
                            sha256
-                           (go go)
+                           (go go-1.26)
                            (mod-root ".")
                            (delete-vendor? #t)
                            goproxy)
@@ -117,9 +118,13 @@ SOURCE."
              (if (string=? #$mod-root ".")
                  source-dir
                  (string-append source-dir "/" #$mod-root))
-           (when (and #$delete-vendor? (file-exists? "vendor"))
-             (delete-file-recursively "vendor"))
-           (invoke "go" "mod" "vendor")
+           (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")))
            (mkdir-p out)
            (copy-recursively "vendor" out #:keep-mtime? #t))))
    #:options
@@ -138,7 +143,7 @@ SOURCE."
                           description
                           license
                           vendor-sha256
-                          (go go)
+                          (go go-1.26)
                           (mod-root ".")
                           (sub-packages '("."))
                           (build-flags '("-trimpath"))

tribes/packages/kernel.scm

@@ -0,0 +1,168 @@
+(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

@@ -0,0 +1,146 @@
+(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

@@ -8,11 +8,12 @@
   #: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))
@@ -42,14 +43,14 @@ SOURCE according to mix.lock."
          (define cert-file
            (string-append work "/ca-certificates.crt"))
          (define hex-lib-dir
-           #$(file-append elixir-hex-otp28
-                          "/lib/elixir/"
-                          (version-major+minor
-                           (package-version elixir-otp28))))
+           (string-append
+            #$(file-append elixir-hex "/lib/elixir/1.19")
+            ":"
+            #$(file-append elixir-hex "/lib/elixir/1.18")))
          (define path
            (string-join
-            (list #$(file-append elixir-otp28 "/bin")
-                  #$(file-append elixir-hex-otp28 "/bin")
+            (list #$(file-append elixir "/bin")
+                  #$(file-append elixir-hex "/bin")
                   #$(file-append rebar3 "/bin")
                   #$(file-append bash-minimal "/bin")
                   #$(file-append coreutils "/bin")
@@ -109,17 +110,33 @@ SOURCE according to mix.lock."
 
          (mkdir-p out)
          (copy-recursively deps-dir out #:follow-symlinks? #t)
-         ;; 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"
-                 "{}"
-                 "+")))
+         ;; 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)))
    #:options
    `(#:hash ,(base32 sha256)
      #:hash-algo sha256
@@ -199,8 +216,7 @@ package-lock.json."
 
          (mkdir-p out)
          (copy-recursively (string-append plugin-assets-dir "/node_modules")
-                           out
-                           #:follow-symlinks? #t)))
+                           out)))
    #:options
    `(#:hash ,(base32 sha256)
      #:hash-algo sha256
@@ -263,16 +279,16 @@ MIX-FOD-DEPS as a pre-fetched dependency tree."
               (define cert-file
                 (string-append work "/ca-certificates.crt"))
               (define hex-lib-dir
-                #$(file-append elixir-hex-otp28
-                               "/lib/elixir/"
-                               (version-major+minor
-                                (package-version elixir-otp28))))
+                (string-append
+                 #$(file-append elixir-hex "/lib/elixir/1.19")
+                 ":"
+                 #$(file-append elixir-hex "/lib/elixir/1.18")))
               (define aclocal-path
                 (string-join (list #$@aclocal-dirs) ":"))
               (define path
                 (string-join
-                 (list #$(file-append elixir-otp28 "/bin")
-                       #$(file-append elixir-hex-otp28 "/bin")
+                 (list #$(file-append elixir "/bin")
+                       #$(file-append elixir-hex "/bin")
                        #$(file-append rebar3 "/bin")
                        #$(file-append bash-minimal "/bin")
                        #$(file-append coreutils "/bin")
@@ -312,7 +328,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" "4")
+              (setenv "MIX_OS_DEPS_COMPILE_PARTITION_COUNT" "6")
               (setenv "HEX_OFFLINE" "1")
               (setenv "MIX_REBAR" #$(file-append rebar3 "/bin/rebar3"))
               (setenv "MIX_REBAR3" #$(file-append rebar3 "/bin/rebar3"))
@@ -371,8 +387,8 @@ MIX-FOD-DEPS as a pre-fetched dependency tree."
               git-minimal
               nss-certs
               rebar3
-              elixir-otp28
-              elixir-hex-otp28)
+              elixir
+              elixir-hex)
         native-inputs))
       (inputs inputs)
       (arguments package-arguments)

tribes/packages/monitoring.scm

@@ -0,0 +1,80 @@
+(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

@@ -0,0 +1,117 @@
+(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

@@ -0,0 +1,230 @@
+(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

@@ -1,76 +0,0 @@
-(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

@@ -1,7 +1,6 @@
 (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)
@@ -21,7 +20,8 @@
                           fetch-npm-deps
                           mix-release-package))
   #:use-module ((tribes packages source)
-                #:select (tribes-source-directory->local-file
+                #:select (tribes-package
+                          tribes-source-directory->local-file
                           tribes-upstream-source))
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-13)
@@ -30,8 +30,18 @@
             tribes-plugin-definition
             tribes-plugin-definition?
             tribes-plugin-definition-name
+            tribes-plugin-definition-package-name
+            tribes-plugin-definition-version
+            tribes-plugin-definition-synopsis
+            tribes-plugin-definition-home-page
+            tribes-plugin-definition-provides
+            tribes-plugin-definition-requires
             tribes-plugin-definition-external-plugin
-            tribes-plugin-catalog-file
+            tribes-plugin-definition-from-package
+            tribes-external-plugin-from-package
+            tribes-plugin-definitions-provided-capabilities
+            tribes-plugin-definitions-required-capabilities
+            tribes-plugin-package
             tribes-external-plugin
             tribes-external-plugin?
             tribes-external-plugin-name
@@ -109,111 +119,200 @@ tracked in Git."
             (default '()))
   (external-plugin tribes-plugin-definition-external-plugin))
 
-(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 (tribes-plugin-package-metadata package)
+  (let ((metadata (assoc-ref (package-properties package) 'tribes-plugin)))
+    (if (and (list? metadata) (every pair? metadata)) metadata '())))
 
-         (define (json-object? value)
-           (and (list? value) (every pair? value)))
+(define (plugin-metadata-ref metadata key fallback)
+  (let ((entry (assoc key metadata)))
+    (if entry (cdr entry) fallback)))
 
-         (define (json-ref object key)
-           (and (json-object? object)
-                (let ((entry (assoc key object)))
-                  (and entry (cdr entry)))))
+(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-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 (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 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-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 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-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))))
 
-         (call-with-output-file #$output
-           (lambda (port)
-             (scm->json
-              `(("schemaVersion" . ,#$schema-version)
-                ("plugins" . ,(list->vector plugins)))
-              port)))))))
+(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=?))
 
-(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
+(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
           (or host-source
               (and host-source-directory
                    (tribes-source-directory->local-file host-source-directory))
               tribes-upstream-source))
-         (resolved-plugin-api-source
-          (file-append resolved-host-source "/tribes_plugin_api"))
+         (resolved-host-package
+          (and reuse-host-libs?
+               (or host-package tribes-package)))
          (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)))
+          #~(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))
          (mix-deps-source
-          (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))))
+          (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)))
          (asset-deps-source
           (or asset-deps
               (and build-assets?
@@ -224,21 +323,35 @@ under lib/*/ebin."
                     #:version version
                     #:sha256 asset-deps-sha256
                     #:assets-dir assets-directory
-                    #:setup-gexp plugin-api-setup-gexp))))
+                    #:setup-gexp source-setup-gexp))))
          (setup-gexp
           (if asset-deps-source
               #~(begin
-                  #$plugin-api-setup-gexp
+                  #$source-setup-gexp
+                  #$host-release-libs-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
-                                      #:follow-symlinks? #t)
-                    (invoke "chmod" "-R" "u+w" node-modules-dir)))
-              plugin-api-setup-gexp))
+                                      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)))
          (resolved-asset-build-gexp
           (cond
            ((not build-assets?) #~(begin))
@@ -250,101 +363,246 @@ under 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))))
-    (mix-release-package
-     plugin-source
+              #~(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
      #: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
-     (list autoconf
-           autoconf-wrapper
-           automake
-           gcc-toolchain
-           gawk
-           grep
-           gnu-make
-           libtool
-           linux-libre-headers
-           m4
-           node
-           perl
-           pkg-config
-           sed)
+     (append native-toolchain-inputs
+             (if build-assets? (list node) '()))
      #:path-inputs
-     (list autoconf
-           autoconf-wrapper
-           automake
-           gcc-toolchain
-           gawk
-           grep
-           gnu-make
-           libtool
-           linux-libre-headers
-           m4
-           node
-           perl
-           pkg-config
-           sed)
+     (append native-toolchain-inputs
+             (if build-assets? (list node) '()))
      #:aclocal-inputs
-     (list automake libtool)
+     (if (or native-deps? (not reuse-host-libs?)) (list automake libtool) '())
      #: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++"))
-         (setenv "CPP"
-                 (string-append #$(file-append gcc-toolchain "/bin/gcc")
-                                " -E"))
+         #$@(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"))))
+                '())
          #$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
-     #~(begin
-         #$resolved-asset-build-gexp
-         (invoke "mix" "compile")
-         #$resolved-asset-digest-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))
      #:install-gexp
      #~(begin
-         (mkdir-p out)
-         (copy-file "manifest.json" (string-append out "/manifest.json"))
+         (define (install-common-files)
+           (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)))))
 
-         (when (file-exists? "_build/prod/lib")
-           (copy-recursively "_build/prod/lib"
-                             (string-append out "/lib")
-                             #:follow-symlinks? #t))))))
+         (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))
 
 (define* (tribes-package-with-external-plugins host-package plugins
                                                #:key
@@ -396,6 +654,13 @@ 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))
@@ -422,12 +687,8 @@ build."
                   (and (every string? value) value))
                  (else #f))))
 
-            (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 cap-rx
+              (make-regexp "^[a-z][a-z0-9_-]*(\\.[a-z][a-z0-9_-]*)+@[1-9][0-9]*$"))
 
             (define (validate-capabilities plugin-name field caps)
               (for-each
@@ -439,29 +700,27 @@ build."
                                          plugin-name
                                          " -> "
                                          cap))))
-               caps))
+                              caps))
 
-            (define (plugin-metadata spec)
-              (let* ((expected-name (assoc-ref spec 'name))
-                     (path (assoc-ref spec 'path))
-                     (manifest-path (string-append path "/manifest.json")))
+            (define (plugin-manifest-metadata expected-slug path)
+              (let* ((manifest-path (string-append path "/manifest.json")))
                 (unless (file-exists? manifest-path)
-                  (error "plugin package missing manifest.json" expected-name path))
+                  (error "plugin package missing manifest.json" expected-slug path))
 
                 (let* ((manifest (json-file->scm manifest-path))
-                       (name (json-string-ref manifest "name"))
+                       (id (json-string-ref manifest "id"))
+                       (slug (json-string-ref manifest "slug"))
+                       (display-name (json-string-ref manifest "display_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
-                        (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)))))
+                       (provides (json-string-list-ref manifest "provides"))
+                       (requires (json-string-list-ref manifest "requires")))
                   (unless (and (json-object? manifest)
-                               name
+                               id
+                               slug
+                               display-name
                                version
                                entry-module
                                plugin-host-api
@@ -469,24 +728,31 @@ build."
                                provides
                                requires)
                     (error "plugin manifest failed schema validation"
-                           expected-name
+                           expected-slug
                            manifest-path))
-                  (unless (string=? name expected-name)
-                    (error "plugin package name does not match manifest name"
-                           expected-name
-                           name))
+                  (unless (string=? slug expected-slug)
+                    (error "plugin package slug does not match manifest slug"
+                           expected-slug
+                           slug))
                   (unless (string=? plugin-host-api #$host-api)
                     (error "plugin manifest host_api mismatch"
-                           name
+                           id
                            plugin-host-api
                            #$host-api))
-                  (validate-capabilities name "provides" provides)
-                  (validate-capabilities name "requires" requires)
-                  `((name . ,name)
+                  (validate-capabilities id "provides" provides)
+                  (validate-capabilities id "requires" requires)
+                  `((id . ,id)
+                    (name . ,slug)
+                    (slug . ,slug)
+                    (display-name . ,display-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
@@ -495,12 +761,20 @@ build."
                        item))
                 items)))
 
-            (define (manifest-provides path)
+            (define (manifest-capabilities path field)
               (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)))
+                     (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"))
 
             (define (find-host-manifest root)
               (let ((matches
@@ -516,8 +790,27 @@ build."
                           matches)
                     (error "host package manifest.json not found" root matches))))
 
-            (define (provider-names plugins capability)
-              (map (lambda (plugin) (assoc-ref plugin 'name))
+            (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))
                    (filter (lambda (plugin)
                              (member capability (assoc-ref plugin 'provides)))
                            plugins)))
@@ -527,8 +820,8 @@ build."
                (append-map
                 (lambda (cap)
                   (filter (lambda (provider)
-                            (not (string=? provider (assoc-ref plugin 'name))))
-                          (provider-names plugins cap)))
+                            (not (string=? provider (assoc-ref plugin 'id))))
+                          (provider-ids plugins cap)))
                 (assoc-ref plugin 'requires))))
 
             (define (ordered-plugins plugins)
@@ -536,38 +829,117 @@ build."
                          (remaining plugins))
                 (if (null? remaining)
                     ordered
-                    (let* ((ordered-names (map (lambda (plugin) (assoc-ref plugin 'name))
-                                               ordered))
+                    (let* ((ordered-ids (map (lambda (plugin) (assoc-ref plugin 'id))
+                                             ordered))
                            (ready
                             (filter
                              (lambda (plugin)
                                (every (lambda (dep)
-                                        (member dep ordered-names))
+                                        (member dep ordered-ids))
                                       (plugin-dependencies plugins plugin)))
                              remaining)))
                       (if (null? ready)
                           (error "plugin capability dependency cycle detected"
                                  (map (lambda (plugin)
-                                        (assoc-ref plugin 'name))
+                                        (assoc-ref plugin 'id))
                                       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 plugin-names (map (lambda (plugin) (assoc-ref plugin 'name)) plugins))
+            (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 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 names in assembled package" duplicate-names))
+              (error "duplicate plugin slugs in assembled package" duplicate-names))
 
             (let ((all-provided
                    (append host-provides
                            (append-map (lambda (plugin) (assoc-ref plugin 'provides))
-                                       plugins))))
+                                       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)))
               (for-each
                (lambda (plugin)
                  (let ((missing
@@ -581,6 +953,8 @@ 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

@@ -0,0 +1,435 @@
+(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

@@ -14,6 +14,7 @@
   #: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)
@@ -25,34 +26,35 @@
             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 stripped except for
-;; .git/HEAD in SCM dependencies.
+;; from the current Tribes mix.lock, with git metadata minimized for SCM
+;; dependencies.
 (define %tribes-raw-mix-deps-sha256
-  "0gl1qn26im9ggdk1l1hikp8602bc1a04qdih1hiwmqjwdagm8c81")
+  "1b6hwd2ii5323d4a4dq57dr6g5vnjn16c7bfffc7f8j6l2kmy93x")
 
 ;; 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
-  "1jzfsh3d2h6f30dq9i9kb13zglvifk7ap8inm106plamc1rmajbj")
+  "158k8zlmzv6y1abhqj20l14y172ndw1y4p5yr51jpf12a5gs4193")
 
 ;; 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
-  "1my46nw162265y8xh0xxfhbm3hd1d9vj3nkd9s1nrrida66siw91")
+  "18fzdwirgsq14ncd8xy1yyiyjhp0msf5qv51zhml0rgn2lqg6rg8")
 
 (define %tribes-home-page
   "https://git.teralink.net/tribes/tribes.git")
 
 (define %tribes-commit
-  "497c02d3b84fdb6f4289ad2276638fb557b90572")
+  "f096578ec153342b29abfc5e900a82aefa378cb7")
 
 (define %tribes-revision "1")
 
@@ -60,7 +62,7 @@
   (git-version "0.2.0" %tribes-revision %tribes-commit))
 
 (define %tribes-source-sha256
-  "0118rdpnpn3qnm3r7v9fhys760sq1nw9590z41ly6ydj4zwyyb9m")
+  "0hcrf3b8ddp6a65si92slr3vrnvib855h4pyccgrsk10q34qapas")
 
 (define %tribes-upstream-source
   (origin
@@ -307,6 +309,7 @@ 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
@@ -314,7 +317,8 @@ 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."
+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."
   (let* ((mix-deps-source
           (or mix-deps
               (tribes-mix-deps source
@@ -384,6 +388,8 @@ mix.lock and assets/package-lock.json."
                        (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"
@@ -411,6 +417,15 @@ mix.lock and assets/package-lock.json."
      #~(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))
@@ -462,20 +477,62 @@ mix.lock and assets/package-lock.json."
          (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/" #$name))
-               (launcher-app (string-append out "/bin/" #$name "-app")))
+         (let ((launcher (string-append out "/bin/tribes"))
+               (launcher-app (string-append out "/bin/tribes-app")))
            (when (file-exists? launcher)
              (rename-file launcher launcher-app)))
 
          (when (file-exists? "plugins")
            (copy-recursively "plugins"
                              (string-append out "/plugins")
-                             #:follow-symlinks? #t))))))
+                             #: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$")))))))
 
 (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))
@@ -485,12 +542,95 @@ 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

@@ -2,13 +2,14 @@
   #:use-module (gnu packages)
   #:use-module (gnu packages bash)
   #:use-module (gnu packages base)
-  #:use-module (gnu packages curl)
+  #:use-module (gnu packages compression)
+  #:use-module (gnu packages crypto)
   #:use-module (gnu packages jemalloc)
-  #:use-module (gnu packages libevent)
   #:use-module (gnu packages linux)
-  #:use-module (gnu packages lsof)
+  #:use-module (gnu packages lua)
   #: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)
@@ -17,6 +18,7 @@
   #: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)
@@ -24,97 +26,89 @@
   #:use-module (guix packages)
   #:use-module (guix utils)
   #:use-module (tribes packages go)
-  #:export (hitch
+  #:export (aws-lc-for-haproxy
+            haproxy
             vinyl
             lego))
 
-(define-public hitch
+(define-public aws-lc-for-haproxy
   (package
-    (name "hitch")
-    (version "1.8.0")
-    (home-page "https://hitch-tls.org/")
-    (build-system gnu-build-system)
-    (arguments
-     `(#: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"))))))))))
+    (name "aws-lc")
+    (version "1.73.0")
     (source
      (origin
        (method url-fetch)
-       (uri (string-append "https://hitch-tls.org/source/hitch-"
-                           version
-                           ".tar.gz"))
+       (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 "0klg2pfsbhjdabjv52i0gfjfv23r45n4vs3965xa5zkzpj299jfz"))))
-    (native-inputs
-     (list pkg-config
+        (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)))
 
-           ;; For tests.
-           curl
-           grep
-           lsof
-           procps
-           python))
+(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"))))
+    (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))))
     (inputs
-     (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)))
+     (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+))))
 
 (define-public vinyl
   (package
@@ -137,6 +131,10 @@ multicore machines.")
             (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))
@@ -144,11 +142,19 @@ multicore machines.")
                (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"
@@ -185,9 +191,7 @@ multicore machines.")
                    (,(dirname
                       (search-input-file inputs "lib/libc.so")))))))))))
     (native-inputs
-     (list pkg-config
-           python-sphinx
-           python-docutils))
+     (list pkg-config))
     (inputs
      (list bash-minimal
            coreutils-minimal

tribes/plugins/aether.scm

@@ -1,11 +1,81 @@
 (define-module (tribes plugins aether)
+  #:use-module (guix git-download)
+  #:use-module (guix packages)
+  #:use-module (guix utils)
   #:use-module (tribes packages plugins)
-  #:export (aether-plugin-definition
+  #:use-module (tribes packages source)
+  #:export (aether-package
+            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
-  "008s3k3ry3jy13q1gx7l5i0ygr012xqybm8l0zaf1cxbx6mw9nfr")
+  "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))
 
 (define* (local-aether-package directory
                                #:key
@@ -14,6 +84,7 @@
                                (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."
@@ -24,30 +95,25 @@ 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 "https://git.teralink.net/tribes/tribes-plugin-aether.git"
+   #: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 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-plugin-definition #:key package)
+(define* (aether-plugin-definition #:key (package aether-package))
   "Return the channel-owned plugin definition for Aether."
-  (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))))
+  (tribes-plugin-definition-from-package package))
 
 (define* (aether-external-plugin #:key package)
   "Return the channel-owned Guix integration record for the Aether plugin."
-  (tribes-external-plugin
-   (name "aether")
-   (package package)
-   (extra-packages '())
-   (extra-services (lambda (_node-config) '()))))
+  (tribes-external-plugin-from-package package))

tribes/plugins/built-ins.scm

@@ -0,0 +1,54 @@
+(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

@@ -0,0 +1,129 @@
+(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

@@ -0,0 +1,118 @@
+(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

@@ -1,23 +1,40 @@
 (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-catalog
-            guix-tribes-plugin-definition-by-name
+  #:export (guix-tribes-plugin-definition-by-name
             guix-tribes-plugin-definitions
-            guix-tribes-external-plugins))
+            guix-tribes-external-plugins
+            guix-tribes-plugin-substitute-packages))
 
 (define guix-tribes-plugin-definitions
   (list
-   (aether-plugin-definition)))
-
-(define guix-tribes-plugin-catalog
-  (tribes-plugin-catalog-file guix-tribes-plugin-definitions))
+   (aether-plugin-definition)
+   (kobold-plugin-definition)
+   (sender-plugin-definition)
+   (supertest-plugin-definition)
+   (trust-plugin-definition)))
 
 (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

@@ -0,0 +1,128 @@
+(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

@@ -0,0 +1,110 @@
+(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

@@ -0,0 +1,116 @@
+(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

@@ -0,0 +1,177 @@
+(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

@@ -0,0 +1,237 @@
+(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

@@ -1,137 +0,0 @@
-(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

@@ -1,12 +1,15 @@
 (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)
@@ -20,6 +23,7 @@
             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
@@ -49,7 +53,9 @@
   (webroot lego-certificate-configuration-webroot
            (default #f))
   (key-type lego-certificate-configuration-key-type
-            (default "ec256"))
+            (default "ec384"))
+  (acme-enabled? lego-certificate-configuration-acme-enabled?
+                 (default #t))
   (renew-days lego-certificate-configuration-renew-days
               (default #f))
   (requirement lego-certificate-configuration-requirement
@@ -76,17 +82,10 @@
 (define (lego-certificate-full-pem certificate)
   (string-append (lego-certificate-directory certificate) "/full.pem"))
 
-(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 (lego-certificate-last-run-log certificate)
+  (string-append (lego-certificate-directory certificate) "/last-run.log"))
 
-(define (ip-subject? subject)
+(define (subject-is-ip? subject)
   (and (not (string-any char-alphabetic? subject))
        (string-any (lambda (chr)
                      (or (char-numeric? chr)
@@ -94,6 +93,9 @@
                          (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 #\*)
@@ -129,7 +131,7 @@
      (if server
          (list "--server" server)
          '())
-     (if (any ip-subject? subjects)
+     (if (any subject-is-ip? subjects)
          (list "--disable-cn")
          '())
      (list "--key-type" key-type)
@@ -164,10 +166,11 @@
           (invoke #$(file-append openssl "/bin/openssl")
                   "req"
                   "-x509"
-                  "-newkey" "rsa:2048"
+                  "-newkey" "ec"
+                  "-pkeyopt" "ec_paramgen_curve:P-384"
                   "-keyout" #$key-output
                   "-out" #$initial-cert
-                  "-sha256"
+                  "-sha384"
                   "-days" "1"
                   "-nodes"
                   "-subj" #$(string-append "/CN=" primary-subject)
@@ -192,6 +195,7 @@
          (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")
@@ -215,11 +219,14 @@
                       (list "--dynamic")))))
     (program-file
      (string-append "lego-" (lego-certificate-configuration-name certificate))
-     (with-imported-modules '((gnu services herd)
-                              (guix build utils))
+     (with-imported-modules (source-module-closure
+                             '((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)
@@ -231,16 +238,39 @@
                    (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"))
-                 (run-args '#$run-arguments)
-                 (renew-args '#$renew-arguments))
+                          "/bin/lego")))
              (if (file-exists? #$certificate-file)
-                 (apply invoke lego renew-args)
-                 (apply invoke lego run-args)))
+                 (run-lego lego '#$renew-arguments)
+                 (run-lego-with-retry lego '#$run-arguments)))
 
            (when (and (file-exists? #$certificate-file)
                       (fullchain-changed?))
@@ -256,7 +286,8 @@
                  (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))))))))
+                     (lego-certificate-configuration-reload-services certificate)))))
+     #:guile (lookup-package-input guix "guile"))))
 
 (define (lego-certificate-service-symbol prefix certificate)
   (string->symbol
@@ -267,48 +298,50 @@
 (define (lego-renewal-services config)
   (append-map
    (lambda (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)))))
+     (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))))
+         '()))
    (lego-configuration-certificates config)))
 
 (define (lego-activation config)

tribes/services/logging.scm

@@ -0,0 +1,225 @@
+(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))))

tribes/services/tribes.scm

@@ -4,25 +4,28 @@
   #:use-module (gnu services databases)
   #:use-module (gnu services shepherd)
   #:use-module (gnu packages admin)
+  #:use-module (gnu packages linux)
   #:use-module (gnu packages rsync)
   #:use-module (gnu packages rust-apps)
   #:use-module (gnu packages tmux)
+  #:use-module (gnu packages video)
   #:use-module (gnu packages vim)
   #:use-module (gnu system shadow)
   #:use-module (guix gexp)
+  #: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 cli)
   #:use-module (tribes packages plugins)
-  #:use-module (tribes plugins registry)
+  #:use-module (tribes packages sender-runtime)
   #:use-module (tribes packages terminals)
   #:export (tribes-configuration
             tribes-configuration?
             tribes-configuration-package
             tribes-configuration-plugins
-            tribes-configuration-plugin-catalog
+            tribes-configuration-disabled-plugins
             tribes-configuration-user
             tribes-configuration-group
             tribes-configuration-working-directory
@@ -42,7 +45,6 @@
             tribes-configuration-sync-tls-cacertfile
             tribes-configuration-host-manifest
             tribes-configuration-admin-pubkeys
-            tribes-configuration-sync-overlap-seconds
             tribes-configuration-database-user
             tribes-configuration-database-name
             tribes-configuration-parrhesia-database-name
@@ -55,6 +57,8 @@
             tribes-configuration-dns-cluster-query
             tribes-configuration-extra-environment-variables
             tribes-configuration-log-file
+            tribes-configuration-open-files-soft-limit
+            tribes-configuration-open-files-hard-limit
             tribes-service-type))
 
 (define-record-type* <tribes-configuration>
@@ -64,8 +68,8 @@
            (default #f))
   (plugins tribes-configuration-plugins
            (default '()))
-  (plugin-catalog tribes-configuration-plugin-catalog
-                  (default #f))
+  (disabled-plugins tribes-configuration-disabled-plugins
+                    (default '()))
   (user tribes-configuration-user
         (default "tribes"))
   (group tribes-configuration-group
@@ -104,8 +108,6 @@
                  (default #f))
   (admin-pubkeys tribes-configuration-admin-pubkeys
                  (default '()))
-  (sync-overlap-seconds tribes-configuration-sync-overlap-seconds
-                        (default 300))
   (database-user tribes-configuration-database-user
                  (default "tribes"))
   (database-name tribes-configuration-database-name
@@ -129,7 +131,18 @@
   (extra-environment-variables tribes-configuration-extra-environment-variables
                                (default '()))
   (log-file tribes-configuration-log-file
-            (default "/var/log/tribes/tribes.log")))
+            (default "/var/log/tribes.log"))
+  (open-files-soft-limit tribes-configuration-open-files-soft-limit
+                         (default 32768))
+  (open-files-hard-limit tribes-configuration-open-files-hard-limit
+                         (default 65535)))
+
+(define %tribes-loopback-release-node
+  "tribes@127.0.0.1")
+
+(define %tribes-loopback-release-erlang-flags
+  (string-append "-kernel inet_dist_use_interface {127,0,0,1} "
+                 "inet_dist_listen_min 4370 inet_dist_listen_max 4379"))
 
 (define (tribes-accounts config)
   (list
@@ -181,7 +194,7 @@
 
 (define (tribes-release-node config)
   (or (tribes-configuration-release-node config)
-      (string-append "tribes@" (tribes-configuration-host config))))
+      %tribes-loopback-release-node))
 
 (define (tribes-effective-package config)
   (let ((package (tribes-configuration-package config))
@@ -197,26 +210,79 @@
         (and package
              (file-append package "/plugins")))))
 
-(define (tribes-effective-plugin-catalog config)
-  (or (tribes-configuration-plugin-catalog config)
-      guix-tribes-plugin-catalog))
-
 (define (tribes-deploy-directory config)
   (string-append (tribes-configuration-working-directory config) "/deploy"))
 
+(define (tribes-local-control-socket-file _config)
+  "/var/run/tribes/local-control.sock")
+
+(define (tribes-generated-configuration-file _config)
+  "/etc/tribes/configuration.scm")
+
+(define (tribes-human-friendly-configuration-file _config)
+  "/etc/config.scm")
+
+(define (tribes-generated-configuration-text)
+  (string-append
+   ";; Auto-generated by guix-tribes / Tribes local-control.\n"
+   ";; Edit /etc/tribes/host-config.json and /etc/tribes/system-facts.json instead.\n"
+   ";; This file is provided so Guix users can still discover the active system\n"
+   ";; configuration in a familiar place.\n\n"
+   "(use-modules (guix gexp)\n"
+   "             (gnu packages guile))\n\n"
+   "(with-extensions (list guile-json-4)\n"
+   "  (begin\n"
+   "    (use-modules (tribes system materialize))\n"
+   "    (tribes-operating-system-from-json-files\n"
+   "     #:host-config-file \"/etc/tribes/host-config.json\"\n"
+   "     #:system-facts-file \"/etc/tribes/system-facts.json\")))\n"))
+
+(define (tribes-migrations-log-file _config)
+  "/var/log/tribes-migrations.log")
+
 (define (tribes-plugin-profile-packages config)
   (append-map tribes-external-plugin-extra-packages
               (tribes-configuration-plugins config)))
 
+(define (tribes-runtime-binary-directories config)
+  (map (lambda (package)
+         (file-append package "/bin"))
+       (delete-duplicates
+        (filter identity
+                (append (list (tribes-effective-package config)
+                              inotify-tools)
+                        (tribes-plugin-profile-packages config))))))
+
+(define (tribes-profile-package-by-name packages name)
+  (find (lambda (package)
+          (string=? (package-name package) name))
+        packages))
+
+(define (tribes-sender-ffmpeg-package config)
+  (or (tribes-profile-package-by-name
+       (tribes-plugin-profile-packages config)
+       (package-name sender-ffmpeg))
+      (tribes-profile-package-by-name
+       (tribes-plugin-profile-packages config)
+       (package-name ffmpeg))))
+
 (define (tribes-launcher config command args)
   (define package
     (tribes-effective-package config))
   (define distribution
     (tribes-configuration-release-distribution config))
+  (define launch-distribution
+    (if (string=? command "start") distribution "none"))
+  (define sender-ffmpeg-package
+    (tribes-sender-ffmpeg-package config))
   (define env-setters
     (append
      (list
       #~(setenv "HOME" #$(tribes-configuration-working-directory config))
+      #~(setenv "TRIBES_STATE_DIR" #$(tribes-configuration-working-directory config))
+      #~(setenv "TRIBES_LOG_JSONL_PATH" "/var/log/tribes-combined.jsonl")
+      #~(setenv "FILESYSTEM_FSINOTIFY_EXECUTABLE_FILE"
+                #$(file-append inotify-tools "/bin/inotifywait"))
       #~(setenv "PHX_SERVER" "true")
       #~(setenv "PORT" #$(number->string
                           (tribes-configuration-listen-port config)))
@@ -230,6 +296,8 @@
                    config
                    (tribes-configuration-parrhesia-database-name config)))
       #~(setenv "PARRHESIA_RELAY_URL" #$(tribes-relay-url config))
+      #~(setenv "PARRHESIA_POOL_SIZE" "30")
+      #~(setenv "PARRHESIA_READ_POOL_SIZE" "30")
       #~(setenv "TRIBES_SYNC_HOST" #$(tribes-sync-host config))
       #~(setenv "TRIBES_SYNC_PORT"
                 #$(number->string
@@ -237,20 +305,41 @@
       #~(setenv "TRIBES_SYNC_BIND_ADDRESS"
                 #$(tribes-configuration-sync-bind-address config))
       #~(setenv "TRIBES_PLUGIN_DIR" #$(tribes-effective-plugin-directory config))
-      #~(setenv "TRIBES_PLUGIN_CATALOG" #$(tribes-effective-plugin-catalog config))
-      #~(setenv "TRIBES_SYNC_OVERLAP_SECONDS"
-                #$(number->string
-                   (tribes-configuration-sync-overlap-seconds config)))
+      #~(setenv "TRIBES_DISABLED_PLUGINS"
+                #$(string-join (tribes-configuration-disabled-plugins config) ","))
+      #~(setenv "TRIBES_LOCAL_CONTROL_SOCKET"
+                #$(tribes-local-control-socket-file config))
       #~(setenv "TRIBES_ADMIN_PUBKEYS"
                 #$(string-join
                    (tribes-configuration-admin-pubkeys config)
                    ","))
-      #~(setenv "RELEASE_DISTRIBUTION" #$distribution)
+      ;; The Tribes plugin manager dynamically adds external plugin ebin
+      ;; directories at runtime.  Elixir releases default to Erlang embedded
+      ;; mode, which prevents those newly added paths from being loaded during
+      ;; application startup.  Use interactive mode so packaged external
+      ;; plugins can be loaded after a rollout switches the service profile.
+      #~(setenv "RELEASE_MODE" "interactive")
+      #~(setenv "RELEASE_DISTRIBUTION" #$launch-distribution)
       #~(setenv "SSL_CERT_DIR" "/etc/ssl/certs")
-      #~(setenv "SSL_CERT_FILE" "/etc/ssl/certs/ca-certificates.crt"))
-     (if (string=? distribution "none")
+      #~(setenv "SSL_CERT_FILE" "/etc/ssl/certs/ca-certificates.crt")
+      #~(let ((existing-path (or (getenv "PATH") "")))
+          (setenv "PATH"
+                  (string-join
+                   (if (string-null? existing-path)
+                       (list #$@(tribes-runtime-binary-directories config))
+                       (append (list #$@(tribes-runtime-binary-directories config))
+                               (list existing-path)))
+                   ":"))))
+     (if sender-ffmpeg-package
+         (list #~(setenv "SENDER_FFMPEG_EXECUTABLE"
+                         #$(file-append sender-ffmpeg-package "/bin/ffmpeg")))
+         '())
+     (if (string=? launch-distribution "none")
          '()
-         (list #~(setenv "RELEASE_NODE" #$(tribes-release-node config))))
+         (list
+          #~(setenv "RELEASE_NODE" #$(tribes-release-node config))
+          #~(setenv "ERL_EPMD_ADDRESS" "127.0.0.1")
+          #~(setenv "ERL_AFLAGS" #$%tribes-loopback-release-erlang-flags)))
      (if (tribes-configuration-listen-address config)
          (list #~(setenv "BIND_ADDRESS"
                          #$(tribes-configuration-listen-address config)))
@@ -290,6 +379,7 @@
    (string-append "tribes-" command)
    #~(begin
        (use-modules (ice-9 textual-ports)
+                    (srfi srfi-1)
                     (srfi srfi-13))
 
        (define (read-secret path)
@@ -328,6 +418,18 @@
               "tribes-app"
               (cons #$command '#$args)))))
 
+(define (tribes-user-command config name command args)
+  (let ((launcher (tribes-launcher config command args)))
+    (program-file
+     (string-append "tribes-" name "-as-user")
+     #~(begin
+         (let* ((user (getpwnam #$(tribes-configuration-user config)))
+                (group (getgrnam #$(tribes-configuration-group config))))
+           (setgroups (vector (group:gid group)))
+           (setgid (group:gid group))
+           (setuid (passwd:uid user))
+           (execl #$launcher #$launcher))))))
+
 (define (tribes-activation config)
   #~(begin
       (use-modules (guix build utils)
@@ -336,10 +438,9 @@
       (let* ((user (getpwnam #$(tribes-configuration-user config)))
              (uid (passwd:uid user))
              (gid (passwd:gid user))
+             (log-dir (dirname #$(tribes-configuration-log-file config)))
              (dirs (append
                     (list #$(tribes-configuration-working-directory config)
-                          (dirname #$(tribes-configuration-log-file config))
-                          #$(tribes-deploy-directory config)
                           (dirname #$(tribes-configuration-secret-key-base-file config))
                           (dirname #$(tribes-configuration-release-cookie-file config))
                           (dirname #$(tribes-configuration-token-signing-secret-file config)))
@@ -347,80 +448,214 @@
                       (if (and plugin-dir
                                (not (string-prefix? "/gnu/store/" plugin-dir)))
                           (list plugin-dir)
-                          '())))))
+                          '()))))
+             (deploy-dir #$(tribes-deploy-directory config))
+             (generated-config-file #$(tribes-generated-configuration-file config))
+             (human-friendly-config-file
+              #$(tribes-human-friendly-configuration-file config))
+             (generated-config-text #$(tribes-generated-configuration-text)))
         (for-each
          (lambda (dir)
            (mkdir-p dir)
            (chown dir uid gid))
-         dirs))))
+         dirs)
+        (unless (string=? log-dir "/var/log")
+          (mkdir-p log-dir)
+          (chown log-dir uid gid))
+        (mkdir-p deploy-dir)
+        (chown deploy-dir 0 0)
+        (chmod deploy-dir #o700)
+        (mkdir-p (dirname generated-config-file))
+        (call-with-output-file generated-config-file
+          (lambda (port)
+            (display generated-config-text port)))
+        (chown generated-config-file 0 0)
+        (chmod generated-config-file #o644)
+        (when (false-if-exception (lstat human-friendly-config-file))
+          (delete-file human-friendly-config-file))
+        (symlink generated-config-file human-friendly-config-file))))
 
-(define (tribes-migrations-shepherd-service config)
-  (let ((launcher (tribes-launcher
-                   config
-                   "eval"
-                   '("Tribes.Release.migrate_with_storage_up()"))))
+(define (tribes-migration-runner-shepherd-service config provision expression)
+  (let* ((launcher (tribes-user-command
+                    config
+                    (symbol->string provision)
+                    "eval"
+                    (list expression)))
+         (capture-launcher
+          (program-file
+           "tribes-migrations-capture"
+           #~(begin
+               (dup2 1 2)
+               (execl #$launcher #$launcher))))
+         (log-file (tribes-migrations-log-file config))
+         (logged-launcher
+          (program-file
+           "tribes-migrations-logged"
+           #~(begin
+               (use-modules (ice-9 popen)
+                            (ice-9 rdelim))
+
+               (define (timestamp)
+                 (strftime "%Y-%m-%dT%H:%M:%S%z"
+                           (localtime (current-time))))
+
+               (define (write-end port)
+                 (format port "== tribes-migrations end ~a ==~%"
+                         (timestamp))
+                 (force-output port))
+
+               (let ((port (open-file #$log-file "a")))
+                 (format port "~%== tribes-migrations start ~a ==~%"
+                         (timestamp))
+                 (format port "launcher: ~a~%" #$launcher)
+                 (force-output port)
+                 (catch #t
+                   (lambda ()
+                     (let ((pipe (open-pipe* OPEN_READ #$capture-launcher)))
+                       (let loop ()
+                         (let ((line (read-line pipe 'concat)))
+                           (cond
+                            ((eof-object? line) #t)
+                            (else
+                             (display line)
+                             (display line port)
+                             (force-output port)
+                             (loop)))))
+                       (let ((status (close-pipe pipe)))
+                         (format port "exit status: ~a~%" status)
+                         (write-end port)
+                         (close-port port)
+                         (primitive-exit (if (zero? status) 0 1)))))
+                   (lambda args
+                     (format port "exception: ~s~%" args)
+                     (write-end port)
+                     (close-port port)
+                     (primitive-exit 1))))))))
     (list
      (shepherd-service
-      (documentation "Run Tribes database migrations.")
-      (provision '(tribes-migrations))
+      (documentation (string-append "Run Tribes migration expression: " expression))
+      (provision (list provision))
       (requirement '(postgres user-processes))
       (one-shot? #t)
+      (auto-start? #f)
       (start
        #~(lambda _
-           (zero? (spawn-command
-                   (list #$launcher)
-                   #:user #$(tribes-configuration-user config)
-                   #:group #$(tribes-configuration-group config)))))
+           (zero? (system* #$logged-launcher))))
       (respawn? #f)))))
 
+(define (tribes-migrations-shepherd-service config)
+  (tribes-migration-runner-shepherd-service
+   config
+   'tribes-migrations
+   "Tribes.Release.migrate_with_storage_up()"))
+
+(define (tribes-plugin-rollback-migrations-shepherd-service config)
+  (tribes-migration-runner-shepherd-service
+   config
+   'tribes-plugin-rollback-migrations
+   "Tribes.Release.rollback_plugins(0)"))
+
+(define (tribes-resource-limits config)
+  `((nofile
+     ,(tribes-configuration-open-files-soft-limit config)
+     ,(tribes-configuration-open-files-hard-limit config))))
+
 (define (tribes-shepherd-service config)
   (let ((launcher (tribes-launcher config "start" '())))
     (list
      (shepherd-service
-      (documentation "Run the Tribes application service.")
+     (documentation "Run the Tribes application service.")
       (provision '(tribes))
-      (requirement '(tribes-migrations networking user-processes))
+      (requirement '(tribes-local-control tribes-migrations networking
+                                          user-processes))
+      (auto-start? #f)
       (start
        #~(make-forkexec-constructor
           (list #$launcher)
           #:user #$(tribes-configuration-user config)
           #:group #$(tribes-configuration-group config)
-          #:log-file #$(tribes-configuration-log-file config)))
+          #:log-file #$(tribes-configuration-log-file config)
+          #:resource-limits '#$(tribes-resource-limits config)))
       (stop #~(make-kill-destructor))
       (respawn? #f)))))
 
-(define (tribes-deploy-shepherd-service _config)
-  (list
-   (shepherd-service
-    (documentation "Apply a pending Tribes deployment request.")
-    (provision '(tribes-deploy-apply))
-    (requirement '(user-processes))
-    (one-shot? #t)
-    (start
-     #~(lambda _
-         (zero? (system* #$(file-append tribes-command-package
-                                        "/bin/tribes-deploy-exec")
-                         "run-pending"))))
-    (respawn? #f))))
+(define (tribes-boot-start-shepherd-service config)
+  (let ((secret-key-file (tribes-configuration-secret-key-base-file config))
+        (token-file (tribes-configuration-token-signing-secret-file config))
+        (release-cookie-file (tribes-configuration-release-cookie-file config)))
+    (list
+     (shepherd-service
+      (documentation
+       "Start Tribes on boot once Legion-managed secrets have been installed.")
+      (provision '(tribes-boot-start))
+      (requirement '(postgres tribes-local-control networking user-processes))
+      (one-shot? #t)
+      (start
+       #~(lambda _
+           (define secret-files
+             (list #$secret-key-file #$token-file #$release-cookie-file))
+           (define missing
+             (let loop ((paths secret-files) (missing '()))
+               (cond
+                ((null? paths) (reverse missing))
+                ((file-exists? (car paths))
+                 (loop (cdr paths) missing))
+                (else
+                 (loop (cdr paths) (cons (car paths) missing))))))
+           (if (null? missing)
+               (start-service (lookup-service 'tribes))
+               (begin
+                 (for-each
+                  (lambda (path)
+                    (format (current-error-port)
+                            "not starting Tribes at boot; missing secret file: ~a~%"
+                            path))
+                  missing)
+                 #t))))
+      (respawn? #f)))))
+
+(define (tribes-local-control-launcher config)
+  (program-file
+   "tribes-local-control-launcher"
+   #~(begin
+       (setenv "TRIBES_LOCAL_CONTROL_GROUP"
+               #$(tribes-configuration-group config))
+       (setenv "TRIBES_LOCAL_CONTROL_SOCKET"
+               #$(tribes-local-control-socket-file config))
+       (setenv "TRIBES_CURRENT_CONFIG_FILE"
+               #$(tribes-human-friendly-configuration-file config))
+       (setenv "TRIBES_GUIX_HELPER"
+               #$(file-append tribes-command-package
+                              "/bin/tribes-guix-helper"))
+       (execl #$(file-append tribes-command-package
+                             "/bin/tribes-local-control")
+              "tribes-local-control"))))
+
+(define (tribes-local-control-shepherd-service config)
+  (let ((launcher (tribes-local-control-launcher config)))
+    (list
+     (shepherd-service
+      (documentation "Run the local Tribes control broker.")
+      (provision '(tribes-local-control))
+      (requirement '(user-processes))
+      (start
+       #~(make-forkexec-constructor
+          (list #$launcher)
+          #:log-file "/var/log/tribes-local-control.log"))
+      (stop #~(make-kill-destructor))
+      (respawn? #f)))))
 
 (define (tribes-root-shepherd-services config)
   (append (tribes-migrations-shepherd-service config)
+          (tribes-plugin-rollback-migrations-shepherd-service config)
           (tribes-shepherd-service config)
-          (tribes-deploy-shepherd-service config)))
-
-(define (tribes-sudoers-entries config)
-  `(("sudoers.d/tribes-deploy-exec"
-     ,(plain-file
-       "tribes-deploy-exec.sudoers"
-       (string-append
-        (tribes-configuration-user config)
-        " ALL=(root) NOPASSWD: /run/current-system/profile/bin/tribes-deploy-exec status\n"
-        (tribes-configuration-user config)
-        " ALL=(root) NOPASSWD: /run/current-system/profile/bin/tribes-deploy-exec apply *\n")))))
+          (tribes-boot-start-shepherd-service config)
+          (tribes-local-control-shepherd-service config)))
 
 (define (tribes-profile-packages config)
   (match (tribes-effective-package config)
     (#f (list tribes-command-package
+              inotify-tools
               rsync
               ripgrep
               fd
@@ -432,6 +667,7 @@
                      (tribes-plugin-profile-packages config)
                      (list
                       tribes-command-package
+                      inotify-tools
                       rsync
                       ripgrep
                       fd
@@ -448,8 +684,6 @@
                              tribes-accounts)
           (service-extension activation-service-type
                              tribes-activation)
-          (service-extension etc-service-type
-                             tribes-sudoers-entries)
           (service-extension shepherd-root-service-type
                              tribes-root-shepherd-services)
           (service-extension profile-service-type

tribes/services/victoriametrics.scm

@@ -0,0 +1,245 @@
+(define-module (tribes services victoriametrics)
+  #:use-module (gnu packages admin)
+  #: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 (tribes packages monitoring)
+  #:export (victoriametrics-configuration
+            victoriametrics-configuration?
+            victoriametrics-configuration-package
+            victoriametrics-configuration-user
+            victoriametrics-configuration-group
+            victoriametrics-configuration-storage-data-path
+            victoriametrics-configuration-http-listen-address
+            victoriametrics-configuration-retention-period
+            victoriametrics-configuration-extra-options
+            victoriametrics-configuration-open-files-soft-limit
+            victoriametrics-configuration-open-files-hard-limit
+            victoriametrics-service-type
+            vmagent-configuration
+            vmagent-configuration?
+            vmagent-configuration-package
+            vmagent-configuration-user
+            vmagent-configuration-group
+            vmagent-configuration-http-listen-address
+            vmagent-configuration-promscrape-config
+            vmagent-configuration-remote-write-url
+            vmagent-configuration-tmp-data-path
+            vmagent-configuration-extra-options
+            vmagent-configuration-open-files-soft-limit
+            vmagent-configuration-open-files-hard-limit
+            vmagent-service-type
+            default-vmagent-scrape-config-text))
+
+(define-record-type* <victoriametrics-configuration>
+  victoriametrics-configuration make-victoriametrics-configuration
+  victoriametrics-configuration?
+  (package victoriametrics-configuration-package
+           (default victoriametrics))
+  (user victoriametrics-configuration-user
+        (default "victoriametrics"))
+  (group victoriametrics-configuration-group
+         (default "victoriametrics"))
+  (storage-data-path victoriametrics-configuration-storage-data-path
+                     (default "/var/lib/victoriametrics"))
+  (http-listen-address victoriametrics-configuration-http-listen-address
+                       (default "127.0.0.1:8428"))
+  (retention-period victoriametrics-configuration-retention-period
+                    (default "90d"))
+  (extra-options victoriametrics-configuration-extra-options
+                 (default '()))
+  (open-files-soft-limit victoriametrics-configuration-open-files-soft-limit
+                         (default 32768))
+  (open-files-hard-limit victoriametrics-configuration-open-files-hard-limit
+                         (default 65535)))
+
+(define-record-type* <vmagent-configuration>
+  vmagent-configuration make-vmagent-configuration
+  vmagent-configuration?
+  (package vmagent-configuration-package
+           (default victoriametrics))
+  (user vmagent-configuration-user
+        (default "vmagent"))
+  (group vmagent-configuration-group
+         (default "vmagent"))
+  (http-listen-address vmagent-configuration-http-listen-address
+                       (default "127.0.0.1:8429"))
+  (promscrape-config vmagent-configuration-promscrape-config
+                     (default #f))
+  (remote-write-url vmagent-configuration-remote-write-url
+                    (default "http://127.0.0.1:8428/api/v1/write"))
+  (tmp-data-path vmagent-configuration-tmp-data-path
+                 (default "/var/lib/vmagent"))
+  (extra-options vmagent-configuration-extra-options
+                 (default '()))
+  (open-files-soft-limit vmagent-configuration-open-files-soft-limit
+                         (default 32768))
+  (open-files-hard-limit vmagent-configuration-open-files-hard-limit
+                         (default 65535)))
+
+(define %victoriametrics-accounts
+  (list
+   (user-group
+    (name "victoriametrics")
+    (system? #t))
+   (user-account
+    (name "victoriametrics")
+    (group "victoriametrics")
+    (system? #t)
+    (comment "VictoriaMetrics service user")
+    (home-directory "/var/lib/victoriametrics")
+    (shell (file-append shadow "/sbin/nologin")))))
+
+(define %vmagent-accounts
+  (list
+   (user-group
+    (name "vmagent")
+    (system? #t))
+   (user-account
+    (name "vmagent")
+    (group "vmagent")
+    (system? #t)
+    (comment "VictoriaMetrics agent user")
+    (home-directory "/var/lib/vmagent")
+    (shell (file-append shadow "/sbin/nologin")))))
+
+(define (chown-directory-gexp directory user group)
+  #~(begin
+      (mkdir-p #$directory)
+      (let ((uid (passwd:uid (getpwnam #$user)))
+            (gid (group:gid (getgrnam #$group))))
+        (chown #$directory uid gid))))
+
+(define (victoriametrics-activation config)
+  #~(begin
+      (use-modules (guix build utils))
+      #$(chown-directory-gexp
+         (victoriametrics-configuration-storage-data-path config)
+         (victoriametrics-configuration-user config)
+         (victoriametrics-configuration-group config))))
+
+(define (vmagent-activation config)
+  #~(begin
+      (use-modules (guix build utils))
+      #$(chown-directory-gexp
+         (vmagent-configuration-tmp-data-path config)
+         (vmagent-configuration-user config)
+         (vmagent-configuration-group config))))
+
+(define (option name value)
+  #~(string-append "-" #$name "=" #$value))
+
+(define (victoriametrics-resource-limits config)
+  `((nofile
+     ,(victoriametrics-configuration-open-files-soft-limit config)
+     ,(victoriametrics-configuration-open-files-hard-limit config))))
+
+(define (vmagent-resource-limits config)
+  `((nofile
+     ,(vmagent-configuration-open-files-soft-limit config)
+     ,(vmagent-configuration-open-files-hard-limit config))))
+
+(define (victoriametrics-shepherd-services config)
+  (match config
+    (($ <victoriametrics-configuration> package user group storage-data-path
+                                        http-listen-address retention-period
+                                        extra-options)
+     (list
+      (shepherd-service
+       (documentation "Run VictoriaMetrics single-node storage and query service.")
+       (provision '(victoria-metrics))
+       (requirement '(user-processes networking))
+       (start
+        #~(make-forkexec-constructor
+           (list #$(file-append package "/bin/victoria-metrics")
+                 #$(option "storageDataPath" storage-data-path)
+                 #$(option "httpListenAddr" http-listen-address)
+                 #$(option "retentionPeriod" retention-period)
+                 #$@extra-options)
+           #:user #$user
+           #:group #$group
+           #:log-file "/var/log/victoria-metrics.log"
+           #:resource-limits '#$(victoriametrics-resource-limits config)))
+       (stop #~(make-kill-destructor)))))))
+
+(define (default-vmagent-scrape-config-text)
+  (string-append
+   "global:\n"
+   "  scrape_interval: 15s\n"
+   "scrape_configs:\n"
+   "  - job_name: node-exporter\n"
+   "    static_configs:\n"
+   "      - targets: [\"127.0.0.1:9100\"]\n"
+   "  - job_name: victoria-metrics\n"
+   "    static_configs:\n"
+   "      - targets: [\"127.0.0.1:8428\"]\n"
+   "  - job_name: tribes\n"
+   "    metrics_path: /metrics\n"
+   "    static_configs:\n"
+   "      - targets: [\"127.0.0.1:4000\"]\n"
+   "  - job_name: vinyl-exporter\n"
+   "    static_configs:\n"
+   "      - targets: [\"127.0.0.1:9131\"]\n"))
+
+(define (vmagent-scrape-config-file config)
+  (or (vmagent-configuration-promscrape-config config)
+      (plain-file "vmagent-scrape.yml"
+                  (default-vmagent-scrape-config-text))))
+
+(define (vmagent-shepherd-services config)
+  (match config
+    (($ <vmagent-configuration> package user group http-listen-address
+                                _ remote-write-url tmp-data-path extra-options)
+     (let ((scrape-config (vmagent-scrape-config-file config)))
+       (list
+        (shepherd-service
+         (documentation "Run vmagent to scrape local node metrics.")
+         (provision '(vmagent))
+         (requirement '(victoria-metrics user-processes networking))
+         (start
+          #~(make-forkexec-constructor
+             (list #$(file-append package "/bin/vmagent")
+                   #$(option "httpListenAddr" http-listen-address)
+                   #$(option "promscrape.config" scrape-config)
+                   #$(option "remoteWrite.url" remote-write-url)
+                   #$(option "remoteWrite.tmpDataPath" tmp-data-path)
+                   #$@extra-options)
+             #:user #$user
+             #:group #$group
+             #:log-file "/var/log/vmagent.log"
+             #:resource-limits '#$(vmagent-resource-limits config)))
+         (stop #~(make-kill-destructor))))))))
+
+(define victoriametrics-service-type
+  (service-type
+   (name 'victoria-metrics)
+   (extensions
+    (list (service-extension account-service-type
+                             (const %victoriametrics-accounts))
+          (service-extension activation-service-type
+                             victoriametrics-activation)
+          (service-extension shepherd-root-service-type
+                             victoriametrics-shepherd-services)
+          (service-extension profile-service-type
+                             (compose list victoriametrics-configuration-package))))
+   (default-value (victoriametrics-configuration))
+   (description "Run VictoriaMetrics single-node storage and query service.")))
+
+(define vmagent-service-type
+  (service-type
+   (name 'vmagent)
+   (extensions
+    (list (service-extension account-service-type
+                             (const %vmagent-accounts))
+          (service-extension activation-service-type
+                             vmagent-activation)
+          (service-extension shepherd-root-service-type
+                             vmagent-shepherd-services)
+          (service-extension profile-service-type
+                             (compose list vmagent-configuration-package))))
+   (default-value (vmagent-configuration))
+   (description "Run vmagent for local metrics scraping.")))