rose-ash/lib/events/tests/federation.sx

;; 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))))))))))

(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!)
      {:failures ev-fd-failures :total (+ ev-fd-pass ev-fd-fail) :passed ev-fd-pass :failed ev-fd-fail})))