rose-ash/lib/events/federation.sx

;; lib/events/federation.sx — cross-instance calendar federation (trust-gated).
;;
;; A peer is another events instance that publishes a schedule (an events
;; store). We merge a peer's agenda into ours ONLY if we trust it — trust is a
;; set of peer ids, re-checked on every merge, so revoking a peer takes effect
;; immediately. Merged occurrences carry :origin provenance (:local for ours, or
;; the peer id) so a consumer always knows where a slot came from.
;;
;; This is the trust-gated stub: peers publish plain schedules and we fold the
;; trusted ones into a single sorted agenda. Real transport (fed-sx / signed
;; fetch) slots in behind `ev/peer-agenda` without changing the merge.
;;
;; Federated FREE/BUSY follows the iCal model: a peer publishes BUSY intervals
;; for an actor (not event details — privacy-preserving), and we union local +
;; trusted-peer busy to answer "is this actor free?" across instances.

(define ev/peer (fn (id store) {:id id :busy (list) :store store}))

;; A peer that also publishes free/busy: `busy` is a list of
;; (actor ((start end) ...)) pairs.
(define ev/peer-with-busy (fn (id store busy) {:id id :busy busy :store store}))

(define ev/peer-id (fn (p) (get p :id)))
(define ev/peer-store (fn (p) (get p :store)))
(define ev/peer-busy-table (fn (p) (get p :busy)))

(define
  ev-fed-member?
  (fn
    (x xs)
    (cond
      ((empty? xs) false)
      ((= x (first xs)) true)
      (else (ev-fed-member? x (rest xs))))))

;; Do we trust this peer id? (trust is a list of trusted peer ids.)
(define ev/trusts? (fn (trust peer-id) (ev-fed-member? peer-id trust)))

;; The trusted subset of a peer list.
(define
  ev/trusted-peers
  (fn
    (peers trust)
    (filter (fn (p) (ev/trusts? trust (ev/peer-id p))) peers)))

;; Tag occurrences with provenance.
(define ev-tag-origin (fn (occs origin) (map (fn (o) {:id (get o :id) :start (get o :start) :end (get o :end) :origin origin}) occs)))

;; A peer's agenda over [ws, we), tagged with the peer's id as :origin.
(define
  ev/peer-agenda
  (fn
    (peer ws we)
    (ev-tag-origin (ev/agenda (ev/peer-store peer) ws we) (ev/peer-id peer))))

;; ---- merge (sorted by start, then origin for ties) ----

(define
  ev-fed-before?
  (fn
    (a c)
    (cond
      ((< (get a :start) (get c :start)) true)
      ((> (get a :start) (get c :start)) false)
      (else (< (str (get a :origin)) (str (get c :origin)))))))

(define
  ev-fed-insert
  (fn
    (x sorted)
    (cond
      ((empty? sorted) (list x))
      ((ev-fed-before? x (first sorted)) (cons x sorted))
      (else (cons (first sorted) (ev-fed-insert x (rest sorted)))))))

(define
  ev-fed-sort
  (fn (xs) (reduce (fn (acc x) (ev-fed-insert x acc)) (list) xs)))

;; Local agenda (origin :local) merged with every TRUSTED peer's agenda,
;; sorted by start. Untrusted peers contribute nothing.
(define
  ev/federated-agenda
  (fn
    (local-store peers trust ws we)
    (let
      ((acc (list)))
      (begin
        (for-each
          (fn (o) (append! acc o))
          (ev-tag-origin (ev/agenda local-store ws we) :local))
        (for-each
          (fn
            (peer)
            (when
              (ev/trusts? trust (ev/peer-id peer))
              (for-each
                (fn (o) (append! acc o))
                (ev/peer-agenda peer ws we))))
          peers)
        (ev-fed-sort acc)))))

;; Filter a federated agenda to occurrences from one origin.
(define
  ev/from-origin
  (fn
    (agenda origin)
    (filter (fn (o) (= (get o :origin) origin)) agenda)))

