chore: update Tribes pin for mesh sync refresh

Compile the in-tree tribes_ui Mix project during the Tribes release build and install its ebin output into the packaged plugin directory so the runtime plugin loader can load the entry module.

tests/tribes-deploy-current-guix.scm

@@ -59,12 +59,15 @@
   (let* ((root (fresh-root))
          (home (string-append root "/home"))
          (bin (string-append root "/bin"))
-         (path-guix (string-append bin "/guix")))
+         (path-guix (string-append bin "/guix"))
+         (expected-guix (if (file-exists? system-guix-binary)
+                            system-guix-binary
+                            path-guix)))
     (write-executable path-guix "#!/bin/sh\nexit 0\n")
     (with-env (("HOME" home)
                ("PATH" bin))
-      (test-equal "current-guix-binary falls back to guix on PATH"
+      (test-equal "current-guix-binary falls back after pulled profile"
-        path-guix
+        expected-guix
         (current-guix-binary))))
 
   (with-env (("GUILE_LOAD_PATH" "bad-load")
@@ -86,7 +89,7 @@
               (getenv "GUIX_PACKAGE_PATH")))))
 
   (let* ((root (fresh-root))
-         (profile (string-append root "/profile"))
+         (profile (string-append root "/.config/guix/current"))
          (guix (string-append profile "/bin/guix"))
          (module (string-append profile
                                 "/share/guile/site/3.0/tribes/example.scm")))
@@ -94,7 +97,7 @@
     (mkdir-p (dirname module))
     (call-with-output-file module
       (lambda (port) (display ";; fixture\n" port)))
-    (with-env (("HOME" (string-append root "/home"))
+    (with-env (("HOME" root)
                ("PATH" (string-append profile "/bin")))
       (test-equal "current-guix-module-file resolves under selected profile"
         module

tests/tribes-deploy-executor.scm

@@ -93,6 +93,15 @@
       (test-equal "channel commit is propagated to package ref"
         "abc123"
         (json-ref package-ref "commit"))
+      (let* ((channels (json-ref plan "resolved_channels"))
+             (channel (and (vector? channels) (> (vector-length channels) 0)
+                           (vector-ref channels 0))))
+        (test-equal "channel branch is preserved in resolved plan"
+          "main"
+          (json-ref channel "branch"))
+        (test-equal "channel introduction is preserved in resolved plan"
+          "intro123"
+          (json-ref (json-ref channel "introduction") "commit")))
       (test-equal "registry version is used"
         "0.1.0"
         (json-ref package-ref "version"))

tests/tribes-deploy-operations.scm

@@ -1,5 +1,6 @@
 (define-module (tests tribes-deploy-operations)
   #:use-module (ice-9 ftw)
+  #:use-module (ice-9 textual-ports)
   #:use-module (guix build utils)
   #:use-module (json)
   #:use-module (srfi srfi-1)
@@ -29,6 +30,17 @@
     ("resolved_channels" . #())
     ("resolved_plugins" . ((("name" . "supertest"))))))
 
+(define plan-with-channel-delta
+  '(("plan_hash" . "plan-with-channel-delta")
+    ("resolved_channels" . #((("channel_id" . "guix-tribes")
+                               ("url" . "https://git.example.test/guix-tribes.git")
+                               ("branch" . "dev")
+                               ("commit" . "abc123")
+                               ("introduction" . (("commit" . "intro123")
+                                                  ("fingerprint" . "0123456789ABCDEF0123456789ABCDEF01234567")))
+                               ("position" . 0))))
+    ("resolved_plugins" . ((("name" . "supertest"))))))
+
 (define (delete-if-present path)
   (when (false-if-exception (lstat path))
     (delete-file path)))
@@ -114,6 +126,9 @@
     (lambda (port)
       (scm->json (json-ready payload) port))))
 
+(define (read-text-file path)
+  (call-with-input-file path get-string-all))
+
 (define (make-fixture)
   (let* ((root (fresh-root))
          (deploy-directory (string-append root "/deploy"))
@@ -261,6 +276,34 @@
           (test-equal "no-channel-delta prepare does not switch"
             0 (get-switches))))))
 
