giles
29127d8613
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 1m4s
Peers publish busy intervals per actor (iCal free/busy model — privacy- preserving, not event details). ev/peer-with-busy, ev/peer-busy; ev/federated-busy unions local availability-db busy + trusted peers' published busy (sorted); ev/federated-free? answers cross-instance availability, half-open, trust-gated (untrusted peers ignored). 219/219 green. Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
232 lines
7.8 KiB
Plaintext
232 lines
7.8 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))))))
|
|
|
|
(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!)
|
|
{:failures ev-fd-failures :total (+ ev-fd-pass ev-fd-fail) :passed ev-fd-pass :failed ev-fd-fail})))
|