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