;; ---- federated free/busy ----

;; A peer's published busy intervals for `actor` ((start end) ...), or empty.
(define
  ev/peer-busy
  (fn
    (peer actor)
    (let
      ((row (ev-fed-assoc actor (ev/peer-busy-table peer))))
      (if (nil? row) (list) (first (rest row))))))

(define
  ev-fed-assoc
  (fn
    (k pairs)
    (cond
      ((empty? pairs) nil)
      ((= (first (first pairs)) k) (first pairs))
      (else (ev-fed-assoc k (rest pairs))))))

;; All busy intervals for `actor` across the LOCAL availability db plus every
;; TRUSTED peer's published free/busy, merged and sorted by start.
;; `local-db` is an availability db (see availability.sx ev-build-avail).
(define
  ev/federated-busy
  (fn
    (local-db peers trust actor)
    (let
      ((acc (list)))
      (begin
        (for-each (fn (iv) (append! acc iv)) (ev-busy local-db actor))
        (for-each
          (fn
            (peer)
            (when
              (ev/trusts? trust (ev/peer-id peer))
              (for-each
                (fn (iv) (append! acc iv))
                (ev/peer-busy peer actor))))
          peers)
        (ev-sort-lists acc)))))

;; Half-open overlap of interval (s e) with window [qs, qe).
(define
  ev-fed-overlaps?
  (fn (iv qs qe) (and (< (first iv) qe) (< qs (first (rest iv))))))

;; Is `actor` free across [qs, qe) considering local + trusted-peer busy?
(define
  ev/federated-free?
  (fn
    (local-db peers trust actor qs qe)
    (not
      (some
        (fn (iv) (ev-fed-overlaps? iv qs qe))
        (ev/federated-busy local-db peers trust actor)))))

;; ---- injected transport (real fed-sx / signed fetch) ----
;; The in-process merge above expands a peer's local :store directly. In
;; production a peer's agenda arrives over a transport. `fetch` abstracts that:
;;   (fetch peer-id ws we) -> {:status :ok :occurrences (...)} | {:status :error :reason ...}
;; The same merge works for any transport; an unreachable peer (:error) is
;; skipped (graceful degradation), never breaking the agenda.

(define
  ev-find-peer
  (fn
    (peers pid)
    (cond
      ((empty? peers) nil)
      ((= (ev/peer-id (first peers)) pid) (first peers))
      (else (ev-find-peer (rest peers) pid)))))

;; In-process transport adapter: resolves a peer-id against a peer list and
;; expands its :store. Lets the in-process model run through the same `fetch`
;; interface a remote transport implements.
(define
  ev/peer-fetch
  (fn
    (peers)
    (fn
      (pid ws we)
      (let
        ((p (ev-find-peer peers pid)))
        (if
          (nil? p)
          {:status :error :reason :unknown-peer}
          {:status :ok :occurrences (ev/agenda (ev/peer-store p) ws we)})))))

;; Local agenda (:local) merged with each trusted peer's agenda fetched via the
;; injected `fetch` transport, sorted by start, tagged with :origin. Peers that
;; fail to fetch contribute nothing.
(define
  ev/federated-agenda-via
  (fn
    (local-store trusted-ids ws we fetch)
    (let
      ((acc (list)))
      (begin
        (for-each
          (fn (o) (append! acc o))
          (ev-tag-origin (ev/agenda local-store ws we) :local))
        (for-each
          (fn
            (pid)
            (let
              ((res (fetch pid ws we)))
              (when
                (= (get res :status) :ok)
                (for-each
                  (fn (o) (append! acc o))
                  (ev-tag-origin (get res :occurrences) pid)))))
          trusted-ids)
        (ev-fed-sort acc)))))

;; Reachability report: ((peer-id :ok|:error) ...) for the trusted peers.
(define
  ev/federation-status
  (fn
    (trusted-ids ws we fetch)
    (map
      (fn (pid) (list pid (get (fetch pid ws we) :status)))
      trusted-ids)))