giles
c991c7c3d3
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 41s
fetch abstracts how a peer's agenda arrives: (fetch peer-id ws we) ->
{:status :ok :occurrences} | {:status :error}. ev/federated-agenda-via merges
local + trusted peers fetched via the transport; unreachable peers degrade
gracefully. ev/peer-fetch = in-process adapter; ev/federation-status reports
reachability. A real fed-sx transport drops in unchanged. 278/278 green.
Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
290 lines
10 KiB
Plaintext
290 lines
10 KiB
Plaintext
;; lib/events/tests/federation.sx — trust-gated cross-instance agenda merge.
|
|
|
|
(define ev-fd-pass 0)
|
|
(define ev-fd-fail 0)
|
|
(define ev-fd-failures (list))
|
|
|
|
(define
|
|
ev-fd-check!
|
|
(fn
|
|
(name got expected)
|
|
(if
|
|
(= got expected)
|
|
(set! ev-fd-pass (+ ev-fd-pass 1))
|
|
(do
|
|
(set! ev-fd-fail (+ ev-fd-fail 1))
|
|
(append!
|
|
ev-fd-failures
|
|
(str name "\n expected: " expected "\n got: " got))))))
|
|
|
|
;; Local schedule + two peers. Distinct start times make ordering legible.
|
|
(define
|
|
ev-fd-local
|
|
(fn
|
|
()
|
|
(ev/schedule
|
|
(ev/empty)
|
|
(quote yoga)
|
|
(ev-dt 2026 6 1 9 0)
|
|
60
|
|
nil
|
|
20)))
|
|
|
|
(define
|
|
ev-fd-berlin
|
|
(fn
|
|
()
|
|
(ev/peer
|
|
(quote berlin)
|
|
(ev/schedule
|
|
(ev/empty)
|
|
(quote meetup)
|
|
(ev-dt 2026 6 1 12 0)
|
|
90
|
|
nil
|
|
100))))
|
|
|
|
(define
|
|
ev-fd-paris
|
|
(fn
|
|
()
|
|
(ev/peer
|
|
(quote paris)
|
|
(ev/schedule
|
|
(ev/empty)
|
|
(quote salon)
|
|
(ev-dt 2026 6 1 15 0)
|
|
60
|
|
nil
|
|
30))))
|
|
|
|
(define
|
|
ev-fd-run-all!
|
|
(fn
|
|
()
|
|
(let
|
|
((local (ev-fd-local))
|
|
(peers (list (ev-fd-berlin) (ev-fd-paris)))
|
|
(ws (ev-date 2026 6 1))
|
|
(we (ev-date 2026 6 2)))
|
|
(do
|
|
(ev-fd-check!
|
|
"trusts a peer in the trust set"
|
|
(ev/trusts? (list (quote berlin)) (quote berlin))
|
|
true)
|
|
(ev-fd-check!
|
|
"does not trust a peer outside the set"
|
|
(ev/trusts? (list (quote berlin)) (quote paris))
|
|
false)
|
|
(ev-fd-check!
|
|
"trusted-peers filters to the trust set"
|
|
(map ev/peer-id (ev/trusted-peers peers (list (quote berlin))))
|
|
(list (quote berlin)))
|
|
(let
|
|
((fed (ev/federated-agenda local peers (list (quote berlin)) ws we)))
|
|
(do
|
|
(ev-fd-check!
|
|
"merge includes local + trusted peer only"
|
|
(map (fn (o) (list (get o :origin) (get o :id))) fed)
|
|
(list
|
|
(list :local (quote yoga))
|
|
(list (quote berlin) (quote meetup))))
|
|
(ev-fd-check!
|
|
"merge is sorted by start"
|
|
(map (fn (o) (get o :start)) fed)
|
|
(list
|
|
(ev-dt 2026 6 1 9 0)
|
|
(ev-dt 2026 6 1 12 0)))
|
|
(ev-fd-check!
|
|
"untrusted peer (paris) contributes nothing"
|
|
(len (ev/from-origin fed (quote paris)))
|
|
0)
|
|
(ev-fd-check!
|
|
"local occurrences tagged :local"
|
|
(map (fn (o) (get o :id)) (ev/from-origin fed :local))
|
|
(list (quote yoga)))
|
|
(ev-fd-check!
|
|
"peer occurrences tagged with the peer id"
|
|
(map
|
|
(fn (o) (get o :id))
|
|
(ev/from-origin fed (quote berlin)))
|
|
(list (quote meetup)))))
|
|
(let
|
|
((fed2 (ev/federated-agenda local peers (list (quote berlin) (quote paris)) ws we)))
|
|
(ev-fd-check!
|
|
"trusting both peers merges all three, sorted"
|
|
(map (fn (o) (list (get o :origin) (get o :id))) fed2)
|
|
(list
|
|
(list :local (quote yoga))
|
|
(list (quote berlin) (quote meetup))
|
|
(list (quote paris) (quote salon)))))
|
|
(let
|
|
((fed3 (ev/federated-agenda local peers (list) ws we)))
|
|
(do
|
|
(ev-fd-check!
|
|
"empty trust yields only local occurrences"
|
|
(map (fn (o) (get o :origin)) fed3)
|
|
(list :local))
|
|
(ev-fd-check!
|
|
"empty trust still includes local"
|
|
(len fed3)
|
|
1)))
|
|
(let
|
|
((rpeer (ev/peer (quote tokyo) (ev/schedule (ev/empty) (quote standup) (ev-dt 2026 6 1 8 0) 15 {:freq :daily :count 3} 5))))
|
|
(let
|
|
((pa (ev/peer-agenda rpeer ws (ev-date 2026 6 4))))
|
|
(do
|
|
(ev-fd-check!
|
|
"peer recurrence expands in the window"
|
|
(len pa)
|
|
3)
|
|
(ev-fd-check!
|
|
"every peer occurrence is tagged with the peer id"
|
|
(map (fn (o) (get o :origin)) pa)
|
|
(list (quote tokyo) (quote tokyo) (quote tokyo))))))))))
|
|
|
|
;; ---- federated free/busy ----
|
|
(define
|
|
ev-fd-fb-run-all!
|
|
(fn
|
|
()
|
|
(let
|
|
((local-db
|
|
(ev-avail-db
|
|
(list (ev-occ (quote yoga) (ev-dt 2026 6 1 9 0) 60))
|
|
(list (list (quote nia) (str (quote yoga) "@" (ev-dt 2026 6 1 9 0))))))
|
|
(berlin
|
|
(ev/peer-with-busy
|
|
(quote berlin)
|
|
(ev/empty)
|
|
(list
|
|
(list (quote nia)
|
|
(list (list (ev-dt 2026 6 1 14 0) (ev-dt 2026 6 1 15 0)))))))
|
|
(paris
|
|
(ev/peer-with-busy
|
|
(quote paris)
|
|
(ev/empty)
|
|
(list
|
|
(list (quote nia)
|
|
(list (list (ev-dt 2026 6 1 11 0) (ev-dt 2026 6 1 12 0))))))))
|
|
(let
|
|
((peers (list berlin paris)))
|
|
(do
|
|
;; peer-busy reads a peer's published intervals
|
|
(ev-fd-check!
|
|
"peer-busy returns published intervals for an actor"
|
|
(ev/peer-busy berlin (quote nia))
|
|
(list (list (ev-dt 2026 6 1 14 0) (ev-dt 2026 6 1 15 0))))
|
|
(ev-fd-check!
|
|
"peer-busy empty for an actor with nothing published"
|
|
(ev/peer-busy berlin (quote zed))
|
|
(list))
|
|
;; federated-busy unions local + trusted-peer busy, sorted
|
|
(ev-fd-check!
|
|
"federated-busy unions local + trusted peer, sorted"
|
|
(ev/federated-busy local-db (list berlin) (list (quote berlin)) (quote nia))
|
|
(list
|
|
(list (ev-dt 2026 6 1 9 0) (ev-dt 2026 6 1 10 0))
|
|
(list (ev-dt 2026 6 1 14 0) (ev-dt 2026 6 1 15 0))))
|
|
(ev-fd-check!
|
|
"untrusted peer busy is excluded from federated-busy"
|
|
(ev/federated-busy local-db peers (list (quote berlin)) (quote nia))
|
|
(list
|
|
(list (ev-dt 2026 6 1 9 0) (ev-dt 2026 6 1 10 0))
|
|
(list (ev-dt 2026 6 1 14 0) (ev-dt 2026 6 1 15 0))))
|
|
;; federated-free? considers both local and trusted-peer commitments
|
|
(ev-fd-check!
|
|
"free locally and on peers in an open window"
|
|
(ev/federated-free? local-db peers (list (quote berlin)) (quote nia) (ev-dt 2026 6 1 16 0) (ev-dt 2026 6 1 17 0))
|
|
true)
|
|
(ev-fd-check!
|
|
"not free during a LOCAL booking"
|
|
(ev/federated-free? local-db peers (list (quote berlin)) (quote nia) (ev-dt 2026 6 1 9 30) (ev-dt 2026 6 1 9 45))
|
|
false)
|
|
(ev-fd-check!
|
|
"not free during a TRUSTED PEER busy interval"
|
|
(ev/federated-free? local-db peers (list (quote berlin)) (quote nia) (ev-dt 2026 6 1 14 30) (ev-dt 2026 6 1 14 45))
|
|
false)
|
|
(ev-fd-check!
|
|
"free during an UNTRUSTED peer's busy interval (paris not trusted)"
|
|
(ev/federated-free? local-db peers (list (quote berlin)) (quote nia) (ev-dt 2026 6 1 11 15) (ev-dt 2026 6 1 11 45))
|
|
true)
|
|
(ev-fd-check!
|
|
"not free once paris is trusted too"
|
|
(ev/federated-free? local-db peers (list (quote berlin) (quote paris)) (quote nia) (ev-dt 2026 6 1 11 15) (ev-dt 2026 6 1 11 45))
|
|
false)
|
|
(ev-fd-check!
|
|
"federated-free? half-open at a busy edge"
|
|
(ev/federated-free? local-db peers (list (quote berlin)) (quote nia) (ev-dt 2026 6 1 15 0) (ev-dt 2026 6 1 16 0))
|
|
true))))))
|
|
|
|
;; ---- injected transport (fed-sx) ----
|
|
(define
|
|
ev-fd-tx-run-all!
|
|
(fn
|
|
()
|
|
(let
|
|
((local (ev/schedule (ev/empty) (quote yoga) (ev-dt 2026 6 1 9 0) 60 nil 20))
|
|
(berlin (ev/peer (quote berlin) (ev/schedule (ev/empty) (quote meetup) (ev-dt 2026 6 1 12 0) 90 nil 100)))
|
|
(ws (ev-date 2026 6 1))
|
|
(we (ev-date 2026 6 2)))
|
|
(let
|
|
((fetch (ev/peer-fetch (list berlin))))
|
|
(do
|
|
;; in-process adapter merges through the transport interface
|
|
(ev-fd-check!
|
|
"federated-agenda-via merges local + fetched peer"
|
|
(map (fn (o) (list (get o :origin) (get o :id)))
|
|
(ev/federated-agenda-via local (list (quote berlin)) ws we fetch))
|
|
(list (list :local (quote yoga)) (list (quote berlin) (quote meetup))))
|
|
;; an unreachable / unknown peer degrades gracefully
|
|
(ev-fd-check!
|
|
"an unreachable peer is skipped, agenda still served"
|
|
(map (fn (o) (get o :origin))
|
|
(ev/federated-agenda-via local (list (quote berlin) (quote ghost)) ws we fetch))
|
|
(list :local (quote berlin)))
|
|
;; reachability report
|
|
(ev-fd-check!
|
|
"federation-status reports per-peer reachability"
|
|
(ev/federation-status (list (quote berlin) (quote ghost)) ws we fetch)
|
|
(list (list (quote berlin) :ok) (list (quote ghost) :error)))
|
|
;; an explicit remote transport (returns occurrences directly)
|
|
(let
|
|
((remote-fetch
|
|
(fn
|
|
(pid rws rwe)
|
|
(if (= pid (quote tokyo))
|
|
{:status :ok
|
|
:occurrences (list (ev-occ (quote standup) (ev-dt 2026 6 1 8 0) 15))}
|
|
{:status :error :reason :unreachable}))))
|
|
(do
|
|
(ev-fd-check!
|
|
"a remote transport's occurrences merge with origin tags"
|
|
(map (fn (o) (list (get o :origin) (get o :id)))
|
|
(ev/federated-agenda-via local (list (quote tokyo)) ws we remote-fetch))
|
|
(list (list (quote tokyo) (quote standup)) (list :local (quote yoga))))
|
|
(ev-fd-check!
|
|
"remote transport error degrades to local only"
|
|
(map (fn (o) (get o :origin))
|
|
(ev/federated-agenda-via local (list (quote osaka)) ws we remote-fetch))
|
|
(list :local))))
|
|
;; no trusted peers -> only local
|
|
(ev-fd-check!
|
|
"no trusted peer ids yields only local"
|
|
(map (fn (o) (get o :origin))
|
|
(ev/federated-agenda-via local (list) ws we fetch))
|
|
(list :local)))))))
|
|
|
|
(define
|
|
ev-federation-tests-run!
|
|
(fn
|
|
()
|
|
(do
|
|
(set! ev-fd-pass 0)
|
|
(set! ev-fd-fail 0)
|
|
(set! ev-fd-failures (list))
|
|
(ev-fd-run-all!)
|
|
(ev-fd-fb-run-all!)
|
|
(ev-fd-tx-run-all!)
|
|
{:failures ev-fd-failures :total (+ ev-fd-pass ev-fd-fail) :passed ev-fd-pass :failed ev-fd-fail})))
|