+  (let* ((fixture (make-fixture))
+         (state (make-state-store (fixture->config fixture)))
+         (channels-file (assq-ref fixture 'channels-file)))
+    (call-with-output-file channels-file
+      (lambda (port)
+        (display "(list\n  (channel\n    (name 'guix)\n    (url \"https://git.example.test/guix.git\")\n    (branch \"master\")\n    (commit \"guix-commit\")))\n" port)))
+    (call-with-values (lambda () (make-fake-helper fixture))
+      (lambda (helper get-builds get-pulls get-switches)
+        (let* ((_prepared (prepare-plugins! state helper
+                                            (plan-plugins plan-with-channel-delta)
+                                            (plan-hash plan-with-channel-delta)
+                                            no-frame
+                                            #:plan plan-with-channel-delta
+                                            #:pull-required?
+                                            (plan-requires-pull?
+                                             plan-with-channel-delta)))
+               (channels-text (read-text-file channels-file)))
+          (test-assert "prepare preserves base guix channel"
+            (string-contains channels-text "guix-commit"))
+          (test-assert "prepare writes rollout channel branch"
+            (string-contains channels-text "(branch \"dev\")"))
+          (test-assert "prepare writes rollout channel commit"
+            (string-contains channels-text "(commit \"abc123\")"))
+          (test-assert "prepare writes rollout channel introduction"
+            (string-contains channels-text "intro123"))
+          (test-equal "channel-delta prepare pulls"
+            1 (get-pulls))))))
+
   (let* ((fixture (make-fixture))
          (state (make-state-store (fixture->config fixture))))
     (with-fake-rollback-herd

tribes/deploy/executor.scm

@@ -57,6 +57,9 @@
 (define (channel-commit channel)
   (or (json-ref channel "commit") ""))
 
+(define (channel-branch channel)
+  (or (json-ref channel "branch") "master"))
+
 (define (channel-position channel)
   (let ((value (json-ref channel "position")))
     (if (integer? value) value 0)))
@@ -115,7 +118,9 @@
 (define (channel->resolved channel)
   `(("channel_id" . ,(channel-id channel))
     ("url" . ,(channel-url channel))
+    ("branch" . ,(channel-branch channel))
     ("commit" . ,(channel-commit channel))
+    ("introduction" . ,(channel-introduction channel))
     ("position" . ,(channel-position channel))))
 
 (define (default-plugin-channel channels)

tribes/deploy/handlers.scm

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

tribes/deploy/operations.scm

@@ -134,6 +134,92 @@
          (updated (host-config-with-plugins host-config plugins)))
     (atomic-write-json-file host-config-file updated)))
 
+(define (resolved-channel-url channel)
+  (or (json-ref channel "url") ""))
+
+(define (resolved-channel-branch channel)
+  (or (json-ref channel "branch") "master"))
+
+(define (resolved-channel-commit channel)
+  (or (json-ref channel "commit") ""))
+
+(define (resolved-channel-introduction channel)
+  (let ((value (json-ref channel "introduction")))
+    (if (json-object? value) value '())))
+
+(define (guix-channel-name channel)
+  'tribes)
+
+(define (channel-form-name form)
+  (match form
+    (('channel fields ...)
+     (match (find (lambda (field)
+                    (and (pair? field) (eq? (car field) 'name)))
+                  fields)
+       (('name ('quote name)) name)
+       (('name name) name)
+       (_ #f)))
+    (_ #f)))
+
+(define (existing-base-channel-forms channels-file)
+  (if (file-exists? channels-file)
+      (let ((form (false-if-exception
+                   (call-with-input-file channels-file read))))
+        (match form
+          (('list forms ...)
+           (filter (lambda (form)
+                     (not (eq? (channel-form-name form) 'tribes)))
+                   forms))
+          (_ '())))
+      '()))
+
+(define (write-scheme-string port value)
+  (write (or value "") port))
+
+(define (write-channel-introduction port introduction)
+  (let ((commit (json-ref introduction "commit"))
+        (fingerprint (json-ref introduction "fingerprint")))
+    (when (and (string? commit) (string? fingerprint))
+      (display "\n    (introduction\n      (make-channel-introduction\n        " port)
+      (write-scheme-string port commit)
+      (display "\n        (openpgp-fingerprint\n          " port)
+      (write-scheme-string port fingerprint)
+      (display ")))" port))))
+
+(define (write-channel port channel)
+  (let ((commit (resolved-channel-commit channel))
+        (introduction (resolved-channel-introduction channel)))
+    (display "  (channel\n    (name '" port)
+    (display (guix-channel-name channel) port)
+    (display ")\n    (url " port)
+    (write-scheme-string port (resolved-channel-url channel))
+    (display ")\n    (branch " port)
+    (write-scheme-string port (resolved-channel-branch channel))
+    (display ")" port)
+    (unless (string=? commit "")
+      (display "\n    (commit " port)
+      (write-scheme-string port commit)
+      (display ")" port))
+    (write-channel-introduction port introduction)
+    (display ")\n" port)))
+
+(define (write-plan-channels! config plan)
+  (let ((channels (plan-resolved-channels plan)))
+    (when (and channels (not (null? channels)))
+      (let* ((channels-file (deploy-config-channels-file config))
+             (base-forms (existing-base-channel-forms channels-file)))
+        (call-with-output-file channels-file
+          (lambda (port)
+            (display "(list\n" port)
+            (for-each
+             (lambda (form)
+               (display "  " port)
+               (write form port)
+               (newline port))
+             base-forms)
+            (for-each (lambda (channel) (write-channel port channel)) channels)
+            (display ")\n" port)))))))
+
 (define (selected-system-path state)
   (state-store-selected-system-path state))
 
@@ -141,7 +227,8 @@
   (state-store-running-system-path state))
 
 (define* (prepare-plugins! state helper plugins plan-hash-value on-frame
-                           #:key (pull-required? #t))
+                           #:key plan
+                           (pull-required? #t))
   (let* ((cfg (state-store-config state))
          (existing (state-store-find-generation-by-plan-hash state plan-hash-value)))
     (state-store-write-status! state "running"
@@ -149,6 +236,8 @@
                                #:plan-hash plan-hash-value
                                #:phase "running")
     (record-host-config-update! state plugins)
+    (when plan
+      (write-plan-channels! cfg plan))
     (cond
      ;; Idempotency: if we already built this plan and the store path still
      ;; exists, just re-register the GC root and report ready.
@@ -411,6 +500,7 @@
   (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)
@@ -439,7 +529,8 @@
               snapshot)))
 
 (define* (submit-prepare! state worker helper plugins plan-hash-value
-                          #:key (pull-required? #t))
+                          #:key plan
+                          (pull-required? #t))
   (call-with-values
       (lambda ()
         (worker-submit!
@@ -452,6 +543,7 @@
              (%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

tribes/packages/source.scm

@@ -35,13 +35,13 @@
 ;; from the current Tribes mix.lock, with git metadata stripped except for
 ;; .git/HEAD in SCM dependencies.
 (define %tribes-raw-mix-deps-sha256
-  "0xb64ffi2339771jp9b9hq8742v16qkqrqx6m8lx0a02hq877w2y")
+  "1s7k3qaqnl7lj9jl5xrm9rx0rva23n3az2f99vqjwvibhnhnml0v")
 
 ;; 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
-  "1bbs2i7fwqnl1ihalra17kh9bm34by5c0jma18ksy7cjry70xybi")
+  "1q7p44xdm7xqbrg2z7pa86v8n89a56hlr9c5y31yd4slssb0r8mk")
 
 ;; Recursive sha256 of assets/node_modules generated from assets/package-lock.json
 ;; in an isolated build environment, with local file dependencies resolved from
@@ -53,7 +53,7 @@
   "https://git.teralink.net/tribes/tribes.git")
 
 (define %tribes-commit
-  "96da023db957784d711cbd791ae38dd376351857")
+  "d5d4d62b0f941b74749702c393743d2db009aba2")
 
 (define %tribes-revision "1")
 
@@ -61,7 +61,7 @@
   (git-version "0.2.0" %tribes-revision %tribes-commit))
 
 (define %tribes-source-sha256
-  "063vy13mhil3cnj1nb0ra2r8b5cq286z1ix7didkiifqyb3zdzyi")
+  "1pkl0xpf95n5ravqs1m79084l3nklfwjhsrzihyj1cpm01dfc5np")
 
 (define %tribes-upstream-source
   (origin
@@ -463,6 +463,10 @@ mix.lock and assets/package-lock.json."
          (invoke "mix" "phx.digest"))
      #:install-gexp
      #~(begin
+         (when (file-exists? "plugins/tribes_ui/mix.exs")
+           (with-directory-excursion "plugins/tribes_ui"
+             (invoke "mix" "compile")))
+
          (invoke "mix" "release" "--path" out)
          (let ((launcher (string-append out "/bin/" #$name))
                (launcher-app (string-append out "/bin/" #$name "-app")))
@@ -472,7 +476,17 @@ mix.lock and assets/package-lock.json."
          (when (file-exists? "plugins")
            (copy-recursively "plugins"
                              (string-append out "/plugins")
-                             #:follow-symlinks? #t))))))
+                             #:follow-symlinks? #t))
+
+         (let ((tribes-ui-ebin "_build/prod/lib/tribes_ui/ebin")
+               (tribes-ui-out (string-append out "/plugins/tribes_ui/ebin")))
+           (when (file-exists? tribes-ui-ebin)
+             (when (file-exists? tribes-ui-out)
+               (delete-file-recursively tribes-ui-out))
+             (mkdir-p (dirname tribes-ui-out))
+             (copy-recursively tribes-ui-ebin
+                               tribes-ui-out
+                               #:follow-symlinks? #t)))))))
 
 (define* (local-tribes-package directory
                                #:key

tribes/plugins/supertest.scm

@@ -16,15 +16,15 @@
   %supertest-home-page)
 
 (define %supertest-commit
-  "e042f3265db7a40d4d558132800238c6d466e8dd")
+  "c5b2a3b2e70082877d64697a991526f25d8a6671")
 
 (define %supertest-revision "1")
 
 (define %supertest-version
-  (git-version "0.1.0" %supertest-revision %supertest-commit))
+  (git-version "0.1.1" %supertest-revision %supertest-commit))
 
 (define %supertest-source-sha256
-  "1rv844pnvqpc6yzcyg6qb013vbyfg8kipr6mdxkb17434djsmn1c")
+  "097z65nhvci2r5qk7pb7w75ig9hsw8rplwbv89hi5n6kmqafdhq3")
 
 (define %supertest-mix-deps-sha256
   "0dacj6c9mhxw37ykksjbhmnsqdhrwpkfsbswm68d2wvcwchqazw9")
@@ -90,7 +90,7 @@
   (tribes-plugin-definition
    (name "supertest")
    (package-name "tribes-plugin-supertest")
-   (version "0.1.0")
+   (version "0.1.1")
    (synopsis "Supertest fixture plugin for Tribes")
    (home-page %supertest-home-page)
    (provides '("supertest@1"))

tribes/system/node.scm

@@ -1,5 +1,6 @@
 (define-module (tribes system node)
   #:use-module (gnu packages databases)
+  #:use-module (gnu packages linux)
   #:use-module (gnu services)
   #:use-module (gnu services databases)
   #:use-module (gnu services linux)
@@ -292,7 +293,10 @@
                       postgresql-role-service-type
                       (tribes-node-postgresql-roles config))
       (service tribes-service-type
-               tribes))
+               tribes)
+      (simple-service 'tribes-node-network-tools
+                      profile-service-type
+                      (list iptables)))
      (tribes-node-bbr-services config)
      plugin-services
      (if (tribes-node-configuration-edge config)