Compare commits

...

21 Commits

Author SHA1 Message Date
bf7bd38010 events: timezone + DST support + 17 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 1m5s
timezone.sx: wall-clock LOCAL <-> absolute UTC. :fixed + :dst zones (std/dst
offsets + UTC transition rules, EU-style, no IANA DB) computed via calendar
helpers. ev-event-tz authors in local time; ev-expand expands tz events in
LOCAL time then converts each occurrence to UTC, so a 09:00 weekly meeting
stays 09:00 across a DST change (UTC instant shifts). Predefined utc/london/
paris. Plain events unaffected. 295/295 green.

Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 09:31:11 +00:00
c991c7c3d3 events: injected federation transport (fed-sx-ready) + 6 tests
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>
2026-06-07 08:12:37 +00:00
07e4cb5f4a events: reschedule notifications + 7 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 31s
ev/reschedule-notifications: when an event carries per-occurrence overrides,
reads the roster at each overridden occurrence's original occ-key and emits a
reschedule message per booked attendee (old-start/new-start/new-duration).
Idempotency key = original-key/reschedule/new-start. 272/272 green.

Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 07:47:00 +00:00
98ed2eebdf events: booking lifecycle notifications + 11 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 38s
booking-notify.sx walks the booking stream into ordered notifications by kind
(booked/promoted/held/confirmed/released/cancelled/waitlisted). Promotion
detected by folding the waitlist (a booking for a waitlisted actor is a
promotion). id=occ-key/seq -> idempotent re-derivation, no double-ping.
Connects ticketing to the delivery layer. 265/265 green.

Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 07:20:39 +00:00
b308effb9f events: per-occurrence overrides / reschedule (RECURRENCE-ID) + 6 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 41s
ev-with-override re-times/re-sizes a single instance of a series (keyed by
original start). ev-expand applies overrides after EXDATE/RDATE: agenda
re-sorts, instance moved out of window is dropped (slot vacated), no-op for a
non-occurring start. assoc for immutable event update. 254/254 green.

Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 06:52:02 +00:00
48f5b75cc2 events: RRULE EXDATE/RDATE exceptions + 8 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 34s
ev-event-full carries :exdate/:rdate. ev-expand-base = raw expansion;
ev-expand applies exceptions: RDATE adds in-window occurrences, EXDATE removes
matching starts, de-duped, EXDATE wins over RDATE and the rrule (RFC 5545).
RDATE-only events supported; plain ev-event unaffected. 248/248 green.

Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 06:26:15 +00:00
7446c24bde events: waitlist + auto-promotion + 21 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 34s
When full, ev/waitlist! queues actors FIFO (:waitlist/:unwaitlist on the
booking stream; waiting fold independent of the seat fold). ev/waitlist,
ev/waitlist-position, ev/leave-waitlist!. ev/cancel-promote! frees a seat and
auto-promotes the head of the queue to a confirmed booking. Idempotent.
240/240 green.

Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 05:59:19 +00:00
29127d8613 events: federated free/busy across trusted peers + 10 tests
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>
2026-06-07 05:32:04 +00:00
80174c7197 events: Phase 4 federation — trust-gated peer agenda merge + 13 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 17s
federation.sx: a peer publishes a schedule; ev/federated-agenda merges local
(origin :local) with trusted peers' agendas, sorted by start, tagged with
:origin provenance. Trust is a peer-id set re-checked per merge; untrusted
peers contribute nothing. Real transport slots behind ev/peer-agenda.
209/209 green — all four plan phases implemented.

Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 04:59:12 +00:00
f6c1d1e9bf events: reminders + digests from the agenda + 14 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 40s
reminders.sx bridges calendar + durable rosters to notify: ev/occurrence-
reminders (one per booked attendee, fires lead before start, idempotency key
occ-key/recipient/lead), ev/agenda-reminders (sorted by fire-at),
ev/due-reminders (fire-at <= now), ev/reminder->msg (notify wire shape),
ev/agenda-digest + ev/agenda-for-p. 196/196 green.

Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 04:34:49 +00:00
e35769411e events: notification delivery flows on lib/flow + 7 tests (Phase 3 start)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 34s
notify.sx: reminders + digests as durable flows over an injected transport.
A flow requests delivery (suspend); the host dispatch sends and resumes with
the outcome. At-least-once + idempotent (transport dedups by msg id; replay
logs outcomes). Retry rides suspend/resume with distinct per-attempt tags,
bounded by maxn. Digest delivers a batch with per-message outcomes.
182/182 green. Delivery core is the delivery-on-sx extraction seam.

Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 04:02:54 +00:00
05d5c46730 events: paid-ticket contract (commerce) over holds + 31 tests (Phase 2 done)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 42s
ticket.sx: checkout-request (events->commerce) + payment-result
(commerce->events) wire shapes — commerce imports the contract. ev/request-
ticket! holds a seat + emits a checkout request; ev/settle-payment! confirms
on :paid, releases on failure/expiry. Idempotent; late paid for a vanished
hold -> :paid-but-no-hold (refund signal). 175/175 green.

Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 03:34:15 +00:00
7153e742c8 events: provisional holds (hold/confirm/release) for paid tickets + 24 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 48s
Booking stream gains :hold/:confirm/:release; fold tracks per-actor seat state
(:held/:confirmed). A held seat counts toward capacity so a pending payment
can't be oversold. ev/hold! (capacity-safe), ev/confirm!, ev/release!,
ev/seat-state. Holds race test mirrors the booking race. 144/144 green.

Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 03:07:29 +00:00
24d4db3f0d events: wire persist-backed booking into api.sx + 10 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 35s
Durable booking path alongside in-memory: ev/book-occ!, ev/cancel-occ!,
ev/roster-occ, ev/seats-left-occ (capacity from scheduled event); ev/free-p?,
ev/next-free-p, ev/conflicts-p derive availability by replaying persist
booking streams. Reordered conformance preloads. 120/120 green.

Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 02:39:19 +00:00
9adeff1431 events: booking cancellation + seat release + 13 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 24s
Booking stream carries :booking/:cancel events; live roster is the folded
replay so cancelling frees a seat and capacity reopens. ev/cancel! (retrying
append-expect), no-op on unbooked, cancelled actor may re-book. Capacity count
is folded roster size. 110/110 green.

Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 02:09:58 +00:00
80a2dee22f events: capacity-safe transactional booking on persist + 24 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 36s
booking.sx: per-occurrence append-only stream, roster = replay. Booking
decided against an observed (roster, last-seq) snapshot, committed via
persist/append-expect — atomic check+append, no overbooking, no lock.
Explicit last-seat race test: two bookers, one booked, one conflict, roster
capped. Idempotent per actor. 97/97 green.

Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 01:44:43 +00:00
15e9503b05 events: api.sx — public events facade + 14 tests (Phase 1 complete)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 37s
Immutable store ({:events :bookings}) over calendar+availability:
ev/schedule, ev/book, ev/agenda, ev/agenda-for, ev/free?, ev/next-free,
ev/conflicts. Availability queries auto-widen expansion by longest event.
73/73 green. Phase 1 done.

Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 01:16:16 +00:00
4674b797cb events: next-free slot search + 6 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 35s
ev-next-free finds the earliest free slot >= after for a duration within a
horizon, probing 'after' + busy-interval ends via the busy_in rule (ev-free?).
Finds gaps, skips too-short gaps, half-open at edges. 59/59 green.

Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 00:49:42 +00:00
540933bfca events: availability.sx — free/busy + conflict detection on Datalog + 16 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 1m1s
occurrence/booking EDB; rules busy/conflict (canonical pair, half-open
overlap)/busy_in. API ev-busy, ev-conflicts, ev-has-conflict?, ev-free?
(transient qwindow). Integrates with calendar expansion. 53/53 green.

Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 00:23:51 +00:00
70aea21601 events: MONTHLY RRULE expansion (bymonthday + ordinal byday) + 13 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 44s
BYMONTHDAY (negative = from end), ordinal BYDAY ({:ord :wd}, last-weekday),
default day-of-month skipping short months. Weekly+monthly share ev-emit-occs.
37/37 green.

Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-06 23:52:39 +00:00
797c5f9147 events: Phase 1 calendar — DAILY/WEEKLY RRULE expansion + 24 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 32s
Civil date arithmetic (Hinnant), integer epoch-minute datetimes, bounded
windowed RRULE expansion (DAILY/WEEKLY with INTERVAL/COUNT/UNTIL/BYDAY),
multi-event merge. Conformance harness + scoreboard wired.

Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-06 23:48:34 +00:00
26 changed files with 5284 additions and 16 deletions

View File

@@ -1 +1 @@
{"sessionId":"bf20a443-9df8-4cb9-932e-8c6f4c4625c2","pid":1303602,"procStart":"253831081","acquiredAt":1779865895644}
{"sessionId":"c4d97db1-361c-4a04-a99b-c838f9385469","pid":2426590,"procStart":"349789073","acquiredAt":1780789990975}

251
lib/events/api.sx Normal file
View File

@@ -0,0 +1,251 @@
;; lib/events/api.sx — public events surface over calendar + availability.
;;
;; A `store` is an immutable value holding scheduled events and (in-memory)
;; bookings:
;;
;; {:events (event ...) :bookings ((actor key) ...)}
;;
;; The in-memory `:bookings` list supports pure, value-level queries. The
;; DURABLE booking path (ev/*-occ! and ev/*-p) keeps bookings in persist
;; streams via booking.sx — capacity-safe, cancellable, replayable — and
;; derives availability from those streams. Use the persist path for real
;; bookings; the in-memory path for projections and tests.
;;
;; All queries are windowed: agenda/free/next-free expand recurring events into
;; concrete occurrences within an explicit (or derived) window before running
;; the Datalog availability rules.
(define ev/store (fn (events bookings) {:bookings bookings :events events}))
(define ev/empty (fn () (ev/store (list) (list))))
(define ev/events (fn (store) (get store :events)))
(define ev/bookings (fn (store) (get store :bookings)))
;; Add a (constructed) event to the store.
(define
ev/add-event
(fn
(store event)
(ev/store (cons event (ev/events store)) (ev/bookings store))))
;; Schedule a fresh event from parts, returning the updated store. rrule may be
;; nil for a one-off. (Booking is separate — see ev/book.)
(define
ev/schedule
(fn
(store id dtstart duration rrule capacity)
(ev/add-event store (ev-event id dtstart duration rrule capacity))))
;; Record that `actor` holds the occurrence with `key` (in-memory only — see
;; ev/book-occ! for the durable, capacity-safe path).
(define
ev/book
(fn
(store actor key)
(ev/store
(ev/events store)
(cons (list actor key) (ev/bookings store)))))
;; The event with `id`, or nil.
(define
ev/event-by-id
(fn
(store id)
(reduce
(fn
(found ev)
(if (nil? found) (if (= (get ev :id) id) ev found) found))
nil
(ev/events store))))
;; Capacity of the event an occurrence belongs to (0 if unknown).
(define
ev/capacity-of
(fn
(store occ)
(let
((ev (ev/event-by-id store (get occ :id))))
(if (nil? ev) 0 (get ev :capacity)))))
;; The maximum event duration in the store (0 when empty) — used to widen
;; expansion windows so any occurrence overlapping a query is captured.
(define
ev/store-max-duration
(fn
(store)
(reduce
(fn (m ev) (max m (get ev :duration)))
0
(ev/events store))))
;; All occurrences across all events within [ws, we), ascending by start.
(define
ev/agenda
(fn (store ws we) (ev-expand-all (ev/events store) ws we)))
(define
ev-key-member?
(fn
(k keys)
(cond
((empty? keys) false)
((= k (first keys)) true)
(else (ev-key-member? k (rest keys))))))
;; Occurrence keys `actor` has booked (in-memory store).
(define
ev/actor-keys
(fn
(store actor)
(reduce
(fn
(acc b)
(if (= (first b) actor) (cons (first (rest b)) acc) acc))
(list)
(ev/bookings store))))
;; The agenda restricted to occurrences `actor` is booked into (in-memory).
(define
ev/agenda-for
(fn
(store actor ws we)
(let
((keys (ev/actor-keys store actor)))
(filter
(fn (o) (ev-key-member? (ev-occ-key o) keys))
(ev/agenda store ws we)))))
;; Build an availability db over occurrences expanded in [ws, we) using the
;; in-memory bookings.
(define
ev/avail-window-db
(fn
(store ws we)
(ev-avail-db (ev/agenda store ws we) (ev/bookings store))))
;; Is `actor` free across [qs, qe)? Expands a window wide enough (back by the
;; longest event) to capture any occurrence that could overlap.
(define
ev/free?
(fn
(store actor qs qe)
(ev-free?
(ev/avail-window-db store (- qs (ev/store-max-duration store)) qe)
actor
qs
qe)))
;; Earliest free slot of `duration` for `actor` in [after, horizon), or nil.
(define
ev/next-free
(fn
(store actor after duration horizon)
(ev-next-free
(ev/avail-window-db
store
(- after (ev/store-max-duration store))
horizon)
actor
after
duration
horizon)))
;; Overlapping double-bookings for `actor` among occurrences in [ws, we).
(define
ev/conflicts
(fn
(store actor ws we)
(ev-conflicts (ev/avail-window-db store ws we) actor)))
(define
ev/has-conflict?
(fn
(store actor ws we)
(> (len (ev/conflicts store actor ws we)) 0)))
;; ---- durable, persist-backed booking path ----
;; These take a persist backend `b` (persist/open) plus the schedule `store`.
;; Bookings live in per-occurrence streams (booking.sx); availability is derived
;; by replaying those streams for the occurrences in the query window.
;; Durably book `actor` into occurrence `occ` (dict {:id :start :end}),
;; capacity-safe. Returns the booking.sx result (:booked / :full / :already).
(define
ev/book-occ!
(fn
(b store actor occ)
(ev/book! b (ev-occ-key occ) (ev/capacity-of store occ) actor)))
;; Durably cancel `actor`'s seat on `occ`, freeing capacity.
(define
ev/cancel-occ!
(fn (b store actor occ) (ev/cancel! b (ev-occ-key occ) actor)))
;; Live roster / seats-left for a specific occurrence from persist.
(define ev/roster-occ (fn (b occ) (ev/roster b (ev-occ-key occ))))
(define
ev/seats-left-occ
(fn
(b store occ)
(ev/seats-left b (ev-occ-key occ) (ev/capacity-of store occ))))
;; Derive (actor key) booking pairs from the persist rosters of `occs`.
(define
ev/persist-bookings
(fn
(b occs)
(reduce
(fn
(acc occ)
(let
((key (ev-occ-key occ)))
(append
acc
(map (fn (actor) (list actor key)) (ev/roster b key)))))
(list)
occs)))
;; Availability db over [ws, we) with bookings sourced from persist streams.
(define
ev/avail-db-p
(fn
(b store ws we)
(let
((occs (ev/agenda store ws we)))
(ev-avail-db occs (ev/persist-bookings b occs)))))
;; Persist-backed availability queries (mirror the in-memory ev/free? etc).
(define
ev/free-p?
(fn
(b store actor qs qe)
(ev-free?
(ev/avail-db-p b store (- qs (ev/store-max-duration store)) qe)
actor
qs
qe)))
(define
ev/next-free-p
(fn
(b store actor after duration horizon)
(ev-next-free
(ev/avail-db-p b store (- after (ev/store-max-duration store)) horizon)
actor
after
duration
horizon)))
(define
ev/conflicts-p
(fn
(b store actor ws we)
(ev-conflicts (ev/avail-db-p b store ws we) actor)))
(define
ev/has-conflict-p?
(fn
(b store actor ws we)
(> (len (ev/conflicts-p b store actor ws we)) 0)))

177
lib/events/availability.sx Normal file
View File

@@ -0,0 +1,177 @@
;; lib/events/availability.sx — free/busy + conflict detection on Datalog.
;;
;; Availability is per-actor and is forward-chained Datalog over two EDB
;; relations:
;;
;; (occurrence Key EventId Start End) ; an expanded calendar occurrence
;; (booking Actor Key) ; actor attends/holds that occurrence
;;
;; The derived relations are the whole policy:
;;
;; busy(A,S,E) — A is committed for [S,E) (a booked occurrence)
;; conflict(A,O1,O2) — A double-booked into two overlapping occurrences
;; busy_in(A,QS,QE) — A is busy somewhere inside query window [QS,QE)
;;
;; Intervals are half-open [Start,End) in epoch minutes (see calendar.sx), so
;; adjacent slots (E == next start) do NOT conflict. Conflict pairs are
;; canonical (O1 < O2 by key) so each overlap is reported once. The same `busy`
;; rule answers "is A free in [QS,QE)?" (busy_in is empty) and feeds "when is A
;; next free?" (ev-next-free probes candidate slots with the same rule).
;; A stable key for an occurrence dict {:id :start :end}.
(define ev-occ-key (fn (occ) (str (get occ :id) "@" (get occ :start))))
(define
ev-occurrence-fact
(fn
(occ)
(list
(quote occurrence)
(ev-occ-key occ)
(get occ :id)
(get occ :start)
(get occ :end))))
(define ev-occurrence-facts (fn (occs) (map ev-occurrence-fact occs)))
(define ev-booking-fact (fn (actor key) (list (quote booking) actor key)))
(define ev-qwindow-fact (fn (qs qe) (list (quote qwindow) qs qe)))
;; Range restriction: each comparison's variables are bound by an earlier
;; positive literal (qwindow / busy precede the < tests). Conflict uses
;; (< O1 O2) on the keys so each overlapping pair is reported once.
(define
ev-avail-rules
(quote
((busy A S E <- (booking A O) (occurrence O _ S E))
(conflict
A
O1
O2
<-
(booking A O1)
(booking A O2)
(occurrence O1 _ S1 E1)
(occurrence O2 _ S2 E2)
(< O1 O2)
(< S1 E2)
(< S2 E1))
(busy_in A QS QE <- (qwindow QS QE) (busy A S E) (< S QE) (< QS E)))))
;; Build a Datalog db from EDB facts under the availability ruleset.
(define ev-build-avail (fn (facts) (dl-program-data facts ev-avail-rules)))
;; Convenience: build a db from occurrence dicts + booking pairs.
;; bookings is a list of (actor key) pairs.
(define
ev-avail-db
(fn
(occs bookings)
(ev-build-avail
(append
(ev-occurrence-facts occs)
(map
(fn (b) (ev-booking-fact (first b) (first (rest b))))
bookings)))))
;; Helper: insertion sort a list of (S E ...) lists ascending by S then E.
(define
ev-list-before?
(fn
(a b)
(cond
((< (first a) (first b)) true)
((> (first a) (first b)) false)
(else (< (first (rest a)) (first (rest b)))))))
(define
ev-list-insert
(fn
(x sorted)
(cond
((empty? sorted) (list x))
((ev-list-before? x (first sorted)) (cons x sorted))
(else (cons (first sorted) (ev-list-insert x (rest sorted)))))))
(define
ev-sort-lists
(fn (xs) (reduce (fn (acc x) (ev-list-insert x acc)) (list) xs)))
(define
ev-dedup-sorted
(fn
(xs)
(cond
((empty? xs) xs)
((empty? (rest xs)) xs)
((= (first xs) (first (rest xs))) (ev-dedup-sorted (rest xs)))
(else (cons (first xs) (ev-dedup-sorted (rest xs)))))))
;; All busy intervals (list S E) for an actor, ascending by start.
(define
ev-busy
(fn
(db actor)
(let
((rows (dl-query db (list (quote busy) actor (quote S) (quote E)))))
(ev-sort-lists (map (fn (b) (list (get b :S) (get b :E))) rows)))))
;; Distinct conflicting occurrence-key pairs for an actor (each pair once).
(define
ev-conflicts
(fn
(db actor)
(dl-query db (list (quote conflict) actor (quote O1) (quote O2)))))
(define
ev-has-conflict?
(fn (db actor) (> (len (ev-conflicts db actor)) 0)))
;; Is `actor` free across the whole window [qs,qe)? (no booked occurrence
;; overlaps it). Asserts a transient qwindow fact, queries, retracts.
(define
ev-free?
(fn
(db actor qs qe)
(do
(dl-assert! db (ev-qwindow-fact qs qe))
(let
((rows (dl-query db (list (quote busy_in) actor (quote QS) (quote QE)))))
(begin (dl-retract! db (ev-qwindow-fact qs qe)) (empty? rows))))))
;; ---- next-free slot search ----
;; The earliest start s >= `after` such that [s, s+duration) is entirely free
;; for `actor` and ends at or before `horizon`, or nil if none. The earliest
;; such slot must begin either at `after` or immediately after some busy
;; interval ends (classic interval packing), so those are the only candidates
;; we probe — each probe reuses the busy_in rule via ev-free?.
(define
ev-first-free
(fn
(db actor cands duration horizon)
(cond
((empty? cands) nil)
(else
(let
((s (first cands)))
(if
(and
(<= (+ s duration) horizon)
(ev-free? db actor s (+ s duration)))
s
(ev-first-free db actor (rest cands) duration horizon)))))))
(define
ev-next-free
(fn
(db actor after duration horizon)
(let
((ends (filter (fn (e) (>= e after)) (map (fn (iv) (first (rest iv))) (ev-busy db actor)))))
(ev-first-free
db
actor
(ev-dedup-sorted (sort (cons after ends)))
duration
horizon))))

View File

@@ -0,0 +1,102 @@
;; lib/events/booking-notify.sx — derive lifecycle notifications from the
;; booking stream, for delivery via notify.sx.
;;
;; Walking the append-only booking stream yields one notification per state
;; change, in order, classified by kind:
;;
;; :booked a confirmed booking
;; :promoted a booking for an actor who was on the waitlist (auto-promote)
;; :held a provisional hold (pending payment)
;; :confirmed a held seat became confirmed (payment succeeded)
;; :released a held seat was released (payment failed/expired)
;; :cancelled a seat was given up
;; :waitlisted an actor joined the waitlist
;;
;; Promotion is detected by folding the waitlist as we walk: a :booking for an
;; actor currently on the waitlist is a promotion, not a fresh booking.
;;
;; Each notification's id is occ-key/seq (the stream seq is unique and stable),
;; so re-deriving and re-delivering is idempotent — the notify transport dedups
;; on this id and never double-pings.
(define
ev-bn-kind
(fn
(typ promoted?)
(cond
((= typ :hold) :held)
((= typ :booking) (if promoted? :promoted :booked))
((= typ :confirm) :confirmed)
((= typ :cancel) :cancelled)
((= typ :release) :released)
((= typ :waitlist) :waitlisted)
(else nil))))
(define
ev-bn-update-waiting
(fn
(typ actor waiting)
(cond
((= typ :waitlist)
(if
(ev-bk-member? actor waiting)
waiting
(ev-bk-append waiting actor)))
((= typ :unwaitlist) (ev-bk-remove waiting actor))
((= typ :booking) (ev-bk-remove waiting actor))
((= typ :hold) (ev-bk-remove waiting actor))
(else waiting))))
(define ev-bn-mk (fn (occ-key label actor kind seq) {:id (str occ-key "/" seq) :event label :kind kind :recipient actor :seq seq}))
(define
ev-bn-step
(fn
(occ-key label events waiting)
(if
(empty? events)
(list)
(let
((e (first events)))
(let
((typ (persist/event-type e))
(actor (get (persist/event-data e) :actor))
(seq (persist/event-seq e)))
(let
((promoted? (and (= typ :booking) (ev-bk-member? actor waiting))))
(let
((kind (ev-bn-kind typ promoted?))
(waiting2 (ev-bn-update-waiting typ actor waiting)))
(if
(nil? kind)
(ev-bn-step occ-key label (rest events) waiting2)
(cons
(ev-bn-mk occ-key label actor kind seq)
(ev-bn-step occ-key label (rest events) waiting2))))))))))
;; The ordered lifecycle notifications for an occurrence's bookings. `label` is
;; a human-facing event id carried on each notification.
(define
ev/booking-notifications
(fn
(b occ-key label)
(ev-bn-step
occ-key
label
(persist/read b (ev-booking-stream occ-key))
(list))))
;; Filter notifications to a single kind.
(define
ev/notify-of-kind
(fn (notifs kind) (filter (fn (n) (= (get n :kind) kind)) notifs)))
;; Project a notification to notify.sx's (id recipient body) wire shape.
(define
ev/booking-notify->msg
(fn
(n)
(list
(get n :id)
(get n :recipient)
(list :booking-event (get n :kind) (get n :event)))))

372
lib/events/booking.sx Normal file
View File

@@ -0,0 +1,372 @@
;; lib/events/booking.sx — transactional, capacity-safe booking on persist.
;;
;; Each bookable occurrence has an append-only stream of booking events:
;;
;; :booking free booking — actor immediately holds a confirmed seat
;; :hold provisional hold — seat reserved while payment is pending
;; :confirm a held seat becomes confirmed (payment succeeded)
;; :release a held seat is abandoned (payment failed/expired) — seat freed
;; :cancel a held or confirmed seat is given up — seat freed
;;
;; The live state is the stream FOLDED in order into per-actor seat states
;; (:held / :confirmed); an actor in ANY state occupies a seat, so both held and
;; confirmed seats count toward capacity — a pending payment cannot be
;; oversold. A freed seat (release/cancel) reopens capacity.
;;
;; Capacity safety is the contract: two writers racing for the last seat must
;; NEVER both succeed. Seat-ACQUIRING writes (:booking, :hold) go through
;; persist's optimistic concurrency — `persist/append-expect` appends only if
;; the stream's last-seq still equals what the writer observed; else it returns
;; a conflict the writer retries. Seat-FREEING writes (:cancel, :release) and
;; the state transition (:confirm) never oversell, so they append directly.
(define ev-booking-stream (fn (occ-key) (str "booking:" occ-key)))
(define
ev-bk-member?
(fn
(x xs)
(cond
((empty? xs) false)
((= x (first xs)) true)
(else (ev-bk-member? x (rest xs))))))
(define
ev-bk-index
(fn
(xs x i)
(cond
((empty? xs) -1)
((= (first xs) x) i)
(else (ev-bk-index (rest xs) x (+ i 1))))))
(define ev-bk-append (fn (xs a) (append xs (list a))))
(define ev-bk-remove (fn (xs a) (filter (fn (x) (not (= x a))) xs)))
;; ---- per-actor state association list: ((actor state) ...) in join order ----
(define
ev-state-has?
(fn
(states actor)
(cond
((empty? states) false)
((= (first (first states)) actor) true)
(else (ev-state-has? (rest states) actor)))))
(define
ev-state-get
(fn
(states actor)
(cond
((empty? states) :none)
((= (first (first states)) actor) (first (rest (first states))))
(else (ev-state-get (rest states) actor)))))
(define
ev-state-del
(fn (states actor) (filter (fn (p) (not (= (first p) actor))) states)))
(define
ev-state-set
(fn
(states actor st)
(if
(ev-state-has? states actor)
(map (fn (p) (if (= (first p) actor) (list actor st) p)) states)
(append states (list (list actor st))))))
;; Fold the booking stream into per-actor seat states (join order preserved).
(define
ev-fold-states
(fn
(events)
(reduce
(fn
(acc e)
(let
((typ (persist/event-type e))
(actor (get (persist/event-data e) :actor)))
(cond
((= typ :booking) (ev-state-set acc actor :confirmed))
((= typ :hold) (ev-state-set acc actor :held))
((= typ :confirm)
(if
(ev-state-has? acc actor)
(ev-state-set acc actor :confirmed)
acc))
((= typ :cancel) (ev-state-del acc actor))
((= typ :release) (ev-state-del acc actor))
(else acc))))
(list)
events)))
(define
ev-states-of
(fn
(b occ-key)
(ev-fold-states (persist/read b (ev-booking-stream occ-key)))))
;; Live roster (actors holding a seat — held or confirmed), oldest active first.
(define
ev-booked-actors
(fn (b occ-key) (map (fn (p) (first p)) (ev-states-of b occ-key))))
(define
ev-actor-booked?
(fn (b occ-key actor) (ev-bk-member? actor (ev-booked-actors b occ-key))))
;; Live seat count (folded roster size — both held and confirmed seats).
(define
ev-booking-count
(fn (b occ-key) (len (ev-booked-actors b occ-key))))
;; Seat state for an actor: :held / :confirmed / :none.
(define
ev/seat-state
(fn (b occ-key actor) (ev-state-get (ev-states-of b occ-key) actor)))
;; 1-based seat number for an actor on the roster (0 if not booked).
(define
ev-seat-of
(fn
(actors actor)
(let
((i (ev-bk-index actors actor 0)))
(if (< i 0) 0 (+ i 1)))))
;; ---- seat-acquiring writes (capacity-guarded via append-expect) ----
;; One seat-acquiring attempt of `kind` (:booking or :hold) against an OBSERVED
;; snapshot (roster the writer saw + the last-seq). Returns :already / :full /
;; :conflict, or a success dict tagged with `ok-status`. :conflict means a
;; concurrent append landed since the snapshot — the caller must re-observe.
(define
ev-acquire-with-observed
(fn
(b occ-key capacity actor observed-actors expected kind ok-status)
(cond
((ev-bk-member? actor observed-actors) {:seat (ev-seat-of observed-actors actor) :actor actor :status :already})
((>= (len observed-actors) capacity) {:actor actor :capacity capacity :status :full})
(else
(let
((r (persist/append-expect b (ev-booking-stream occ-key) expected kind 0 {:actor actor})))
(if (persist/conflict? r) {:actual (persist/conflict-actual r) :actor actor :status :conflict} {:seat (+ (len observed-actors) 1) :actor actor :status ok-status}))))))
(define
ev-acquire!
(fn
(b occ-key capacity actor kind ok-status)
(let
((res (ev-acquire-with-observed b occ-key capacity actor (ev-booked-actors b occ-key) (persist/last-seq b (ev-booking-stream occ-key)) kind ok-status)))
(if
(= (get res :status) :conflict)
(ev-acquire! b occ-key capacity actor kind ok-status)
res))))
;; Capacity-safe confirmed booking (retrying on conflict).
(define
ev/book!
(fn
(b occ-key capacity actor)
(ev-acquire! b occ-key capacity actor :booking :booked)))
;; Capacity-safe provisional hold (retrying on conflict). The seat is reserved
;; (counts toward capacity) until confirmed or released.
(define
ev/hold!
(fn
(b occ-key capacity actor)
(ev-acquire! b occ-key capacity actor :hold :held)))
;; Test seam: one attempt against a caller-supplied snapshot (book or hold).
(define
ev/book-with-observed
(fn
(b occ-key capacity actor observed-actors expected)
(ev-acquire-with-observed
b
occ-key
capacity
actor
observed-actors
expected
:booking :booked)))
(define
ev/hold-with-observed
(fn
(b occ-key capacity actor observed-actors expected)
(ev-acquire-with-observed
b
occ-key
capacity
actor
observed-actors
expected
:hold :held)))
;; ---- state transitions / seat-freeing writes (no oversell, append direct) ----
;; Confirm a held seat (payment succeeded). :confirmed on success,
;; :already-confirmed if it was confirmed, :not-held otherwise.
(define
ev/confirm!
(fn
(b occ-key actor)
(let
((st (ev/seat-state b occ-key actor)))
(cond
((= st :held)
(begin
(persist/append
b
(ev-booking-stream occ-key)
:confirm 0
{:actor actor})
{:actor actor :status :confirmed}))
((= st :confirmed) {:actor actor :status :already-confirmed})
(else {:actor actor :status :not-held})))))
;; Release a held seat (payment failed/expired), freeing it. Only valid for a
;; held seat — confirmed bookings are given up via ev/cancel!.
(define
ev/release!
(fn
(b occ-key actor)
(let
((st (ev/seat-state b occ-key actor)))
(if
(= st :held)
(begin
(persist/append
b
(ev-booking-stream occ-key)
:release 0
{:actor actor})
{:actor actor :status :released})
{:actor actor :status :not-held}))))
;; Cancel a held or confirmed seat, freeing it. :cancelled or :not-booked.
(define
ev/cancel!
(fn
(b occ-key actor)
(if
(ev-bk-member? actor (ev-booked-actors b occ-key))
(begin
(persist/append
b
(ev-booking-stream occ-key)
:cancel 0
{:actor actor})
{:actor actor :status :cancelled})
{:actor actor :status :not-booked})))
;; The roster as a plain list of actors (oldest active first).
(define ev/roster (fn (b occ-key) (ev-booked-actors b occ-key)))
;; Seats remaining for an occurrence of the given capacity.
(define
ev/seats-left
(fn
(b occ-key capacity)
(max 0 (- capacity (ev-booking-count b occ-key)))))
;; ---- waitlist ----
;; When an occurrence is full, actors join a FIFO waitlist (:waitlist /
;; :unwaitlist events on the same stream). Taking a seat (:booking / :hold)
;; removes an actor from the queue, so the waitlist fold is independent of the
;; seat fold. Cancelling/releasing a seat can auto-promote the head of the
;; queue (a :booking appended for them).
(define
ev-fold-waiting
(fn
(events)
(reduce
(fn
(acc e)
(let
((typ (persist/event-type e))
(actor (get (persist/event-data e) :actor)))
(cond
((= typ :waitlist) (if (ev-bk-member? actor acc) acc (ev-bk-append acc actor)))
((= typ :unwaitlist) (ev-bk-remove acc actor))
((= typ :booking) (ev-bk-remove acc actor))
((= typ :hold) (ev-bk-remove acc actor))
(else acc))))
(list)
events)))
;; The current waitlist queue (FIFO, oldest first).
(define
ev/waitlist
(fn (b occ-key) (ev-fold-waiting (persist/read b (ev-booking-stream occ-key)))))
;; 1-based queue position for an actor (0 if not waiting).
(define
ev/waitlist-position
(fn (b occ-key actor) (ev-seat-of (ev/waitlist b occ-key) actor)))
;; Book if a seat is free, else join the waitlist. Idempotent: already seated →
;; :already; already queued → :already-waiting.
(define
ev/waitlist!
(fn
(b occ-key capacity actor)
(let
((seats (ev-booked-actors b occ-key))
(waiting (ev/waitlist b occ-key)))
(cond
((ev-bk-member? actor seats)
{:status :already :seat (ev-seat-of seats actor) :actor actor})
((ev-bk-member? actor waiting)
{:status :already-waiting :position (ev-seat-of waiting actor) :actor actor})
(else
(let
((r (ev/book! b occ-key capacity actor)))
(if
(= (get r :status) :booked)
r
(begin
(persist/append b (ev-booking-stream occ-key) :waitlist 0 {:actor actor})
{:status :waitlisted
:position (+ (len waiting) 1)
:actor actor}))))))))
;; Leave the waitlist. :left or :not-waiting.
(define
ev/leave-waitlist!
(fn
(b occ-key actor)
(if
(ev-bk-member? actor (ev/waitlist b occ-key))
(begin
(persist/append b (ev-booking-stream occ-key) :unwaitlist 0 {:actor actor})
{:status :left :actor actor})
{:status :not-waiting :actor actor})))
;; Cancel a seat and, if that frees capacity, auto-promote the head of the
;; waitlist (a confirmed booking). Returns the cancel result plus :promoted
;; (the actor promoted, or nil).
(define
ev/cancel-promote!
(fn
(b occ-key capacity actor)
(let
((c (ev/cancel! b occ-key actor)))
(if
(= (get c :status) :cancelled)
(let
((waiting (ev/waitlist b occ-key))
(seats (ev-booked-actors b occ-key)))
(if
(and (not (empty? waiting)) (< (len seats) capacity))
(let
((promoted (first waiting)))
(begin
(persist/append b (ev-booking-stream occ-key) :booking 0 {:actor promoted})
{:status :cancelled :actor actor :promoted promoted}))
{:status :cancelled :actor actor :promoted nil}))
c))))

614
lib/events/calendar.sx Normal file
View File

@@ -0,0 +1,614 @@
;; lib/events/calendar.sx — civil date arithmetic + RRULE expansion in a window.
;;
;; Datetimes are integer "epoch minutes": days-since-1970-01-01 * 1440 plus
;; minute-of-day. Ordering, window bounds, and durations are plain integer
;; arithmetic. Civil <-> day-number conversion uses Howard Hinnant's algorithm
;; (exact, branch-free, correct for the proleptic Gregorian calendar).
;;
;; RRULE expansion is the bridge to Datalog: a recurring event expands to a
;; bounded list of occurrence dicts within an explicit (win-start, win-end)
;; window. Expansion is ALWAYS windowed — an RRULE without a window is an
;; infinite computation and is never permitted. Supported subset (RFC 5545):
;; FREQ=DAILY|WEEKLY|MONTHLY, INTERVAL, COUNT, UNTIL, BYDAY (weekly: weekday
;; numbers; monthly: {:ord N :wd W} ordinal weekdays), BYMONTHDAY (monthly,
;; negative = from month end). YEARLY and the rest are deferred.
;; ---- integer helpers ----
;; Floored integer division (modulo is already floored, so the remainder
;; subtraction makes the quotient exact and floor-correct for any sign).
(define ev-floor-div (fn (a b) (quotient (- a (modulo a b)) b)))
(define ev-or (fn (x d) (if (nil? x) d x)))
(define ev-filter-nil (fn (xs) (filter (fn (x) (not (nil? x))) xs)))
;; ---- civil date core (Hinnant) ----
;; Days since 1970-01-01 for civil (y, m, d). m in [1,12], d in [1,31].
(define
ev-days-from-civil
(fn
(y0 m d)
(let
((y (if (<= m 2) (- y0 1) y0)))
(let
((era (ev-floor-div (if (>= y 0) y (- y 399)) 400)))
(let
((yoe (- y (* era 400)))
(doy
(+
(ev-floor-div
(+
(*
153
(+ m (if (> m 2) -3 9)))
2)
5)
(- d 1))))
(let
((doe (+ (* yoe 365) (ev-floor-div yoe 4) (- (ev-floor-div yoe 100)) doy)))
(+ (* era 146097) doe -719468)))))))
;; Civil (y m d) list from a day-number.
(define
ev-civil-from-days
(fn
(z0)
(let
((z (+ z0 719468)))
(let
((era (ev-floor-div (if (>= z 0) z (- z 146096)) 146097)))
(let
((doe (- z (* era 146097))))
(let
((yoe (ev-floor-div (+ (- doe (ev-floor-div doe 1460)) (ev-floor-div doe 36524) (- (ev-floor-div doe 146096))) 365)))
(let
((y (+ yoe (* era 400)))
(doy
(-
doe
(+
(* 365 yoe)
(ev-floor-div yoe 4)
(- (ev-floor-div yoe 100))))))
(let
((mp (ev-floor-div (+ (* 5 doy) 2) 153)))
(let
((d (+ (- doy (ev-floor-div (+ (* 153 mp) 2) 5)) 1))
(m
(if
(< mp 10)
(+ mp 3)
(- mp 9))))
(list (if (<= m 2) (+ y 1) y) m d))))))))))
;; Weekday of a day-number: 0=Mon .. 6=Sun (1970-01-01 is Thursday = 3).
(define ev-weekday-of-days (fn (z) (modulo (+ z 3) 7)))
(define
ev-days-in-month
(fn
(y m)
(-
(ev-days-from-civil
(if (= m 12) (+ y 1) y)
(if (= m 12) 1 (+ m 1))
1)
(ev-days-from-civil y m 1))))
;; Add k months to (y,m), returning (list y2 m2).
(define
ev-add-months
(fn
(y m k)
(let
((total (+ (* y 12) (- m 1) k)))
(list
(ev-floor-div total 12)
(+ (modulo total 12) 1)))))
;; ---- datetime (epoch minutes) ----
(define
ev-dt
(fn
(y m d hh mm)
(+ (* (ev-days-from-civil y m d) 1440) (* hh 60) mm)))
(define ev-date (fn (y m d) (ev-dt y m d 0 0)))
(define ev-dt->days (fn (t) (ev-floor-div t 1440)))
(define ev-dt->civil (fn (t) (ev-civil-from-days (ev-dt->days t))))
(define ev-dt-weekday (fn (t) (ev-weekday-of-days (ev-dt->days t))))
(define ev-dt-tod (fn (t) (modulo t 1440)))
(define ev-civ-y (fn (c) (first c)))
(define ev-civ-m (fn (c) (first (rest c))))
(define ev-civ-d (fn (c) (first (rest (rest c)))))
;; ---- event + occurrence constructors ----
;; rrule is nil (single event) or a dict:
;; {:freq :daily|:weekly|:monthly :interval N :count N|nil :until DT|nil
;; :byday ...|nil :bymonthday (list 15 -1)|nil}
;; weekly :byday -> (list 0 2 4) weekday numbers, 0=Mon
;; monthly :byday -> (list {:ord 2 :wd 1}) nth weekday (ord<0 from end)
;; monthly :bymonthday -> (list 15 -1) day of month (negative from end)
(define ev-event (fn (id dtstart duration rrule capacity) {:duration duration :id id :dtstart dtstart :capacity capacity :rrule rrule}))
;; Event with EXDATE/RDATE exceptions. exdate/rdate are lists of epoch-minute
;; starts to exclude from / add to the expansion (RFC 5545 VEVENT properties).
(define
ev-event-full
(fn
(id dtstart duration rrule capacity exdate rdate)
{:duration duration
:id id
:dtstart dtstart
:capacity capacity
:rrule rrule
:exdate exdate
:rdate rdate}))
(define ev-occ (fn (id start dur) {:id id :start start :end (+ start dur)}))
;; ---- DAILY expansion ----
;; occ starts at dtstart; n counts every generated occurrence (window-
;; independent, so COUNT/UNTIL bound the rule, not the view). Emits only
;; occurrences inside [win-start, win-end].
(define
ev-daily-loop
(fn
(id occ duration step count until dtstart win-start win-end acc n)
(cond
((> occ win-end) acc)
((and (not (nil? count)) (>= n count)) acc)
((and (not (nil? until)) (> occ until)) acc)
(else
(begin
(when (>= occ win-start) (append! acc (ev-occ id occ duration)))
(ev-daily-loop
id
(+ occ step)
duration
step
count
until
dtstart
win-start
win-end
acc
(+ n 1)))))))
;; ---- shared per-period emit ----
;; Walk a start-ascending list of candidate occurrence datetimes for one
;; period, generating (count toward COUNT) those >= dtstart within UNTIL, and
;; emitting those also inside the window. Returns the updated running n.
(define
ev-emit-occs
(fn
(id occs duration count until dtstart win-start win-end acc n)
(if
(empty? occs)
n
(let
((occ (first occs)))
(let
((generates? (and (>= occ dtstart) (or (nil? until) (<= occ until)) (or (nil? count) (< n count)))))
(begin
(when
(and generates? (>= occ win-start) (<= occ win-end))
(append! acc (ev-occ id occ duration)))
(ev-emit-occs
id
(rest occs)
duration
count
until
dtstart
win-start
win-end
acc
(if generates? (+ n 1) n))))))))
;; ---- WEEKLY expansion ----
;; Iterate week by week from the Monday of dtstart's week; within each active
;; week emit each BYDAY (sorted). n counts every generated occurrence.
(define
ev-week0-days
(fn (dtstart) (- (ev-dt->days dtstart) (ev-dt-weekday dtstart))))
(define
ev-byday-default
(fn
(byday dtstart)
(if (nil? byday) (list (ev-dt-weekday dtstart)) (sort byday))))
(define
ev-weekly-loop
(fn
(id
week-days
tod
duration
week-step
bd
count
until
dtstart
win-start
win-end
acc
n)
(let
((week-start-dt (* week-days 1440)))
(cond
((> week-start-dt win-end) acc)
((and (not (nil? count)) (>= n count)) acc)
(else
(let
((occs (map (fn (wd) (+ (* (+ week-days wd) 1440) tod)) bd)))
(let
((n2 (ev-emit-occs id occs duration count until dtstart win-start win-end acc n)))
(ev-weekly-loop
id
(+ week-days week-step)
tod
duration
week-step
bd
count
until
dtstart
win-start
win-end
acc
n2))))))))
;; ---- MONTHLY expansion ----
;; Iterate month by month from dtstart's month, stepping by INTERVAL months.
;; Candidate days per month come from BYMONTHDAY, then ordinal BYDAY, else the
;; day-of-month of dtstart (skipped in months too short to contain it).
;; Resolve a BYMONTHDAY value to a valid day-of-month, or nil.
(define
ev-resolve-monthday
(fn
(y m bmd)
(let
((dim (ev-days-in-month y m)))
(let
((day (if (< bmd 0) (+ dim 1 bmd) bmd)))
(if (and (>= day 1) (<= day dim)) day nil)))))
;; Resolve an ordinal weekday {:ord :wd} to a day-of-month, or nil.
(define
ev-resolve-nth-weekday
(fn
(y m ord wd)
(let
((dim (ev-days-in-month y m)))
(if
(> ord 0)
(let
((first-wd (ev-weekday-of-days (ev-days-from-civil y m 1))))
(let
((day (+ 1 (modulo (- wd first-wd) 7) (* (- ord 1) 7))))
(if (<= day dim) day nil)))
(let
((last-wd (ev-weekday-of-days (ev-days-from-civil y m dim))))
(let
((day (- dim (modulo (- last-wd wd) 7) (* (- (- ord) 1) 7))))
(if (>= day 1) day nil)))))))
(define
ev-month-candidates
(fn
(y m rrule dtstart)
(let
((bmd (get rrule :bymonthday)) (byday (get rrule :byday)))
(cond
((not (nil? bmd))
(ev-filter-nil (map (fn (d) (ev-resolve-monthday y m d)) bmd)))
((not (nil? byday))
(ev-filter-nil
(map
(fn
(e)
(ev-resolve-nth-weekday y m (get e :ord) (get e :wd)))
byday)))
(else
(ev-filter-nil
(list
(ev-resolve-monthday y m (ev-civ-d (ev-dt->civil dtstart))))))))))
(define
ev-monthly-loop
(fn
(id
y
m
rrule
duration
tod
interval
count
until
dtstart
win-start
win-end
acc
n)
(let
((month-start (ev-dt y m 1 0 0)))
(cond
((> month-start win-end) acc)
((and (not (nil? count)) (>= n count)) acc)
(else
(let
((days (sort (ev-month-candidates y m rrule dtstart))))
(let
((occs (map (fn (d) (+ (* (ev-days-from-civil y m d) 1440) tod)) days)))
(let
((n2 (ev-emit-occs id occs duration count until dtstart win-start win-end acc n))
(nm (ev-add-months y m interval)))
(ev-monthly-loop
id
(ev-civ-y nm)
(ev-civ-m nm)
rrule
duration
tod
interval
count
until
dtstart
win-start
win-end
acc
n2)))))))))
;; ---- top-level expansion ----
;; Raw expansion (RRULE / single event), before EXDATE/RDATE are applied.
;; Returns a list of occurrence dicts {:id :start :end} within the window.
(define
ev-expand-base
(fn
(event win-start win-end)
(let
((id (get event :id))
(dtstart (get event :dtstart))
(duration (get event :duration))
(rrule (get event :rrule)))
(if
(nil? rrule)
(if
(and (>= dtstart win-start) (<= dtstart win-end))
(list (ev-occ id dtstart duration))
(list))
(let
((freq (get rrule :freq))
(interval (ev-or (get rrule :interval) 1))
(count (get rrule :count))
(until (get rrule :until))
(byday (get rrule :byday))
(acc (list)))
(begin
(cond
((= freq :daily)
(ev-daily-loop
id
dtstart
duration
(* interval 1440)
count
until
dtstart
win-start
win-end
acc
0))
((= freq :weekly)
(ev-weekly-loop
id
(ev-week0-days dtstart)
(ev-dt-tod dtstart)
duration
(* interval 7)
(ev-byday-default byday dtstart)
count
until
dtstart
win-start
win-end
acc
0))
((= freq :monthly)
(let
((civ (ev-dt->civil dtstart)))
(ev-monthly-loop
id
(ev-civ-y civ)
(ev-civ-m civ)
rrule
duration
(ev-dt-tod dtstart)
interval
count
until
dtstart
win-start
win-end
acc
0)))
(else (error (str "ev-expand-base: unsupported freq: " freq))))
acc))))))
;; ---- EXDATE / RDATE (RFC 5545 exceptions) ----
;; Applied AFTER raw expansion: RDATE adds explicit occurrences within the
;; window, EXDATE removes occurrences whose start matches (EXDATE wins over
;; RDATE). Both are VEVENT-level: (get event :exdate) / (get event :rdate) are
;; lists of epoch-minute starts; nil for plain events.
(define
ev-num-member?
(fn
(n xs)
(cond
((empty? xs) false)
((= n (first xs)) true)
(else (ev-num-member? n (rest xs))))))
;; Drop duplicate-start occurrences from a start-sorted list (keep one).
(define
ev-dedupe-by-start
(fn
(occs)
(cond
((empty? occs) occs)
((empty? (rest occs)) occs)
((= (get (first occs) :start) (get (first (rest occs)) :start))
(ev-dedupe-by-start (rest occs)))
(else (cons (first occs) (ev-dedupe-by-start (rest occs)))))))
(define
ev-apply-exceptions
(fn
(event base win-start win-end)
(let
((id (get event :id))
(duration (get event :duration))
(exdate (ev-or (get event :exdate) (list)))
(rdate (ev-or (get event :rdate) (list))))
(let
((rdate-occs
(reduce
(fn
(acc d)
(if
(and (>= d win-start) (<= d win-end))
(cons (ev-occ id d duration) acc)
acc))
(list)
rdate)))
(let
((no-ex
(filter
(fn (o) (not (ev-num-member? (get o :start) exdate)))
(append base rdate-occs))))
(ev-dedupe-by-start (ev-sort-occs no-ex)))))))
;; ---- per-occurrence overrides (RFC 5545 RECURRENCE-ID) ----
;; A single instance of a recurring series can be detached and rescheduled. The
;; event carries :overrides — a list of (orig-start {:start :duration}) — keyed
;; by the occurrence's ORIGINAL start. Applied after EXDATE/RDATE. A moved
;; instance whose new start leaves the window is dropped from this window (the
;; original slot is vacated); an instance moved INTO the window from outside is
;; out of scope for a windowed expansion (known stub limitation).
(define
ev-assoc-lookup
(fn
(k pairs)
(cond
((empty? pairs) nil)
((= (first (first pairs)) k) (first (rest (first pairs))))
(else (ev-assoc-lookup k (rest pairs))))))
(define
ev-apply-overrides
(fn
(id base overrides)
(map
(fn
(o)
(let
((ov (ev-assoc-lookup (get o :start) overrides)))
(if (nil? ov) o (ev-occ id (get ov :start) (get ov :duration)))))
base)))
;; Add an override that reschedules the occurrence originally at `orig-start`
;; to `new-start` with `new-duration`.
(define
ev-with-override
(fn
(event orig-start new-start new-duration)
(assoc
event
:overrides
(cons
(list orig-start {:start new-start :duration new-duration})
(ev-or (get event :overrides) (list))))))
;; Naive (single time-domain) expansion: RRULE + EXDATE/RDATE + overrides.
(define
ev-expand-naive
(fn
(event win-start win-end)
(let
((excepted
(ev-apply-exceptions
event
(ev-expand-base event win-start win-end)
win-start
win-end))
(overrides (ev-or (get event :overrides) (list)))
(id (get event :id)))
(if
(empty? overrides)
excepted
(filter
(fn (o) (and (>= (get o :start) win-start) (<= (get o :start) win-end)))
(ev-sort-occs (ev-apply-overrides id excepted overrides)))))))
;; Public entry point. A tz-aware event (`:tz` set) expands in local wall-clock
;; time and converts each occurrence to UTC (ev-expand-tz, timezone.sx); a plain
;; event expands naively in a single time domain. The window is UTC either way.
(define
ev-expand
(fn
(event win-start win-end)
(let
((tz (get event :tz)))
(if
(nil? tz)
(ev-expand-naive event win-start win-end)
(ev-expand-tz event tz win-start win-end)))))
;; ---- multi-event expansion (sorted by start) ----
;; Insertion of one occurrence into a start-ascending list.
(define
ev-occ-insert
(fn
(o sorted)
(cond
((empty? sorted) (list o))
((<= (get o :start) (get (first sorted) :start)) (cons o sorted))
(else (cons (first sorted) (ev-occ-insert o (rest sorted)))))))
(define
ev-sort-occs
(fn (occs) (reduce (fn (acc o) (ev-occ-insert o acc)) (list) occs)))
;; Expand many events into one occurrence list, ascending by start.
(define
ev-expand-all
(fn
(events win-start win-end)
(let
((acc (list)))
(begin
(for-each
(fn
(ev)
(for-each
(fn (o) (append! acc o))
(ev-expand ev win-start win-end)))
events)
(ev-sort-occs acc)))))

View File

@@ -0,0 +1,60 @@
# events-on-sx conformance config — sourced by lib/guest/conformance.sh.
LANG_NAME=events
MODE=dict
SCOREBOARD_DIR=lib/events
PRELOADS=(
spec/stdlib.sx
lib/r7rs.sx
lib/datalog/tokenizer.sx
lib/datalog/parser.sx
lib/datalog/unify.sx
lib/datalog/db.sx
lib/datalog/builtins.sx
lib/datalog/aggregates.sx
lib/datalog/strata.sx
lib/datalog/eval.sx
lib/datalog/api.sx
lib/datalog/magic.sx
lib/events/calendar.sx
lib/events/timezone.sx
lib/events/availability.sx
lib/persist/event.sx
lib/persist/backend.sx
lib/persist/log.sx
lib/persist/kv.sx
lib/persist/concurrency.sx
lib/persist/api.sx
lib/events/booking.sx
lib/events/booking-notify.sx
lib/events/ticket.sx
lib/guest/lex.sx
lib/guest/reflective/env.sx
lib/guest/reflective/quoting.sx
lib/scheme/parser.sx
lib/scheme/eval.sx
lib/scheme/runtime.sx
lib/flow/spec.sx
lib/flow/store.sx
lib/flow/remote.sx
lib/flow/host.sx
lib/flow/api.sx
lib/events/notify.sx
lib/events/api.sx
lib/events/reminders.sx
lib/events/federation.sx
)
SUITES=(
"calendar:lib/events/tests/calendar.sx:(ev-calendar-tests-run!)"
"timezone:lib/events/tests/timezone.sx:(ev-timezone-tests-run!)"
"availability:lib/events/tests/availability.sx:(ev-availability-tests-run!)"
"api:lib/events/tests/api.sx:(ev-api-tests-run!)"
"booking:lib/events/tests/booking.sx:(ev-booking-tests-run!)"
"booking-notify:lib/events/tests/booking-notify.sx:(ev-booking-notify-tests-run!)"
"ticket:lib/events/tests/ticket.sx:(ev-ticket-tests-run!)"
"notify:lib/events/tests/notify.sx:(ev-notify-tests-run!)"
"reminders:lib/events/tests/reminders.sx:(ev-reminders-tests-run!)"
"federation:lib/events/tests/federation.sx:(ev-federation-tests-run!)"
)

3
lib/events/conformance.sh Executable file
View File

@@ -0,0 +1,3 @@
#!/usr/bin/env bash
# Thin wrapper — see lib/guest/conformance.sh and lib/events/conformance.conf.
exec bash "$(dirname "$0")/../guest/conformance.sh" "$(dirname "$0")/conformance.conf" "$@"

232
lib/events/federation.sx Normal file
View File

@@ -0,0 +1,232 @@
;; 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)))

38
lib/events/notify.sx Normal file
View File

@@ -0,0 +1,38 @@
;; lib/events/notify.sx — durable notification delivery flows over an injected
;; transport (lib/flow).
;;
;; Reminders and digests are durable `flow`s: a flow `request`s delivery (a
;; suspend point), the HOST performs the actual send via an injected `dispatch`
;; (the transport — email/push/etc.), and resumes the flow with the outcome.
;; Because flow uses deterministic replay, a completed delivery is never re-run
;; on recovery; the host owns IO and persistence.
;;
;; Delivery is AT-LEAST-ONCE with idempotency. Each message carries an id (the
;; idempotency key). Two protections stop double-delivery:
;; 1. The transport dedups by id — a re-send of a delivered id is a no-op
;; that still reports ok, so a retry never produces two pings.
;; 2. flow's replay log records each resolved request, so recovery replays the
;; logged outcome instead of re-issuing the send.
;;
;; Retry/backoff rides flow suspend/resume: each attempt issues a request with a
;; DISTINCT tag `(deliver <id> <n>)` — distinct tags keep deterministic replay
;; correct across retries. The dispatch returns (ok info) to finish or
;; (retry reason) to try again, bounded by `maxn` (then (failed id reason)).
;;
;; A message is a 3-element list (id recipient body). The transport is generic
;; and injected — when feed/notify lands, both consumers share one transport,
;; so this delivery core is a candidate for extraction to `delivery-on-sx`.
;;
;; The Scheme flow source below loads into a flow env (see lib/flow/api.sx).
;; `ev/notify-run` prepends it to a caller program and evaluates in the shared
;; flow env.
(define
ev-notify-flows-src
"(define (ev-msg-id m) (car m))\n (define (ev-msg-recipient m) (car (cdr m)))\n (define (ev-msg-body m) (car (cdr (cdr m))))\n (define (ev-mem x xs)\n (if (null? xs) #f (if (equal? x (car xs)) #t (ev-mem x (cdr xs)))))\n (define (ev-notify-attempt m n maxn)\n (let ((r (request (list (quote deliver) (ev-msg-id m) n) m)))\n (if (eq? (car r) (quote ok))\n (list (quote delivered) (ev-msg-id m) n)\n (if (>= n maxn)\n (list (quote failed) (ev-msg-id m) (car (cdr r)))\n (ev-notify-attempt m (+ n 1) maxn)))))\n (define (ev-deliver-reminder maxn)\n (flow-node (lambda (m) (ev-notify-attempt m 1 maxn))))\n (define (ev-digest-step ms maxn)\n (if (null? ms)\n (list)\n (cons (ev-notify-attempt (car ms) 1 maxn)\n (ev-digest-step (cdr ms) maxn))))\n (define (ev-deliver-digest maxn)\n (flow-node (lambda (ms) (ev-digest-step ms maxn))))")
;; Run a Scheme flow program with the notify flows preloaded, in the shared
;; flow env. Returns the program's value (SX-native).
(define
ev/notify-run
(fn (prog) (flow-run (str ev-notify-flows-src "\n" prog))))

147
lib/events/reminders.sx Normal file
View File

@@ -0,0 +1,147 @@
;; lib/events/reminders.sx — derive reminder + digest messages from the agenda.
;;
;; Bridges the schedule (calendar) and the durable roster (booking on persist)
;; to the notification layer (notify.sx). For each booked attendee of each
;; upcoming occurrence we derive a reminder message that fires `lead` minutes
;; before the occurrence starts. Each message has a deterministic idempotency
;; key — occ-key / recipient / lead — so re-deriving over an overlapping window
;; never produces a duplicate ping (the notify transport dedups on this id).
;;
;; A reminder is a dict:
;; {:id :recipient :event :start :fire-at}
;; `ev/reminder->msg` projects it to notify's (id recipient body) wire shape.
;; Reminders for one occurrence: one per booked attendee (durable roster).
(define
ev/occurrence-reminders
(fn
(b occ lead)
(let
((occ-key (ev-occ-key occ))
(start (get occ :start))
(evid (get occ :id)))
(map (fn (actor) {:id (str occ-key "/" actor "/" lead) :event evid :start start :fire-at (- start lead) :recipient actor}) (ev/roster-occ b occ)))))
;; Insertion sort of reminder dicts ascending by :fire-at (then :id for ties).
(define
ev-rem-before?
(fn
(a c)
(cond
((< (get a :fire-at) (get c :fire-at)) true)
((> (get a :fire-at) (get c :fire-at)) false)
(else (< (get a :id) (get c :id))))))
(define
ev-rem-insert
(fn
(r sorted)
(cond
((empty? sorted) (list r))
((ev-rem-before? r (first sorted)) (cons r sorted))
(else (cons (first sorted) (ev-rem-insert r (rest sorted)))))))
(define
ev-rem-sort
(fn (rs) (reduce (fn (acc r) (ev-rem-insert r acc)) (list) rs)))
;; All reminders across the agenda in [ws, we), ascending by fire-at.
(define
ev/agenda-reminders
(fn
(b store ws we lead)
(let
((acc (list)))
(begin
(for-each
(fn
(occ)
(for-each
(fn (r) (append! acc r))
(ev/occurrence-reminders b occ lead)))
(ev/agenda store ws we))
(ev-rem-sort acc)))))
;; Reminders whose fire-at has arrived (fire-at <= now) — what a scheduler
;; should hand to the notify transport at time `now`.
(define
ev/due-reminders
(fn
(reminders now)
(filter (fn (r) (<= (get r :fire-at) now)) reminders)))
;; Project a reminder to notify's (id recipient body) wire shape.
(define
ev/reminder->msg
(fn
(r)
(list
(get r :id)
(get r :recipient)
(list :reminder (get r :event) (get r :start)))))
;; ---- digests ----
;; The occurrences `actor` is booked into (durable roster), within window.
(define
ev/agenda-for-p
(fn
(b store actor ws we)
(filter
(fn (occ) (ev-bk-member? actor (ev/roster-occ b occ)))
(ev/agenda store ws we))))
;; A single digest message summarising an actor's upcoming booked occurrences.
;; :items is ({:event :start} ...); empty when the actor has nothing booked.
(define ev/agenda-digest (fn (b store actor ws we) {:items (map (fn (occ) {:event (get occ :id) :start (get occ :start)}) (ev/agenda-for-p b store actor ws we)) :id (str actor "/digest/" ws "-" we) :recipient actor}))
;; ---- reschedule notifications ----
;; When an event carries per-occurrence overrides (ev-with-override), every
;; attendee booked at the ORIGINAL start should be told the new time. Bookings
;; were made against the original occ-key (id@orig-start), so we read that
;; roster. Idempotency key encodes the original key and the new start, so
;; re-deriving the same reschedule never double-notifies.
(define
ev/reschedule-notifications
(fn
(b event)
(let
((overrides (ev-or (get event :overrides) (list)))
(evid (get event :id))
(dur (get event :duration)))
(reduce
(fn
(acc entry)
(let
((orig-start (first entry))
(ov (first (rest entry))))
(let
((occ (ev-occ evid orig-start dur))
(new-start (get ov :start))
(new-duration (get ov :duration)))
(let
((key (ev-occ-key occ)))
(append
acc
(map
(fn
(actor)
{:id (str key "/reschedule/" new-start)
:recipient actor
:event evid
:old-start orig-start
:new-start new-start
:new-duration new-duration})
(ev/roster-occ b occ)))))))
(list)
overrides))))
;; Project a reschedule notification to notify's (id recipient body) shape.
(define
ev/reschedule-notify->msg
(fn
(r)
(list
(get r :id)
(get r :recipient)
(list :rescheduled (get r :event) (get r :old-start) (get r :new-start)))))

View File

@@ -0,0 +1,19 @@
{
"lang": "events",
"total_passed": 295,
"total_failed": 0,
"total": 295,
"suites": [
{"name":"calendar","passed":51,"failed":0,"total":51},
{"name":"timezone","passed":17,"failed":0,"total":17},
{"name":"availability","passed":22,"failed":0,"total":22},
{"name":"api","passed":24,"failed":0,"total":24},
{"name":"booking","passed":82,"failed":0,"total":82},
{"name":"booking-notify","passed":11,"failed":0,"total":11},
{"name":"ticket","passed":31,"failed":0,"total":31},
{"name":"notify","passed":7,"failed":0,"total":7},
{"name":"reminders","passed":21,"failed":0,"total":21},
{"name":"federation","passed":29,"failed":0,"total":29}
],
"generated": "2026-06-07T09:30:28+00:00"
}

16
lib/events/scoreboard.md Normal file
View File

@@ -0,0 +1,16 @@
# events scoreboard
**295 / 295 passing** (0 failure(s)).
| Suite | Passed | Total | Status |
|-------|--------|-------|--------|
| calendar | 51 | 51 | ok |
| timezone | 17 | 17 | ok |
| availability | 22 | 22 | ok |
| api | 24 | 24 | ok |
| booking | 82 | 82 | ok |
| booking-notify | 11 | 11 | ok |
| ticket | 31 | 31 | ok |
| notify | 7 | 7 | ok |
| reminders | 21 | 21 | ok |
| federation | 29 | 29 | ok |

271
lib/events/tests/api.sx Normal file
View File

@@ -0,0 +1,271 @@
;; lib/events/tests/api.sx — public events facade (schedule/agenda/free/book).
(define ev-api-pass 0)
(define ev-api-fail 0)
(define ev-api-failures (list))
(define
ev-api-check!
(fn
(name got expected)
(if
(= got expected)
(set! ev-api-pass (+ ev-api-pass 1))
(do
(set! ev-api-fail (+ ev-api-fail 1))
(append!
ev-api-failures
(str name "\n expected: " expected "\n got: " got))))))
;; A store with a weekly yoga class (Mon+Wed 18:00, 60m, 4 occurrences).
(define
ev-api-store
(fn
()
(ev/schedule
(ev/empty)
(quote yoga)
(ev-dt 2026 6 1 18 0)
60
{:freq :weekly :count 4 :byday (list 0 2)}
20)))
(define
ev-api-run-all!
(fn
()
(let
((s0 (ev-api-store)))
(let
((occs (ev/agenda s0 (ev-date 2026 6 1) (ev-date 2026 7 1))))
(let
((s1 (ev/book (ev/book s0 (quote nia) (ev-occ-key (first occs))) (quote nia) (ev-occ-key (first (rest occs))))))
(do
(ev-api-check!
"agenda expands weekly class to four occurrences"
(map (fn (o) (ev-dt->civil (get o :start))) occs)
(list
(list 2026 6 1)
(list 2026 6 3)
(list 2026 6 8)
(list 2026 6 10)))
(ev-api-check!
"empty store has empty agenda"
(ev/agenda
(ev/empty)
(ev-date 2026 6 1)
(ev-date 2026 7 1))
(list))
(ev-api-check!
"max duration reflects scheduled events"
(ev/store-max-duration s0)
60)
(ev-api-check!
"max duration of empty store is zero"
(ev/store-max-duration (ev/empty))
0)
(ev-api-check!
"event-by-id finds the scheduled event"
(get (ev/event-by-id s0 (quote yoga)) :capacity)
20)
(ev-api-check!
"event-by-id is nil for unknown id"
(ev/event-by-id s0 (quote nope))
nil)
(ev-api-check!
"agenda-for lists only booked occurrences"
(map
(fn (o) (ev-dt->civil (get o :start)))
(ev/agenda-for
s1
(quote nia)
(ev-date 2026 6 1)
(ev-date 2026 7 1)))
(list
(list 2026 6 1)
(list 2026 6 3)))
(ev-api-check!
"agenda-for empty for unbooked actor"
(ev/agenda-for
s1
(quote zed)
(ev-date 2026 6 1)
(ev-date 2026 7 1))
(list))
(ev-api-check!
"free? false during a booked occurrence"
(ev/free?
s1
(quote nia)
(ev-dt 2026 6 1 18 30)
(ev-dt 2026 6 1 19 0))
false)
(ev-api-check!
"free? true in an open window"
(ev/free?
s1
(quote nia)
(ev-dt 2026 6 1 9 0)
(ev-dt 2026 6 1 10 0))
true)
(ev-api-check!
"free? half-open at occurrence end"
(ev/free?
s1
(quote nia)
(ev-dt 2026 6 1 19 0)
(ev-dt 2026 6 1 20 0))
true)
(ev-api-check!
"free? true for an actor who booked nothing"
(ev/free?
s1
(quote zed)
(ev-dt 2026 6 1 18 0)
(ev-dt 2026 6 1 19 0))
true)
(ev-api-check!
"next-free skips the booked slot to the hour after"
(ev-dt-tod
(ev/next-free
s1
(quote nia)
(ev-dt
2026
6
1
18
0)
60
(ev-dt
2026
6
1
23
0)))
(* 19 60))
(ev-api-check!
"next-free returns `after` when already open"
(ev/next-free
s1
(quote nia)
(ev-dt 2026 6 1 9 0)
60
(ev-dt 2026 6 1 18 0))
(ev-dt 2026 6 1 9 0))
(ev-api-check!
"no conflict among disjoint bookings"
(ev/has-conflict?
s1
(quote nia)
(ev-date 2026 6 1)
(ev-date 2026 7 1))
false)
(let
((sc (ev/book (ev/schedule s1 (quote talk) (ev-dt 2026 6 1 18 30) 60 nil 5) (quote nia) (ev-occ-key (ev-occ (quote talk) (ev-dt 2026 6 1 18 30) 60)))))
(ev-api-check!
"overlapping second booking creates a conflict"
(ev/has-conflict?
sc
(quote nia)
(ev-date 2026 6 1)
(ev-date 2026 7 1))
true))
(let
((b (persist/open)) (occ1 (first occs)))
(do
(let
((sp (ev/schedule (ev/empty) (quote clinic) (ev-dt 2026 6 5 9 0) 30 nil 2)))
(let
((occ (ev-occ (quote clinic) (ev-dt 2026 6 5 9 0) 30)))
(do
(ev-api-check!
"durable book returns booked"
(get (ev/book-occ! b sp (quote a) occ) :status)
:booked)
(ev/book-occ! b sp (quote c) occ)
(ev-api-check!
"durable book past capacity is full"
(get (ev/book-occ! b sp (quote d) occ) :status)
:full)
(ev-api-check!
"durable roster reflects persisted bookings"
(ev/roster-occ b occ)
(list (quote a) (quote c)))
(ev-api-check!
"durable seats-left honours capacity"
(ev/seats-left-occ b sp occ)
0)
(ev-api-check!
"persist free? false during a durable booking"
(ev/free-p?
b
sp
(quote a)
(ev-dt
2026
6
5
9
10)
(ev-dt
2026
6
5
9
20))
false)
(ev-api-check!
"persist free? true in an open window"
(ev/free-p?
b
sp
(quote a)
(ev-dt
2026
6
5
10
0)
(ev-dt
2026
6
5
10
30))
true)
(ev/cancel-occ! b sp (quote a) occ)
(ev-api-check!
"durable cancel frees a seat"
(ev/seats-left-occ b sp occ)
1)
(ev-api-check!
"persist free? true after cancellation"
(ev/free-p?
b
sp
(quote a)
(ev-dt
2026
6
5
9
10)
(ev-dt
2026
6
5
9
20))
true))))))))))))
(define
ev-api-tests-run!
(fn
()
(do
(set! ev-api-pass 0)
(set! ev-api-fail 0)
(set! ev-api-failures (list))
(ev-api-run-all!)
{:failures ev-api-failures :total (+ ev-api-pass ev-api-fail) :passed ev-api-pass :failed ev-api-fail})))

View File

@@ -0,0 +1,331 @@
;; lib/events/tests/availability.sx — free/busy + conflict rules on Datalog.
(define ev-av-pass 0)
(define ev-av-fail 0)
(define ev-av-failures (list))
(define
ev-av-check!
(fn
(name got expected)
(if
(= got expected)
(set! ev-av-pass (+ ev-av-pass 1))
(do
(set! ev-av-fail (+ ev-av-fail 1))
(append!
ev-av-failures
(str name "\n expected: " expected "\n got: " got))))))
;; Fixture: three occurrences on 2026-06-01.
;; standup 09:0009:30 review 09:1510:15 (overlaps standup)
;; lunch 12:0013:00
(define
ev-av-occs
(fn
()
(list
(ev-occ
(quote standup)
(ev-dt 2026 6 1 9 0)
30)
(ev-occ
(quote review)
(ev-dt 2026 6 1 9 15)
60)
(ev-occ
(quote lunch)
(ev-dt 2026 6 1 12 0)
60))))
(define ev-av-key (fn (id start) (str id "@" start)))
;; alice: standup + review (overlap → conflict). bob: lunch only.
(define
ev-av-db
(fn
()
(ev-avail-db
(ev-av-occs)
(list
(list
(quote alice)
(ev-av-key
(quote standup)
(ev-dt 2026 6 1 9 0)))
(list
(quote alice)
(ev-av-key
(quote review)
(ev-dt 2026 6 1 9 15)))
(list
(quote bob)
(ev-av-key
(quote lunch)
(ev-dt 2026 6 1 12 0)))))))
;; Disjoint fixture for slot search: 09:0010:00 then 10:3011:30 (a 30m gap).
(define
ev-av-gap-db
(fn
()
(ev-avail-db
(list
(ev-occ
(quote a)
(ev-dt 2026 6 1 9 0)
60)
(ev-occ
(quote b)
(ev-dt 2026 6 1 10 30)
60))
(list
(list
(quote sam)
(ev-av-key
(quote a)
(ev-dt 2026 6 1 9 0)))
(list
(quote sam)
(ev-av-key
(quote b)
(ev-dt 2026 6 1 10 30)))))))
(define
ev-av-run-all!
(fn
()
(let
((db (ev-av-db)))
(do
(ev-av-check!
"busy lists alice committed intervals ascending"
(ev-busy db (quote alice))
(list
(list
(ev-dt 2026 6 1 9 0)
(ev-dt 2026 6 1 9 30))
(list
(ev-dt 2026 6 1 9 15)
(ev-dt 2026 6 1 10 15))))
(ev-av-check!
"busy lists bob single interval"
(ev-busy db (quote bob))
(list
(list
(ev-dt 2026 6 1 12 0)
(ev-dt 2026 6 1 13 0))))
(ev-av-check!
"busy empty for unknown actor"
(ev-busy db (quote carol))
(list))
(ev-av-check!
"alice has an overlap conflict"
(ev-has-conflict? db (quote alice))
true)
(ev-av-check!
"alice conflict reported once (canonical pair)"
(len (ev-conflicts db (quote alice)))
1)
(ev-av-check!
"bob has no conflict"
(ev-has-conflict? db (quote bob))
false)
(ev-av-check!
"non-overlapping bookings do not conflict"
(ev-has-conflict?
(ev-avail-db
(list
(ev-occ
(quote a)
(ev-dt
2026
6
1
9
0)
30)
(ev-occ
(quote b)
(ev-dt
2026
6
1
9
30)
30))
(list
(list
(quote dave)
(ev-av-key
(quote a)
(ev-dt
2026
6
1
9
0)))
(list
(quote dave)
(ev-av-key
(quote b)
(ev-dt
2026
6
1
9
30)))))
(quote dave))
false)
(ev-av-check!
"alice free in an empty window"
(ev-free?
db
(quote alice)
(ev-dt 2026 6 1 13 0)
(ev-dt 2026 6 1 14 0))
true)
(ev-av-check!
"alice not free overlapping a booking"
(ev-free?
db
(quote alice)
(ev-dt 2026 6 1 9 20)
(ev-dt 2026 6 1 9 40))
false)
(ev-av-check!
"free? is half-open at the trailing edge"
(ev-free?
db
(quote alice)
(ev-dt 2026 6 1 10 15)
(ev-dt 2026 6 1 11 0))
true)
(ev-av-check!
"free? is half-open at the leading edge"
(ev-free?
db
(quote bob)
(ev-dt 2026 6 1 11 0)
(ev-dt 2026 6 1 12 0))
true)
(ev-av-check!
"free? false when window straddles a booking edge"
(ev-free?
db
(quote bob)
(ev-dt 2026 6 1 11 0)
(ev-dt 2026 6 1 12 1))
false)
(ev-av-check!
"free? query leaves db reusable (no leaked qwindow)"
(do
(ev-free?
db
(quote alice)
(ev-dt 2026 6 1 9 0)
(ev-dt 2026 6 1 9 30))
(ev-busy db (quote bob)))
(list
(list
(ev-dt 2026 6 1 12 0)
(ev-dt 2026 6 1 13 0))))
(let
((gdb (ev-av-gap-db)))
(do
(ev-av-check!
"next-free finds the gap between bookings"
(ev-next-free
gdb
(quote sam)
(ev-dt 2026 6 1 9 0)
30
(ev-dt 2026 6 1 18 0))
(ev-dt 2026 6 1 10 0))
(ev-av-check!
"next-free skips a gap too short for the duration"
(ev-next-free
gdb
(quote sam)
(ev-dt 2026 6 1 9 0)
60
(ev-dt 2026 6 1 18 0))
(ev-dt 2026 6 1 11 30))
(ev-av-check!
"next-free returns `after` when already free"
(ev-next-free
gdb
(quote sam)
(ev-dt 2026 6 1 14 0)
60
(ev-dt 2026 6 1 18 0))
(ev-dt 2026 6 1 14 0))
(ev-av-check!
"next-free returns nil when nothing fits before horizon"
(ev-next-free
gdb
(quote sam)
(ev-dt 2026 6 1 9 0)
120
(ev-dt 2026 6 1 11 0))
nil)
(ev-av-check!
"next-free for actor with no bookings is `after`"
(ev-next-free
gdb
(quote nobody)
(ev-dt 2026 6 1 9 0)
60
(ev-dt 2026 6 1 18 0))
(ev-dt 2026 6 1 9 0))
(ev-av-check!
"next-free at exact edge of a booking (half-open)"
(ev-next-free
gdb
(quote sam)
(ev-dt 2026 6 1 10 0)
30
(ev-dt 2026 6 1 18 0))
(ev-dt 2026 6 1 10 0))))
(let
((daily (ev-expand (ev-event (quote class) (ev-dt 2026 6 1 9 0) 60 {:freq :daily :count 3} 1) (ev-date 2026 6 1) (ev-date 2026 7 1))))
(let
((db2 (ev-avail-db daily (map (fn (o) (list (quote sam) (ev-occ-key o))) daily))))
(do
(ev-av-check!
"expanded daily occurrences become busy intervals"
(len (ev-busy db2 (quote sam)))
3)
(ev-av-check!
"no conflicts among disjoint daily occurrences"
(ev-has-conflict? db2 (quote sam))
false)
(ev-av-check!
"busy on day two of the series"
(ev-free?
db2
(quote sam)
(ev-dt
2026
6
2
9
30)
(ev-dt
2026
6
2
9
45))
false))))))))
(define
ev-availability-tests-run!
(fn
()
(do
(set! ev-av-pass 0)
(set! ev-av-fail 0)
(set! ev-av-failures (list))
(ev-av-run-all!)
{:failures ev-av-failures :total (+ ev-av-pass ev-av-fail) :passed ev-av-pass :failed ev-av-fail})))

View File

@@ -0,0 +1,137 @@
;; lib/events/tests/booking-notify.sx — lifecycle notifications from the stream.
(define ev-bn-pass 0)
(define ev-bn-fail 0)
(define ev-bn-failures (list))
(define
ev-bn-check!
(fn
(name got expected)
(if
(= got expected)
(set! ev-bn-pass (+ ev-bn-pass 1))
(do
(set! ev-bn-fail (+ ev-bn-fail 1))
(append!
ev-bn-failures
(str name "\n expected: " expected "\n got: " got))))))
(define
ev-bn-kinds
(fn
(notifs)
(map (fn (n) (list (get n :recipient) (get n :kind))) notifs)))
(define
ev-bn-run-all!
(fn
()
(do
(let
((b (persist/open)))
(do
(ev/book! b "o" 1 (quote a))
(ev/waitlist! b "o" 1 (quote x))
(ev/cancel-promote! b "o" 1 (quote a))
(let
((ns (ev/booking-notifications b "o" (quote yoga))))
(do
(ev-bn-check!
"lifecycle notifications in order"
(ev-bn-kinds ns)
(list
(list (quote a) :booked)
(list (quote x) :waitlisted)
(list (quote a) :cancelled)
(list (quote x) :promoted)))
(ev-bn-check!
"promotion targets the waitlisted actor"
(map
(fn (n) (get n :recipient))
(ev/notify-of-kind ns :promoted))
(list (quote x)))
(ev-bn-check!
"a fresh booking is not flagged as a promotion"
(len (ev/notify-of-kind ns :booked))
1)
(ev-bn-check!
"every notification carries the event label"
(get (first ns) :event)
(quote yoga))))))
(let
((b (persist/open)))
(do
(ev/hold! b "p" 3 (quote q))
(ev/confirm! b "p" (quote q))
(ev-bn-check!
"hold then confirm notifications"
(ev-bn-kinds (ev/booking-notifications b "p" (quote gig)))
(list (list (quote q) :held) (list (quote q) :confirmed)))))
(let
((b (persist/open)))
(do
(ev/hold! b "r" 1 (quote q))
(ev/release! b "r" (quote q))
(ev-bn-check!
"hold then release notifications"
(ev-bn-kinds (ev/booking-notifications b "r" (quote gig)))
(list (list (quote q) :held) (list (quote q) :released)))))
(let
((b (persist/open)))
(do
(ev/book! b "k" 5 (quote a))
(ev/book! b "k" 5 (quote c))
(let
((ns (ev/booking-notifications b "k" (quote talk))))
(do
(ev-bn-check!
"notification ids are occ-key/seq"
(map (fn (n) (get n :id)) ns)
(list "k/1" "k/2"))
(ev-bn-check!
"re-deriving yields identical ids (idempotent)"
(map
(fn (n) (get n :id))
(ev/booking-notifications b "k" (quote talk)))
(list "k/1" "k/2"))))))
(let
((b (persist/open)))
(do
(ev/book! b "w" 5 (quote a))
(ev-bn-check!
"notification projects to (id recipient body)"
(ev/booking-notify->msg
(first (ev/booking-notifications b "w" (quote talk))))
(list
"w/1"
(quote a)
(list :booking-event :booked (quote talk))))))
(let
((b (persist/open)))
(do
(ev/book! b "u" 1 (quote a))
(ev/waitlist! b "u" 1 (quote x))
(ev/leave-waitlist! b "u" (quote x))
(ev-bn-check!
"leaving the waitlist emits no notification"
(len
(ev/notify-of-kind
(ev/booking-notifications b "u" (quote e))
:left-waitlist))
0)
(ev-bn-check!
"unbooked occurrence has no notifications"
(ev/booking-notifications b "empty" (quote e))
(list)))))))
(define
ev-booking-notify-tests-run!
(fn
()
(do
(set! ev-bn-pass 0)
(set! ev-bn-fail 0)
(set! ev-bn-failures (list))
(ev-bn-run-all!)
{:failures ev-bn-failures :total (+ ev-bn-pass ev-bn-fail) :passed ev-bn-pass :failed ev-bn-fail})))

431
lib/events/tests/booking.sx Normal file
View File

@@ -0,0 +1,431 @@
;; lib/events/tests/booking.sx — capacity-safe booking, cancel, and holds.
(define ev-bk-pass 0)
(define ev-bk-fail 0)
(define ev-bk-failures (list))
(define
ev-bk-check!
(fn
(name got expected)
(if
(= got expected)
(set! ev-bk-pass (+ ev-bk-pass 1))
(do
(set! ev-bk-fail (+ ev-bk-fail 1))
(append!
ev-bk-failures
(str name "\n expected: " expected "\n got: " got))))))
;; Take a consistent (roster, last-seq) snapshot of an occurrence's stream.
(define ev-bk-snap (fn (b k) (ev-booked-actors b k)))
(define ev-bk-seq (fn (b k) (persist/last-seq b (ev-booking-stream k))))
(define
ev-bk-run-all!
(fn
()
(do
(let
((b (persist/open)))
(do
(ev-bk-check!
"first booking takes seat 1"
(get (ev/book! b "o1" 3 (quote a)) :seat)
1)
(ev-bk-check!
"second booking takes seat 2"
(get (ev/book! b "o1" 3 (quote c)) :seat)
2)
(ev-bk-check!
"booked status reported"
(get (ev/book! b "o1" 3 (quote d)) :status)
:booked)
(ev-bk-check!
"roster is oldest-first"
(ev/roster b "o1")
(list (quote a) (quote c) (quote d)))
(ev-bk-check!
"seats-left is zero when full"
(ev/seats-left b "o1" 3)
0)
(ev-bk-check!
"free booking is confirmed state"
(ev/seat-state b "o1" (quote a))
:confirmed)))
(let
((b (persist/open)))
(do
(ev/book! b "o2" 1 (quote a))
(ev-bk-check!
"booking past capacity is refused"
(get (ev/book! b "o2" 1 (quote c)) :status)
:full)
(ev-bk-check!
"full does not grow the roster"
(ev/roster b "o2")
(list (quote a)))
(ev-bk-check!
"seats-left zero at capacity"
(ev/seats-left b "o2" 1)
0)))
(let
((b (persist/open)))
(do
(ev/book! b "o3" 5 (quote a))
(ev-bk-check!
"re-booking the same actor is idempotent"
(get (ev/book! b "o3" 5 (quote a)) :status)
:already)
(ev-bk-check!
"idempotent re-book reports existing seat"
(get (ev/book! b "o3" 5 (quote a)) :seat)
1)
(ev-bk-check!
"roster unchanged after re-book"
(ev/roster b "o3")
(list (quote a)))
(ev-bk-check!
"count unchanged after re-book"
(ev-booking-count b "o3")
1)))
(let
((b (persist/open)))
(do
(ev/book! b "last" 2 (quote x))
(let
((snap (ev-bk-snap b "last")) (exp (ev-bk-seq b "last")))
(let
((ra (ev/book-with-observed b "last" 2 (quote a) snap exp))
(rb
(ev/book-with-observed
b
"last"
2
(quote bee)
snap
exp)))
(do
(ev-bk-check!
"race winner is booked"
(get ra :status)
:booked)
(ev-bk-check!
"race winner takes the last seat"
(get ra :seat)
2)
(ev-bk-check!
"race loser is rejected with a conflict"
(get rb :status)
:conflict)
(ev-bk-check!
"conflict reports the advanced seq"
(get rb :actual)
(+ exp 1))
(ev-bk-check!
"no overbooking: exactly two on roster"
(ev-booking-count b "last")
2)
(ev-bk-check!
"race loser is NOT on the roster"
(ev-bk-member? (quote bee) (ev/roster b "last"))
false)
(ev-bk-check!
"race loser retrying gets full"
(get (ev/book! b "last" 2 (quote bee)) :status)
:full))))))
(let
((b (persist/open)))
(do
(ev/book! b "room" 3 (quote x))
(let
((snap (ev-bk-snap b "room")) (exp (ev-bk-seq b "room")))
(let
((ra (ev/book-with-observed b "room" 3 (quote a) snap exp))
(rb
(ev/book-with-observed
b
"room"
3
(quote bee)
snap
exp)))
(do
(ev-bk-check!
"room winner booked seat 2"
(get ra :seat)
2)
(ev-bk-check!
"room loser first conflicts"
(get rb :status)
:conflict)
(ev-bk-check!
"room loser retry books seat 3"
(get (ev/book! b "room" 3 (quote bee)) :seat)
3)
(ev-bk-check!
"room roster is x,a,bee"
(ev/roster b "room")
(list (quote x) (quote a) (quote bee)))
(ev-bk-check!
"room is now full"
(ev/seats-left b "room" 3)
0))))))
(let
((b (persist/open)))
(do
(ev/book! b "cx" 2 (quote a))
(ev/book! b "cx" 2 (quote c))
(ev-bk-check!
"occupied to capacity before cancel"
(ev/seats-left b "cx" 2)
0)
(ev-bk-check!
"booking when full (pre-cancel) is refused"
(get (ev/book! b "cx" 2 (quote d)) :status)
:full)
(ev-bk-check!
"cancel reports cancelled"
(get (ev/cancel! b "cx" (quote a)) :status)
:cancelled)
(ev-bk-check!
"cancel removes actor from roster"
(ev/roster b "cx")
(list (quote c)))
(ev-bk-check!
"cancel frees a seat"
(ev/seats-left b "cx" 2)
1)
(ev-bk-check!
"freed seat is bookable again"
(get (ev/book! b "cx" 2 (quote d)) :status)
:booked)
(ev-bk-check!
"roster after rebook is c,d"
(ev/roster b "cx")
(list (quote c) (quote d)))))
(let
((b (persist/open)))
(do
(ev/book! b "ce" 3 (quote a))
(ev-bk-check!
"cancelling an unbooked actor is a no-op"
(get (ev/cancel! b "ce" (quote z)) :status)
:not-booked)
(ev-bk-check!
"no-op cancel leaves roster intact"
(ev/roster b "ce")
(list (quote a)))
(ev/cancel! b "ce" (quote a))
(ev-bk-check!
"double cancel is not-booked the second time"
(get (ev/cancel! b "ce" (quote a)) :status)
:not-booked)
(ev-bk-check!
"empty roster after cancel"
(ev/roster b "ce")
(list))
(ev-bk-check!
"cancelled actor may re-book"
(get (ev/book! b "ce" 3 (quote a)) :status)
:booked)
(ev-bk-check!
"re-booked actor back on roster"
(ev/roster b "ce")
(list (quote a)))))
(let
((b (persist/open)))
(do
(ev/book! b "h" 2 (quote a))
(ev-bk-check!
"hold reports held"
(get (ev/hold! b "h" 2 (quote p)) :status)
:held)
(ev-bk-check!
"held seat is :held state"
(ev/seat-state b "h" (quote p))
:held)
(ev-bk-check!
"held actor is on the roster"
(ev/roster b "h")
(list (quote a) (quote p)))
(ev-bk-check!
"held seat blocks the last booking"
(get (ev/book! b "h" 2 (quote x)) :status)
:full)
(ev-bk-check!
"no seats left with one held"
(ev/seats-left b "h" 2)
0)))
(let
((b (persist/open)))
(do
(ev/hold! b "hc" 3 (quote p))
(ev-bk-check!
"confirm reports confirmed"
(get (ev/confirm! b "hc" (quote p)) :status)
:confirmed)
(ev-bk-check!
"confirmed seat is :confirmed state"
(ev/seat-state b "hc" (quote p))
:confirmed)
(ev-bk-check!
"re-confirm is already-confirmed"
(get (ev/confirm! b "hc" (quote p)) :status)
:already-confirmed)
(ev-bk-check!
"confirming a non-holder is not-held"
(get (ev/confirm! b "hc" (quote z)) :status)
:not-held)
(ev-bk-check!
"confirmed seat still occupies"
(ev/seats-left b "hc" 3)
2)))
(let
((b (persist/open)))
(do
(ev/book! b "hr" 2 (quote a))
(ev/hold! b "hr" 2 (quote p))
(ev-bk-check!
"full while hold pending"
(ev/seats-left b "hr" 2)
0)
(ev-bk-check!
"release reports released"
(get (ev/release! b "hr" (quote p)) :status)
:released)
(ev-bk-check!
"release frees the held seat"
(ev/seats-left b "hr" 2)
1)
(ev-bk-check!
"released actor off the roster"
(ev/roster b "hr")
(list (quote a)))
(ev-bk-check!
"freed seat bookable after release"
(get (ev/book! b "hr" 2 (quote x)) :status)
:booked)
(ev/hold! b "hr2" 1 (quote q))
(ev/confirm! b "hr2" (quote q))
(ev-bk-check!
"release on a confirmed seat is not-held"
(get (ev/release! b "hr2" (quote q)) :status)
:not-held)
(ev-bk-check!
"cancel frees a confirmed-from-hold seat"
(get (ev/cancel! b "hr2" (quote q)) :status)
:cancelled)))
(let
((b (persist/open)))
(do
(ev/book! b "hlast" 2 (quote x))
(let
((snap (ev-bk-snap b "hlast")) (exp (ev-bk-seq b "hlast")))
(let
((ra (ev/hold-with-observed b "hlast" 2 (quote p) snap exp))
(rb
(ev/hold-with-observed
b
"hlast"
2
(quote q)
snap
exp)))
(do
(ev-bk-check! "hold race winner held" (get ra :status) :held)
(ev-bk-check!
"hold race loser conflicts"
(get rb :status)
:conflict)
(ev-bk-check!
"no oversell via concurrent holds"
(ev-booking-count b "hlast")
2)
(ev-bk-check!
"hold loser retry gets full"
(get (ev/hold! b "hlast" 2 (quote q)) :status)
:full))))))
(let
((b (persist/open)))
(do
(ev/hold! b "hi" 4 (quote p))
(ev-bk-check!
"re-holding the same actor is idempotent"
(get (ev/hold! b "hi" 4 (quote p)) :status)
:already)
(ev-bk-check!
"hold idempotency keeps one seat"
(ev-booking-count b "hi")
1))))))
;; ---- waitlist ----
(define
ev-bk-wl-run-all!
(fn
()
(do
;; join the waitlist when full; book directly when a seat is free
(let
((b (persist/open)))
(do
(ev-bk-check! "waitlist! books when a seat is free" (get (ev/waitlist! b "w" 2 (quote a)) :status) :booked)
(ev-bk-check! "second booking still fits" (get (ev/waitlist! b "w" 2 (quote c)) :status) :booked)
(ev-bk-check! "third joins the waitlist when full" (get (ev/waitlist! b "w" 2 (quote x)) :status) :waitlisted)
(ev-bk-check! "fourth is next in line" (get (ev/waitlist! b "w" 2 (quote y)) :position) 2)
(ev-bk-check! "waitlist is FIFO" (ev/waitlist b "w") (list (quote x) (quote y)))
(ev-bk-check! "seats unaffected by waitlisting" (ev/roster b "w") (list (quote a) (quote c)))
(ev-bk-check! "waitlist-position reports a queued actor" (ev/waitlist-position b "w" (quote y)) 2)
(ev-bk-check! "waitlist-position 0 for a seated actor" (ev/waitlist-position b "w" (quote a)) 0)))
;; idempotency
(let
((b (persist/open)))
(do
(ev/waitlist! b "wi" 1 (quote a))
(ev/waitlist! b "wi" 1 (quote x))
(ev-bk-check! "re-joining as a seated actor is :already" (get (ev/waitlist! b "wi" 1 (quote a)) :status) :already)
(ev-bk-check! "re-joining the queue is :already-waiting" (get (ev/waitlist! b "wi" 1 (quote x)) :status) :already-waiting)
(ev-bk-check! "queue did not grow on re-join" (ev/waitlist b "wi") (list (quote x)))))
;; leaving the waitlist
(let
((b (persist/open)))
(do
(ev/waitlist! b "wl" 1 (quote a))
(ev/waitlist! b "wl" 1 (quote x))
(ev/waitlist! b "wl" 1 (quote y))
(ev-bk-check! "leave-waitlist reports left" (get (ev/leave-waitlist! b "wl" (quote x)) :status) :left)
(ev-bk-check! "leaving removes from the queue" (ev/waitlist b "wl") (list (quote y)))
(ev-bk-check! "leaving when not queued is not-waiting" (get (ev/leave-waitlist! b "wl" (quote z)) :status) :not-waiting)))
;; auto-promotion on cancel
(let
((b (persist/open)))
(do
(ev/waitlist! b "wp" 1 (quote a))
(ev/waitlist! b "wp" 1 (quote x))
(ev/waitlist! b "wp" 1 (quote y))
(let
((r (ev/cancel-promote! b "wp" 1 (quote a))))
(do
(ev-bk-check! "cancel-promote cancels the seat holder" (get r :status) :cancelled)
(ev-bk-check! "cancel-promote promotes the head of the queue" (get r :promoted) (quote x))))
(ev-bk-check! "promoted actor now holds the seat" (ev/roster b "wp") (list (quote x)))
(ev-bk-check! "promoted actor left the queue" (ev/waitlist b "wp") (list (quote y)))
(ev-bk-check! "promoted seat is confirmed" (ev/seat-state b "wp" (quote x)) :confirmed)
;; cancelling with an empty waitlist promotes nobody
(ev/leave-waitlist! b "wp" (quote y))
(let
((r2 (ev/cancel-promote! b "wp" 1 (quote x))))
(ev-bk-check! "cancel with empty waitlist promotes nobody" (get r2 :promoted) nil))
(ev-bk-check! "seat is free after the last cancel" (ev/seats-left b "wp" 1) 1))))))
(define
ev-booking-tests-run!
(fn
()
(do
(set! ev-bk-pass 0)
(set! ev-bk-fail 0)
(set! ev-bk-failures (list))
(ev-bk-run-all!)
(ev-bk-wl-run-all!)
{:failures ev-bk-failures :total (+ ev-bk-pass ev-bk-fail) :passed ev-bk-pass :failed ev-bk-fail})))

View File

@@ -0,0 +1,592 @@
;; lib/events/tests/calendar.sx — civil date core + RRULE window expansion.
(define ev-cal-pass 0)
(define ev-cal-fail 0)
(define ev-cal-failures (list))
(define
ev-cal-check!
(fn
(name got expected)
(if
(= got expected)
(set! ev-cal-pass (+ ev-cal-pass 1))
(do
(set! ev-cal-fail (+ ev-cal-fail 1))
(append!
ev-cal-failures
(str name "\n expected: " expected "\n got: " got))))))
;; Project occurrences to (civil weekday) pairs for legible assertions.
(define
ev-cal-shape
(fn
(occs)
(map
(fn
(o)
(list (ev-dt->civil (get o :start)) (ev-dt-weekday (get o :start))))
occs)))
(define
ev-cal-starts
(fn (occs) (map (fn (o) (ev-dt->civil (get o :start))) occs)))
(define
ev-cal-run-all!
(fn
()
(do
(ev-cal-check!
"epoch day zero"
(ev-days-from-civil 1970 1 1)
0)
(ev-cal-check!
"y2k day number"
(ev-days-from-civil 2000 1 1)
10957)
(ev-cal-check!
"leap day round trip"
(ev-civil-from-days
(ev-days-from-civil 2024 2 29))
(list 2024 2 29))
(ev-cal-check!
"pre-epoch round trip"
(ev-civil-from-days
(ev-days-from-civil 1969 12 31))
(list 1969 12 31))
(ev-cal-check!
"epoch is thursday"
(ev-weekday-of-days 0)
3)
(ev-cal-check!
"2026-06-06 is saturday"
(ev-dt-weekday (ev-date 2026 6 6))
5)
(ev-cal-check!
"dt carries time of day"
(ev-dt-tod
(ev-dt 2026 6 1 9 30))
570)
(ev-cal-check!
"civil from dt"
(ev-dt->civil
(ev-dt 2026 12 25 8 0))
(list 2026 12 25))
(ev-cal-check!
"days in feb 2024 (leap)"
(ev-days-in-month 2024 2)
29)
(ev-cal-check!
"days in feb 2026"
(ev-days-in-month 2026 2)
28)
(ev-cal-check!
"add months wraps year"
(ev-add-months 2026 11 3)
(list 2027 2))
(ev-cal-check!
"add months within year"
(ev-add-months 2026 1 5)
(list 2026 6))
(let
((ev (ev-event (quote one) (ev-dt 2026 6 10 14 0) 60 nil 1)))
(do
(ev-cal-check!
"single inside window emits once"
(len
(ev-expand
ev
(ev-date 2026 6 1)
(ev-date 2026 7 1)))
1)
(ev-cal-check!
"single before window omitted"
(len
(ev-expand
ev
(ev-date 2026 7 1)
(ev-date 2026 8 1)))
0)
(ev-cal-check!
"single after window omitted"
(len
(ev-expand
ev
(ev-date 2026 1 1)
(ev-date 2026 2 1)))
0)
(ev-cal-check!
"occurrence end is start plus duration"
(get
(first
(ev-expand
ev
(ev-date 2026 6 1)
(ev-date 2026 7 1)))
:end)
(+
(ev-dt 2026 6 10 14 0)
60))))
(let
((daily (ev-event (quote d) (ev-dt 2026 6 1 9 0) 30 {:freq :daily :count 5} 1)))
(do
(ev-cal-check!
"daily count caps occurrences"
(ev-cal-starts
(ev-expand
daily
(ev-date 2026 6 1)
(ev-date 2026 7 1)))
(list
(list 2026 6 1)
(list 2026 6 2)
(list 2026 6 3)
(list 2026 6 4)
(list 2026 6 5)))
(ev-cal-check!
"daily preserves time of day"
(ev-dt-tod
(get
(first
(ev-expand
daily
(ev-date 2026 6 1)
(ev-date 2026 7 1)))
:start))
540)))
(let
((di (ev-event (quote di) (ev-dt 2026 6 1 0 0) 30 {:interval 3 :freq :daily :until (ev-date 2026 6 30)} 1)))
(ev-cal-check!
"daily interval 3 steps by three days"
(ev-cal-starts
(ev-expand
di
(ev-date 2026 6 1)
(ev-date 2026 6 13)))
(list
(list 2026 6 1)
(list 2026 6 4)
(list 2026 6 7)
(list 2026 6 10)
(list 2026 6 13))))
(let
((dc (ev-event (quote dc) (ev-dt 2026 6 1 0 0) 30 {:freq :daily :count 10} 1)))
(ev-cal-check!
"count is window-independent (clip middle)"
(ev-cal-starts
(ev-expand
dc
(ev-date 2026 6 5)
(ev-date 2026 6 8)))
(list
(list 2026 6 5)
(list 2026 6 6)
(list 2026 6 7)
(list 2026 6 8))))
(let
((dc2 (ev-event (quote dc2) (ev-dt 2026 6 1 0 0) 30 {:freq :daily :count 3} 1)))
(ev-cal-check!
"count exhausted before window yields nothing"
(len
(ev-expand
dc2
(ev-date 2026 6 10)
(ev-date 2026 6 20)))
0))
(let
((wk (ev-event (quote w) (ev-dt 2026 6 1 18 0) 90 {:freq :weekly :byday (list 0 2 4)} 1)))
(ev-cal-check!
"weekly byday mon/wed/fri first two weeks"
(ev-cal-shape
(ev-expand
wk
(ev-date 2026 6 1)
(ev-date 2026 6 13)))
(list
(list (list 2026 6 1) 0)
(list (list 2026 6 3) 2)
(list (list 2026 6 5) 4)
(list (list 2026 6 8) 0)
(list (list 2026 6 10) 2)
(list (list 2026 6 12) 4))))
(let
((wu (ev-event (quote wu) (ev-dt 2026 6 1 18 0) 90 {:freq :weekly :until (ev-dt 2026 6 10 23 0) :byday (list 0 2)} 1)))
(ev-cal-check!
"weekly until clips trailing occurrences"
(ev-cal-starts
(ev-expand
wu
(ev-date 2026 6 1)
(ev-date 2026 7 1)))
(list
(list 2026 6 1)
(list 2026 6 3)
(list 2026 6 8)
(list 2026 6 10))))
(let
((wi (ev-event (quote wi) (ev-dt 2026 6 1 18 0) 90 {:interval 2 :freq :weekly :byday (list 0)} 1)))
(ev-cal-check!
"weekly interval 2 skips alternate weeks"
(ev-cal-starts
(ev-expand
wi
(ev-date 2026 6 1)
(ev-date 2026 7 6)))
(list
(list 2026 6 1)
(list 2026 6 15)
(list 2026 6 29))))
(let
((wd (ev-event (quote wd) (ev-dt 2026 6 3 12 0) 60 {:freq :weekly :count 3} 1)))
(ev-cal-check!
"weekly default byday is dtstart weekday"
(ev-cal-shape
(ev-expand
wd
(ev-date 2026 6 1)
(ev-date 2026 8 1)))
(list
(list (list 2026 6 3) 2)
(list (list 2026 6 10) 2)
(list (list 2026 6 17) 2))))
(let
((wc (ev-event (quote wc) (ev-dt 2026 6 1 18 0) 90 {:freq :weekly :count 10 :byday (list 0 2)} 1)))
(ev-cal-check!
"weekly count window-independent (clip middle)"
(ev-cal-starts
(ev-expand
wc
(ev-date 2026 6 15)
(ev-date 2026 7 5)))
(list
(list 2026 6 15)
(list 2026 6 17)
(list 2026 6 22)
(list 2026 6 24)
(list 2026 6 29)
(list 2026 7 1))))
(let
((wf (ev-event (quote wf) (ev-dt 2026 6 3 18 0) 90 {:freq :weekly :count 4 :byday (list 0 2 4)} 1)))
(ev-cal-check!
"first week skips byday earlier than dtstart"
(ev-cal-starts
(ev-expand
wf
(ev-date 2026 6 1)
(ev-date 2026 7 1)))
(list
(list 2026 6 3)
(list 2026 6 5)
(list 2026 6 8)
(list 2026 6 10))))
(let
((md (ev-event (quote md) (ev-dt 2026 1 15 9 0) 60 {:bymonthday (list 15) :freq :monthly} 1)))
(do
(ev-cal-check!
"monthly bymonthday 15th"
(ev-cal-starts
(ev-expand
md
(ev-date 2026 1 1)
(ev-date 2026 4 1)))
(list
(list 2026 1 15)
(list 2026 2 15)
(list 2026 3 15)))
(ev-cal-check!
"monthly preserves time of day"
(ev-dt-tod
(get
(first
(ev-expand
md
(ev-date 2026 1 1)
(ev-date 2026 4 1)))
:start))
540)))
(let
((mm (ev-event (quote mm) (ev-dt 2026 1 1 9 0) 60 {:bymonthday (list 1 15) :freq :monthly :count 4} 1)))
(ev-cal-check!
"monthly multiple bymonthday sorted within month"
(ev-cal-starts
(ev-expand
mm
(ev-date 2026 1 1)
(ev-date 2026 12 1)))
(list
(list 2026 1 1)
(list 2026 1 15)
(list 2026 2 1)
(list 2026 2 15))))
(let
((ml (ev-event (quote ml) (ev-dt 2026 1 31 9 0) 60 {:bymonthday (list -1) :freq :monthly} 1)))
(ev-cal-check!
"monthly bymonthday -1 is last day"
(ev-cal-starts
(ev-expand
ml
(ev-date 2026 1 1)
(ev-date 2026 4 1)))
(list
(list 2026 1 31)
(list 2026 2 28)
(list 2026 3 31))))
(let
((mn (ev-event (quote mn) (ev-dt 2026 1 1 9 0) 60 {:freq :monthly :byday (list {:ord 2 :wd 1})} 1)))
(ev-cal-check!
"monthly 2nd tuesday"
(ev-cal-shape
(ev-expand
mn
(ev-date 2026 1 1)
(ev-date 2026 4 1)))
(list
(list (list 2026 1 13) 1)
(list (list 2026 2 10) 1)
(list (list 2026 3 10) 1))))
(let
((mz (ev-event (quote mz) (ev-dt 2026 1 1 9 0) 60 {:freq :monthly :byday (list {:ord -1 :wd 4})} 1)))
(ev-cal-check!
"monthly last friday"
(ev-cal-shape
(ev-expand
mz
(ev-date 2026 1 1)
(ev-date 2026 4 1)))
(list
(list (list 2026 1 30) 4)
(list (list 2026 2 27) 4)
(list (list 2026 3 27) 4))))
(let
((m31 (ev-event (quote m31) (ev-dt 2026 1 31 9 0) 60 {:freq :monthly :count 4} 1)))
(ev-cal-check!
"monthly default day-of-month skips short months"
(ev-cal-starts
(ev-expand
m31
(ev-date 2026 1 1)
(ev-date 2026 12 1)))
(list
(list 2026 1 31)
(list 2026 3 31)
(list 2026 5 31)
(list 2026 7 31))))
(let
((mi (ev-event (quote mi) (ev-dt 2026 1 10 9 0) 60 {:interval 3 :freq :monthly :count 3} 1)))
(ev-cal-check!
"monthly interval 3 steps by quarter"
(ev-cal-starts
(ev-expand
mi
(ev-date 2026 1 1)
(ev-date 2027 1 1)))
(list
(list 2026 1 10)
(list 2026 4 10)
(list 2026 7 10))))
(let
((mc (ev-event (quote mc) (ev-dt 2026 1 5 9 0) 60 {:freq :monthly :count 12} 1)))
(ev-cal-check!
"monthly count window-independent (clip middle)"
(ev-cal-starts
(ev-expand
mc
(ev-date 2026 4 1)
(ev-date 2026 6 30)))
(list
(list 2026 4 5)
(list 2026 5 5)
(list 2026 6 5))))
(let
((a (ev-event (quote a) (ev-dt 2026 6 2 10 0) 30 {:freq :daily :count 2} 1))
(b
(ev-event
(quote b)
(ev-dt 2026 6 1 9 0)
30
{:freq :daily :count 2}
1)))
(ev-cal-check!
"expand-all sorts merged occurrences by start"
(map
(fn (o) (list (get o :id) (ev-dt->civil (get o :start))))
(ev-expand-all
(list a b)
(ev-date 2026 6 1)
(ev-date 2026 7 1)))
(list
(list (quote b) (list 2026 6 1))
(list (quote b) (list 2026 6 2))
(list (quote a) (list 2026 6 2))
(list (quote a) (list 2026 6 3))))))))
;; ---- EXDATE / RDATE exceptions ----
(define
ev-cal-ex-run-all!
(fn
()
(do
;; EXDATE removes a matching occurrence from the recurrence
(let
((ex
(ev-event-full
(quote standup)
(ev-dt 2026 6 1 9 0)
30
{:freq :daily :count 5}
1
(list (ev-dt 2026 6 3 9 0))
(list))))
(ev-cal-check!
"EXDATE excludes the matching occurrence"
(ev-cal-starts (ev-expand ex (ev-date 2026 6 1) (ev-date 2026 7 1)))
(list (list 2026 6 1) (list 2026 6 2) (list 2026 6 4) (list 2026 6 5))))
;; EXDATE that matches nothing is a no-op
(let
((ex2
(ev-event-full
(quote s)
(ev-dt 2026 6 1 9 0)
30
{:freq :daily :count 3}
1
(list (ev-dt 2026 6 9 9 0))
(list))))
(ev-cal-check!
"EXDATE not matching any occurrence is a no-op"
(len (ev-expand ex2 (ev-date 2026 6 1) (ev-date 2026 7 1)))
3))
;; RDATE adds an explicit occurrence (within the window)
(let
((rd
(ev-event-full
(quote s)
(ev-dt 2026 6 1 9 0)
30
{:freq :daily :count 3}
1
(list)
(list (ev-dt 2026 6 10 9 0)))))
(do
(ev-cal-check!
"RDATE adds an explicit occurrence, sorted in"
(ev-cal-starts (ev-expand rd (ev-date 2026 6 1) (ev-date 2026 7 1)))
(list (list 2026 6 1) (list 2026 6 2) (list 2026 6 3) (list 2026 6 10)))
(ev-cal-check!
"RDATE outside the window is dropped"
(len (ev-expand rd (ev-date 2026 6 1) (ev-date 2026 6 5)))
3)))
;; RDATE coinciding with an rrule occurrence is de-duplicated
(let
((rdup
(ev-event-full
(quote s)
(ev-dt 2026 6 1 9 0)
30
{:freq :daily :count 3}
1
(list)
(list (ev-dt 2026 6 2 9 0)))))
(ev-cal-check!
"RDATE duplicating an occurrence does not double it"
(len (ev-expand rdup (ev-date 2026 6 1) (ev-date 2026 7 1)))
3))
;; EXDATE wins over RDATE for the same datetime
(let
((both
(ev-event-full
(quote s)
(ev-dt 2026 6 1 9 0)
30
{:freq :daily :count 3}
1
(list (ev-dt 2026 6 2 9 0))
(list (ev-dt 2026 6 2 9 0)))))
(ev-cal-check!
"EXDATE wins over RDATE and the rrule for the same date"
(ev-cal-starts (ev-expand both (ev-date 2026 6 1) (ev-date 2026 7 1)))
(list (list 2026 6 1) (list 2026 6 3))))
;; RDATE-only event (no rrule)
(let
((ronly
(ev-event-full
(quote s)
(ev-dt 2026 6 1 9 0)
30
nil
1
(list)
(list (ev-dt 2026 6 5 9 0) (ev-dt 2026 6 3 9 0)))))
(ev-cal-check!
"RDATE-only event yields dtstart plus the extra dates, sorted"
(ev-cal-starts (ev-expand ronly (ev-date 2026 6 1) (ev-date 2026 7 1)))
(list (list 2026 6 1) (list 2026 6 3) (list 2026 6 5))))
;; plain ev-event (no exception keys) is unaffected
(let
((plain (ev-event (quote p) (ev-dt 2026 6 1 9 0) 30 {:freq :daily :count 3} 1)))
(ev-cal-check!
"plain event without exceptions expands unchanged"
(len (ev-expand plain (ev-date 2026 6 1) (ev-date 2026 7 1)))
3)))))
;; ---- per-occurrence overrides (reschedule one instance) ----
(define
ev-cal-ov-run-all!
(fn
()
(let
((base (ev-event (quote standup) (ev-dt 2026 6 1 9 0) 30 {:freq :daily :count 4} 1)))
(do
;; reschedule one instance to a new time + duration
(let
((moved (ev-with-override base (ev-dt 2026 6 2 9 0) (ev-dt 2026 6 2 14 0) 45)))
(let
((occs (ev-expand moved (ev-date 2026 6 1) (ev-date 2026 6 5))))
(do
(ev-cal-check!
"override moves only the targeted instance"
(map (fn (o) (ev-dt-tod (get o :start))) occs)
(list 540 840 540 540))
(ev-cal-check!
"override applies the new duration"
(map (fn (o) (- (get o :end) (get o :start))) occs)
(list 30 45 30 30))
(ev-cal-check!
"override keeps the series length"
(len occs)
4))))
;; an instance moved out of the window vacates its slot
(let
((movedout (ev-with-override base (ev-dt 2026 6 2 9 0) (ev-dt 2026 6 20 9 0) 30)))
(ev-cal-check!
"instance moved out of window is dropped, slot vacated"
(ev-cal-starts (ev-expand movedout (ev-date 2026 6 1) (ev-date 2026 6 5)))
(list (list 2026 6 1) (list 2026 6 3) (list 2026 6 4))))
;; override for a non-existent original start is a no-op
(let
((noop (ev-with-override base (ev-dt 2026 6 9 9 0) (ev-dt 2026 6 9 14 0) 45)))
(ev-cal-check!
"override for a non-occurring start is a no-op"
(len (ev-expand noop (ev-date 2026 6 1) (ev-date 2026 6 5)))
4))
;; overrides re-sort the agenda when an instance moves earlier
(let
((early (ev-with-override base (ev-dt 2026 6 3 9 0) (ev-dt 2026 6 1 7 0) 30)))
(ev-cal-check!
"an instance moved earlier re-sorts into place"
(map (fn (o) (ev-dt-tod (get o :start))) (ev-expand early (ev-date 2026 6 1) (ev-date 2026 6 5)))
(list 420 540 540 540)))))))
(define
ev-calendar-tests-run!
(fn
()
(do
(set! ev-cal-pass 0)
(set! ev-cal-fail 0)
(set! ev-cal-failures (list))
(ev-cal-run-all!)
(ev-cal-ex-run-all!)
(ev-cal-ov-run-all!)
{:failures ev-cal-failures :total (+ ev-cal-pass ev-cal-fail) :passed ev-cal-pass :failed ev-cal-fail})))

View File

@@ -0,0 +1,289 @@
;; 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})))

View File

@@ -0,0 +1,77 @@
;; lib/events/tests/notify.sx — durable notification delivery flows.
(define ev-nt-pass 0)
(define ev-nt-fail 0)
(define ev-nt-failures (list))
(define
ev-nt-check!
(fn
(name got expected)
(if
(= got expected)
(set! ev-nt-pass (+ ev-nt-pass 1))
(do
(set! ev-nt-fail (+ ev-nt-fail 1))
(append!
ev-nt-failures
(str name "\n expected: " expected "\n got: " got))))))
;; Each case runs a Scheme flow program (notify flows preloaded) and asserts on
;; the SX-native result. Scheme symbols come back as strings.
(define
ev-nt-run-all!
(fn
()
(do
(ev-nt-check!
"reminder delivers on the first attempt"
(ev/notify-run
"(define s (flow/start (ev-deliver-reminder 3) (list (quote m1) (quote alice) (quote hello))))\n (flow-run-host (lambda (k p) (list (quote ok) (quote sent))) 5)\n (list (flow/status (car (cdr s))) (flow/result (car (cdr s))))")
(list "done" (list "delivered" "m1" 1)))
(ev-nt-check!
"reminder retries a transient failure then delivers"
(ev/notify-run
"(define hits 0)\n (define s (flow/start (ev-deliver-reminder 3) (list (quote m1) (quote bob) (quote hi))))\n (flow-run-host (lambda (k p) (begin (set! hits (+ hits 1)) (if (< hits 2) (list (quote retry) (quote down)) (list (quote ok) (quote sent))))) 10)\n (list (flow/result (car (cdr s))) hits)")
(list (list "delivered" "m1" 2) 2))
(ev-nt-check!
"reminder gives up after maxn attempts"
(ev/notify-run
"(define s (flow/start (ev-deliver-reminder 2) (list (quote m1) (quote x) (quote y))))\n (flow-run-host (lambda (k p) (list (quote retry) (quote down))) 10)\n (flow/result (car (cdr s)))")
(list "failed" "m1" "down"))
(ev-nt-check!
"redelivery of the same id sends only once (at-least-once, idempotent)"
(ev/notify-run
"(define sent (list)) (define deliveries 0)\n (define (xport k p)\n (let ((id (ev-msg-id p)))\n (if (ev-mem id sent)\n (list (quote ok) (quote duplicate))\n (begin (set! sent (cons id sent)) (set! deliveries (+ deliveries 1)) (list (quote ok) (quote sent))))))\n (define s1 (flow/start (ev-deliver-reminder 3) (list (quote m1) (quote a) (quote hi))))\n (flow-run-host xport 5)\n (define s2 (flow/start (ev-deliver-reminder 3) (list (quote m1) (quote a) (quote hi))))\n (flow-run-host xport 5)\n (list deliveries (flow/result (car (cdr s2))))")
(list 1 (list "delivered" "m1" 1)))
(ev-nt-check!
"digest delivers every message in the batch"
(ev/notify-run
"(define s (flow/start (ev-deliver-digest 3) (list (list (quote a) (quote u1) (quote hi)) (list (quote b) (quote u2) (quote yo)))))\n (flow-run-host (lambda (k p) (list (quote ok) (quote sent))) 10)\n (flow/result (car (cdr s)))")
(list
(list "delivered" "a" 1)
(list "delivered" "b" 1)))
(ev-nt-check!
"digest reports per-message outcomes independently"
(ev/notify-run
"(define (xport k p)\n (let ((id (ev-msg-id p)))\n (if (equal? id (quote b)) (list (quote retry) (quote flaky)) (list (quote ok) (quote sent)))))\n (define s (flow/start (ev-deliver-digest 2) (list (list (quote a) (quote u1) (quote hi)) (list (quote b) (quote u2) (quote yo)) (list (quote c) (quote u3) (quote ya)))))\n (flow-run-host xport 12)\n (flow/result (car (cdr s)))")
(list
(list "delivered" "a" 1)
(list "failed" "b" "flaky")
(list "delivered" "c" 1)))
(ev-nt-check!
"delivery suspends until the transport responds"
(ev/notify-run
"(define s (flow/start (ev-deliver-reminder 3) (list (quote m1) (quote a) (quote hi))))\n (flow/status (car (cdr s)))")
"suspended"))))
(define
ev-notify-tests-run!
(fn
()
(do
(set! ev-nt-pass 0)
(set! ev-nt-fail 0)
(set! ev-nt-failures (list))
(ev-nt-run-all!)
{:failures ev-nt-failures :total (+ ev-nt-pass ev-nt-fail) :passed ev-nt-pass :failed ev-nt-fail})))

View File

@@ -0,0 +1,276 @@
;; lib/events/tests/reminders.sx — reminder + digest derivation from the agenda.
(define ev-rm-pass 0)
(define ev-rm-fail 0)
(define ev-rm-failures (list))
(define
ev-rm-check!
(fn
(name got expected)
(if
(= got expected)
(set! ev-rm-pass (+ ev-rm-pass 1))
(do
(set! ev-rm-fail (+ ev-rm-fail 1))
(append!
ev-rm-failures
(str name "\n expected: " expected "\n got: " got))))))
;; A store with a weekly class (Mon+Wed 18:00, 60m, 4 occurrences) and a one-off
;; talk; durable bookings on a persist backend.
(define
ev-rm-store
(fn
()
(ev/schedule
(ev/schedule
(ev/empty)
(quote yoga)
(ev-dt 2026 6 1 18 0)
60
{:freq :weekly :count 4 :byday (list 0 2)}
20)
(quote talk)
(ev-dt 2026 6 2 12 0)
30
nil
50)))
(define
ev-rm-run-all!
(fn
()
(let
((store (ev-rm-store)) (b (persist/open)))
(let
((occs (ev/agenda store (ev-date 2026 6 1) (ev-date 2026 7 1))))
(do
(ev/book-occ! b store (quote nia) (first occs))
(ev/book-occ! b store (quote ola) (first occs))
(ev/book-occ!
b
store
(quote ola)
(ev-occ
(quote talk)
(ev-dt 2026 6 2 12 0)
30))
(do
(let
((rs (ev/occurrence-reminders b (first occs) 60)))
(do
(ev-rm-check!
"one reminder per booked attendee"
(len rs)
2)
(ev-rm-check!
"reminder fires lead minutes before start"
(get (first rs) :fire-at)
(-
(ev-dt
2026
6
1
18
0)
60))
(ev-rm-check!
"reminder idempotency key encodes occ/recipient/lead"
(get (first rs) :id)
(str
(ev-occ-key (first occs))
"/"
(quote nia)
"/"
60))
(ev-rm-check!
"reminder names the event"
(get (first rs) :event)
(quote yoga))))
(ev-rm-check!
"unbooked occurrence has no reminders"
(len
(ev/occurrence-reminders b (ev-occ (quote yoga) (ev-dt 2026 6 3 18 0) 60) 60))
0)
(let
((all (ev/agenda-reminders b store (ev-date 2026 6 1) (ev-date 2026 7 1) 60)))
(do
(ev-rm-check!
"agenda reminders cover all bookings"
(len all)
3)
(ev-rm-check!
"agenda reminders sorted by fire-at"
(map (fn (r) (get r :fire-at)) all)
(list
(-
(ev-dt
2026
6
1
18
0)
60)
(-
(ev-dt
2026
6
1
18
0)
60)
(-
(ev-dt
2026
6
2
12
0)
60)))))
(let
((all (ev/agenda-reminders b store (ev-date 2026 6 1) (ev-date 2026 7 1) 60)))
(do
(ev-rm-check!
"nothing due before the first fire-at"
(len
(ev/due-reminders
all
(-
(ev-dt
2026
6
1
17
0)
1)))
0)
(ev-rm-check!
"the two yoga reminders are due at 17:00"
(len
(ev/due-reminders
all
(ev-dt
2026
6
1
17
0)))
2)
(ev-rm-check!
"all reminders due once past the last fire-at"
(len
(ev/due-reminders
all
(ev-dt
2026
6
2
12
0)))
3)))
(let
((r (first (ev/occurrence-reminders b (first occs) 60))))
(ev-rm-check!
"reminder projects to (id recipient body)"
(ev/reminder->msg r)
(list
(str
(ev-occ-key (first occs))
"/"
(quote nia)
"/"
60)
(quote nia)
(list
:reminder (quote yoga)
(ev-dt
2026
6
1
18
0)))))
(let
((dig (ev/agenda-digest b store (quote ola) (ev-date 2026 6 1) (ev-date 2026 7 1))))
(do
(ev-rm-check!
"digest is addressed to the actor"
(get dig :recipient)
(quote ola))
(ev-rm-check!
"digest lists the actor's booked occurrences"
(map (fn (it) (get it :event)) (get dig :items))
(list (quote yoga) (quote talk)))))
(let
((empty-dig (ev/agenda-digest b store (quote nobody) (ev-date 2026 6 1) (ev-date 2026 7 1))))
(ev-rm-check!
"digest empty for an actor with no bookings"
(get empty-dig :items)
(list)))))))))
;; ---- reschedule notifications ----
(define
ev-rm-rs-run-all!
(fn
()
(let
((b (persist/open))
(ev (ev-event (quote yoga) (ev-dt 2026 6 1 9 0) 60 {:freq :daily :count 3} 20)))
(let
((occ2 (ev-occ (quote yoga) (ev-dt 2026 6 2 9 0) 60)))
(do
(ev/book-occ! b (ev/add-event (ev/empty) ev) (quote nia) occ2)
(ev/book-occ! b (ev/add-event (ev/empty) ev) (quote ola) occ2)
;; reschedule the Jun 2 occurrence to 14:00 / 90 min
(let
((moved (ev-with-override ev (ev-dt 2026 6 2 9 0) (ev-dt 2026 6 2 14 0) 90)))
(let
((ns (ev/reschedule-notifications b moved)))
(do
(ev-rm-check!
"every booked attendee is notified of the reschedule"
(map (fn (n) (get n :recipient)) ns)
(list (quote nia) (quote ola)))
(ev-rm-check!
"reschedule carries old and new start"
(list (get (first ns) :old-start) (get (first ns) :new-start))
(list (ev-dt 2026 6 2 9 0) (ev-dt 2026 6 2 14 0)))
(ev-rm-check!
"reschedule carries the new duration"
(get (first ns) :new-duration)
90)
(ev-rm-check!
"reschedule idempotency key encodes original key + new start"
(get (first ns) :id)
(str (ev-occ-key occ2) "/reschedule/" (ev-dt 2026 6 2 14 0)))
(ev-rm-check!
"reschedule projects to notify wire shape"
(ev/reschedule-notify->msg (first ns))
(list
(str (ev-occ-key occ2) "/reschedule/" (ev-dt 2026 6 2 14 0))
(quote nia)
(list :rescheduled (quote yoga) (ev-dt 2026 6 2 9 0) (ev-dt 2026 6 2 14 0)))))))
;; an override on an occurrence nobody booked notifies no one
(let
((moved2 (ev-with-override ev (ev-dt 2026 6 3 9 0) (ev-dt 2026 6 3 10 0) 60)))
(ev-rm-check!
"rescheduling an unbooked occurrence notifies no one"
(len (ev/reschedule-notifications b moved2))
0))
;; an event with no overrides yields no reschedule notifications
(ev-rm-check!
"event without overrides has no reschedule notifications"
(len (ev/reschedule-notifications b ev))
0))))))
(define
ev-reminders-tests-run!
(fn
()
(do
(set! ev-rm-pass 0)
(set! ev-rm-fail 0)
(set! ev-rm-failures (list))
(ev-rm-run-all!)
(ev-rm-rs-run-all!)
{:failures ev-rm-failures :total (+ ev-rm-pass ev-rm-fail) :passed ev-rm-pass :failed ev-rm-fail})))

252
lib/events/tests/ticket.sx Normal file
View File

@@ -0,0 +1,252 @@
;; lib/events/tests/ticket.sx — paid-ticket contract + settlement orchestration.
(define ev-tk-pass 0)
(define ev-tk-fail 0)
(define ev-tk-failures (list))
(define
ev-tk-check!
(fn
(name got expected)
(if
(= got expected)
(set! ev-tk-pass (+ ev-tk-pass 1))
(do
(set! ev-tk-fail (+ ev-tk-fail 1))
(append!
ev-tk-failures
(str name "\n expected: " expected "\n got: " got))))))
(define
ev-tk-run-all!
(fn
()
(do
(let
((req (ev/checkout-request "occ1" (quote nia) 1500 "GBP" "ref-1")))
(do
(ev-tk-check!
"checkout-request is tagged"
(ev/checkout-request? req)
true)
(ev-tk-check!
"payment-result is not a checkout-request"
(ev/checkout-request? (ev/payment-paid "o" (quote a) "r"))
false)
(ev-tk-check!
"request occ-key accessor"
(ev/req-occ-key req)
"occ1")
(ev-tk-check!
"request actor accessor"
(ev/req-actor req)
(quote nia))
(ev-tk-check!
"request amount accessor"
(ev/req-amount req)
1500)
(ev-tk-check!
"request currency accessor"
(ev/req-currency req)
"GBP")
(ev-tk-check! "request ref accessor" (ev/req-ref req) "ref-1")))
(let
((res (ev/payment-paid "occ1" (quote nia) "ref-1")))
(do
(ev-tk-check!
"payment-result is tagged"
(ev/payment-result? res)
true)
(ev-tk-check! "result status accessor" (ev/result-status res) :paid)
(ev-tk-check!
"failed constructor carries status"
(ev/result-status (ev/payment-failed "o" (quote a) "r"))
:failed)
(ev-tk-check!
"expired constructor carries status"
(ev/result-status (ev/payment-expired "o" (quote a) "r"))
:expired)))
(let
((b (persist/open)))
(do
(let
((r (ev/request-ticket! b "show" 1 (quote a) 2000 "GBP" "ref-a")))
(do
(ev-tk-check!
"request-ticket awaiting-payment"
(get r :status)
:awaiting-payment)
(ev-tk-check!
"request-ticket returns a checkout-request"
(ev/checkout-request? (get r :request))
true)
(ev-tk-check!
"checkout-request carries the amount"
(ev/req-amount (get r :request))
2000)))
(ev-tk-check!
"held seat reserves capacity"
(ev/seats-left b "show" 1)
0)
(ev-tk-check!
"second buyer is full while payment pends"
(get
(ev/request-ticket!
b
"show"
1
(quote c)
2000
"GBP"
"ref-c")
:status)
:full)
(ev-tk-check!
"held seat state pending"
(ev/seat-state b "show" (quote a))
:held)))
(let
((b (persist/open)))
(do
(ev/request-ticket!
b
"gig"
2
(quote a)
2000
"GBP"
"ref-a")
(let
((s (ev/settle-payment! b (ev/payment-paid "gig" (quote a) "ref-a"))))
(ev-tk-check! "settle paid confirms" (get s :status) :confirmed))
(ev-tk-check!
"confirmed seat state"
(ev/seat-state b "gig" (quote a))
:confirmed)
(ev-tk-check!
"redelivered paid is still confirmed (idempotent)"
(get
(ev/settle-payment!
b
(ev/payment-paid "gig" (quote a) "ref-a"))
:status)
:confirmed)
(ev-tk-check!
"still exactly one seat taken"
(ev-booking-count b "gig")
1)))
(let
((b (persist/open)))
(do
(ev/request-ticket!
b
"fail"
1
(quote a)
2000
"GBP"
"ref-a")
(ev-tk-check!
"seat held before failure"
(ev/seats-left b "fail" 1)
0)
(let
((s (ev/settle-payment! b (ev/payment-failed "fail" (quote a) "ref-a"))))
(ev-tk-check! "settle failed releases" (get s :status) :released))
(ev-tk-check!
"released seat frees capacity"
(ev/seats-left b "fail" 1)
1)
(ev-tk-check!
"redelivered failure is a noop"
(get
(ev/settle-payment!
b
(ev/payment-failed "fail" (quote a) "ref-a"))
:status)
:noop)
(ev-tk-check!
"freed seat available to next buyer"
(get
(ev/request-ticket!
b
"fail"
1
(quote c)
2000
"GBP"
"ref-c")
:status)
:awaiting-payment)
(ev/request-ticket!
b
"exp"
1
(quote a)
2000
"GBP"
"ref-a")
(ev-tk-check!
"settle expired releases"
(get
(ev/settle-payment!
b
(ev/payment-expired "exp" (quote a) "ref-a"))
:status)
:released)))
(let
((b (persist/open)))
(do
(ev/request-ticket!
b
"race"
1
(quote a)
2000
"GBP"
"ref-a")
(ev/settle-payment!
b
(ev/payment-expired "race" (quote a) "ref-a"))
(ev-tk-check!
"late paid for a vanished hold needs a refund"
(get
(ev/settle-payment!
b
(ev/payment-paid "race" (quote a) "ref-a"))
:status)
:paid-but-no-hold)
(ev-tk-check!
"no phantom seat created"
(ev-booking-count b "race")
0)))
(let
((b (persist/open)))
(do
(let
((start (ev/request-ticket! b "e2e" 3 (quote nia) 2500 "GBP" "ref-nia")))
(ev/settle-payment!
b
(ev/payment-paid
(ev/req-occ-key (get start :request))
(ev/req-actor (get start :request))
(ev/req-ref (get start :request)))))
(ev-tk-check!
"e2e roster holds the buyer"
(ev/roster b "e2e")
(list (quote nia)))
(ev-tk-check!
"e2e seat confirmed"
(ev/seat-state b "e2e" (quote nia))
:confirmed))))))
(define
ev-ticket-tests-run!
(fn
()
(do
(set! ev-tk-pass 0)
(set! ev-tk-fail 0)
(set! ev-tk-failures (list))
(ev-tk-run-all!)
{:failures ev-tk-failures :total (+ ev-tk-pass ev-tk-fail) :passed ev-tk-pass :failed ev-tk-fail})))

View File

@@ -0,0 +1,173 @@
;; lib/events/tests/timezone.sx — timezones + DST.
(define ev-tz-pass 0)
(define ev-tz-fail 0)
(define ev-tz-failures (list))
(define
ev-tz-check!
(fn
(name got expected)
(if
(= got expected)
(set! ev-tz-pass (+ ev-tz-pass 1))
(do
(set! ev-tz-fail (+ ev-tz-fail 1))
(append!
ev-tz-failures
(str name "\n expected: " expected "\n got: " got))))))
;; Wall-clock (civil + minute-of-day) an occurrence's UTC start maps to in a tz.
(define
ev-tz-local-of
(fn
(tz utc-dt)
(let
((l (ev-tz-utc->local tz utc-dt)))
(list (ev-dt->civil l) (ev-dt-tod l)))))
(define
ev-tz-run-all!
(fn
()
(do
(let
((nyc (ev-tz-fixed "EST" -300)))
(do
(ev-tz-check!
"fixed zone: utc -> local subtracts 5h"
(ev-tz-utc->local
nyc
(ev-dt 2026 1 1 17 0))
(ev-dt 2026 1 1 12 0))
(ev-tz-check!
"fixed zone: local -> utc adds 5h back"
(ev-tz-local->utc
nyc
(ev-dt 2026 1 1 12 0))
(ev-dt 2026 1 1 17 0))
(ev-tz-check!
"UTC zone is identity"
(ev-tz-local->utc
ev-tz-utc
(ev-dt 2026 6 1 9 0))
(ev-dt 2026 6 1 9 0))))
(ev-tz-check!
"London winter offset is 0 (GMT)"
(ev-tz-offset
ev-tz-london
(ev-dt 2026 1 15 12 0))
0)
(ev-tz-check!
"London summer offset is 60 (BST)"
(ev-tz-offset
ev-tz-london
(ev-dt 2026 7 15 12 0))
60)
(ev-tz-check!
"Paris winter offset is 60 (CET)"
(ev-tz-offset
ev-tz-paris
(ev-dt 2026 1 15 12 0))
60)
(ev-tz-check!
"Paris summer offset is 120 (CEST)"
(ev-tz-offset
ev-tz-paris
(ev-dt 2026 7 15 12 0))
120)
(ev-tz-check!
"DST starts last Sunday of March"
(ev-dt->civil
(ev-tz-transition
2026
(ev-tz-rule 3 -1 6 60)))
(list 2026 3 29))
(ev-tz-check!
"DST ends last Sunday of October"
(ev-dt->civil
(ev-tz-transition
2026
(ev-tz-rule 10 -1 6 60)))
(list 2026 10 25))
(ev-tz-check!
"09:00 London in winter is 09:00 UTC"
(ev-tz-local->utc
ev-tz-london
(ev-dt 2026 1 15 9 0))
(ev-dt 2026 1 15 9 0))
(ev-tz-check!
"09:00 London in summer is 08:00 UTC"
(ev-tz-local->utc
ev-tz-london
(ev-dt 2026 7 15 9 0))
(ev-dt 2026 7 15 8 0))
(ev-tz-check!
"round trip utc -> local -> utc"
(ev-tz-local->utc
ev-tz-london
(ev-tz-utc->local
ev-tz-london
(ev-dt 2026 7 15 8 0)))
(ev-dt 2026 7 15 8 0))
(let
((ev (ev-event-tz (quote standup) (ev-dt 2026 3 27 9 0) 60 {:freq :daily :count 5} 10 ev-tz-london)))
(let
((occs (ev-expand ev (ev-date 2026 3 1) (ev-date 2026 4 5))))
(do
(ev-tz-check!
"daily occurrences shift in UTC across the DST boundary"
(map (fn (o) (ev-dt-tod (get o :start))) occs)
(list 540 540 480 480 480))
(ev-tz-check!
"but every occurrence stays 09:00 local wall-clock"
(map
(fn
(o)
(first
(rest (ev-tz-local-of ev-tz-london (get o :start)))))
occs)
(list 540 540 540 540 540))
(ev-tz-check!
"occurrence dates are stable in local time"
(map
(fn
(o)
(ev-civ-d
(first (ev-tz-local-of ev-tz-london (get o :start)))))
occs)
(list 27 28 29 30 31)))))
(let
((wk (ev-event-tz (quote class) (ev-dt 2026 3 23 18 0) 90 {:freq :weekly :byday (list 0)} 5 ev-tz-london)))
(let
((occs (ev-expand wk (ev-date 2026 3 1) (ev-date 2026 4 20))))
(ev-tz-check!
"weekly Monday 18:00 London stays 18:00 local each week"
(map
(fn
(o)
(first (rest (ev-tz-local-of ev-tz-london (get o :start)))))
occs)
(list 1080 1080 1080 1080))))
(let
((plain (ev-event (quote p) (ev-dt 2026 3 27 9 0) 60 {:freq :daily :count 3} 1)))
(ev-tz-check!
"plain event expands naively (no UTC shift)"
(map
(fn (o) (ev-dt-tod (get o :start)))
(ev-expand
plain
(ev-date 2026 3 1)
(ev-date 2026 4 5)))
(list 540 540 540))))))
(define
ev-timezone-tests-run!
(fn
()
(do
(set! ev-tz-pass 0)
(set! ev-tz-fail 0)
(set! ev-tz-failures (list))
(ev-tz-run-all!)
{:failures ev-tz-failures :total (+ ev-tz-pass ev-tz-fail) :passed ev-tz-pass :failed ev-tz-fail})))

101
lib/events/ticket.sx Normal file
View File

@@ -0,0 +1,101 @@
;; lib/events/ticket.sx — paid-ticket contract between events and commerce.
;;
;; A paid booking spans two subsystems. events does NOT import commerce; instead
;; this module defines the CONTRACT — the two messages on the wire — and the
;; events-side orchestration over provisional holds (booking.sx). commerce
;; imports these shapes; the dependency only points one way.
;;
;; checkout-request events -> commerce "take payment for this seat"
;; {:kind :events.checkout :occ-key :actor :amount :currency :ref}
;;
;; payment-result commerce -> events "here's how payment went"
;; {:kind :events.payment :occ-key :actor :ref :status}
;; :status ∈ :paid | :failed | :expired
;;
;; Flow: ev/request-ticket! places a capacity-safe HOLD (reserving the seat so
;; it can't be oversold while payment pends) and returns a checkout-request to
;; hand to commerce. When commerce reports back, ev/settle-payment! confirms the
;; hold on :paid or releases it otherwise. Settlement is idempotent — an
;; at-least-once redelivery of the same result is safe. `ref` is the opaque
;; correlation/idempotency id; occ-key + actor locate the hold, so settlement
;; needs no side table.
;; ---- contract: checkout request (events -> commerce) ----
(define
ev/checkout-request
(fn (occ-key actor amount currency ref) {:actor actor :amount amount :kind :events.checkout :ref ref :currency currency :occ-key occ-key}))
(define
ev/checkout-request?
(fn (m) (and (dict? m) (= (get m :kind) :events.checkout))))
(define ev/req-occ-key (fn (r) (get r :occ-key)))
(define ev/req-actor (fn (r) (get r :actor)))
(define ev/req-amount (fn (r) (get r :amount)))
(define ev/req-currency (fn (r) (get r :currency)))
(define ev/req-ref (fn (r) (get r :ref)))
;; ---- contract: payment result (commerce -> events) ----
(define ev/payment-result (fn (occ-key actor ref status) {:actor actor :kind :events.payment :status status :ref ref :occ-key occ-key}))
(define
ev/payment-result?
(fn (m) (and (dict? m) (= (get m :kind) :events.payment))))
(define ev/result-occ-key (fn (r) (get r :occ-key)))
(define ev/result-actor (fn (r) (get r :actor)))
(define ev/result-ref (fn (r) (get r :ref)))
(define ev/result-status (fn (r) (get r :status)))
(define
ev/payment-paid
(fn (occ-key actor ref) (ev/payment-result occ-key actor ref :paid)))
(define
ev/payment-failed
(fn (occ-key actor ref) (ev/payment-result occ-key actor ref :failed)))
(define
ev/payment-expired
(fn (occ-key actor ref) (ev/payment-result occ-key actor ref :expired)))
;; ---- orchestration ----
;; Begin a paid booking: place a capacity-safe hold and, if reserved, return a
;; checkout-request for commerce. :full when no seat; :already when the actor
;; already holds/booked this occurrence (no duplicate request).
(define
ev/request-ticket!
(fn
(b occ-key capacity actor amount currency ref)
(let
((h (ev/hold! b occ-key capacity actor)))
(cond
((= (get h :status) :held) {:seat (get h :seat) :request (ev/checkout-request occ-key actor amount currency ref) :status :awaiting-payment})
((= (get h :status) :already) {:seat (get h :seat) :status :already})
(else {:capacity capacity :status :full})))))
;; Settle a payment result from commerce. :paid confirms the hold; :failed /
;; :expired release it. Idempotent: a redelivered :paid stays :confirmed, a
;; redelivered release is a :noop. If a :paid arrives for a hold that is already
;; gone (released/expired first), returns :paid-but-no-hold so the caller can
;; trigger a refund.
(define
ev/settle-payment!
(fn
(b result)
(let
((occ-key (ev/result-occ-key result))
(actor (ev/result-actor result))
(ref (ev/result-ref result)))
(if
(= (ev/result-status result) :paid)
(let
((c (ev/confirm! b occ-key actor)))
(cond
((= (get c :status) :confirmed) {:actor actor :status :confirmed :ref ref})
((= (get c :status) :already-confirmed) {:actor actor :status :confirmed :ref ref})
(else {:actor actor :status :paid-but-no-hold :ref ref})))
(let
((r (ev/release! b occ-key actor)))
(if (= (get r :status) :released) {:actor actor :status :released :ref ref} {:actor actor :status :noop :ref ref}))))))

131
lib/events/timezone.sx Normal file
View File

@@ -0,0 +1,131 @@
;; lib/events/timezone.sx — timezones + DST for the calendar.
;;
;; Datetimes in calendar.sx are naive epoch-minutes (wall clock). A timezone
;; maps between wall-clock LOCAL time and absolute UTC. An event is authored in
;; local time + a tz; recurrence is expanded in local time (so a "09:00 weekly"
;; meeting stays 09:00 across a DST change), then each occurrence is converted
;; to UTC for storage/comparison.
;;
;; Offset convention: offset = local - utc (minutes). London summer (BST) = +60.
;; UTC = local - offset; local = utc + offset.
;;
;; Two kinds of zone, no IANA database:
;; :fixed — a constant offset.
;; :dst — std/dst offsets + two transition rules. Transitions are given in
;; UTC (EU zones all switch at 01:00 UTC), so the offset at any UTC
;; instant is a direct range check; no recursion. Northern-hemisphere
;; ordering (dst-start < dst-end within a year) is assumed.
;;
;; Requires calendar.sx (ev-dt, ev-days-from-civil, ev-civil-from-days,
;; ev-civ-y, ev-floor-div, ev-resolve-nth-weekday).
;; A DST transition rule: the ord-th weekday `wd` (0=Mon..6=Sun) of `month`, at
;; `time` minutes-of-day UTC. EU: last Sunday (ord -1, wd 6) at 01:00 UTC.
(define ev-tz-rule (fn (month ord wd time) {:ord ord :wd wd :month month :time time}))
(define ev-tz-fixed (fn (name offset) {:name name :offset offset :kind :fixed}))
(define ev-tz-dst (fn (name std dst start-rule end-rule) {:name name :kind :dst :dst-end end-rule :dst-start start-rule :std-offset std :dst-offset dst}))
;; Standard (winter) offset — the initial guess when inverting local -> utc.
(define
ev-tz-std-offset
(fn
(tz)
(if (= (get tz :kind) :fixed) (get tz :offset) (get tz :std-offset))))
;; The UTC instant (epoch-minutes) of a transition rule in a given year.
(define
ev-tz-transition
(fn
(year rule)
(let
((day (ev-resolve-nth-weekday year (get rule :month) (get rule :ord) (get rule :wd))))
(+
(* (ev-days-from-civil year (get rule :month) day) 1440)
(get rule :time)))))
;; The offset (minutes) in effect at a UTC instant.
(define
ev-tz-offset
(fn
(tz utc-dt)
(cond
((= (get tz :kind) :fixed) (get tz :offset))
((= (get tz :kind) :dst)
(let
((year (ev-civ-y (ev-civil-from-days (ev-floor-div utc-dt 1440)))))
(let
((start (ev-tz-transition year (get tz :dst-start)))
(end (ev-tz-transition year (get tz :dst-end))))
(if
(and (>= utc-dt start) (< utc-dt end))
(get tz :dst-offset)
(get tz :std-offset)))))
(else 0))))
;; UTC instant -> local wall-clock.
(define
ev-tz-utc->local
(fn (tz utc-dt) (+ utc-dt (ev-tz-offset tz utc-dt))))
;; Local wall-clock -> UTC instant. The offset depends on the instant, so we
;; guess with the standard offset and refine once (correct except within the
;; one-hour DST gap/overlap, where it resolves to the pre-transition offset).
(define
ev-tz-local->utc
(fn
(tz local-dt)
(let
((utc1 (- local-dt (ev-tz-offset tz (- local-dt (ev-tz-std-offset tz))))))
(- local-dt (ev-tz-offset tz utc1)))))
;; ---- predefined zones ----
(define ev-tz-utc (ev-tz-fixed "UTC" 0))
(define
ev-tz-london
(ev-tz-dst
"Europe/London"
0
60
(ev-tz-rule 3 -1 6 60)
(ev-tz-rule 10 -1 6 60)))
(define
ev-tz-paris
(ev-tz-dst
"Europe/Paris"
60
120
(ev-tz-rule 3 -1 6 60)
(ev-tz-rule 10 -1 6 60)))
;; ---- tz-aware event expansion ----
;; An event authored in local time + a tz. dtstart-local / rrule / exceptions
;; are all wall-clock in `tz`; expansion converts each occurrence to UTC.
(define
ev-event-tz
(fn (id dtstart-local duration rrule capacity tz) {:id id :duration duration :dtstart dtstart-local :rrule rrule :capacity capacity :tz tz}))
;; Expand a tz-aware event over a UTC window. Local recurrence is expanded over
;; a window widened by a day each side (to catch occurrences whose UTC lands in
;; range), converted to UTC, then filtered to [win-start, win-end].
(define
ev-expand-tz
(fn
(event tz win-start win-end)
(let
((local-ws (- (ev-tz-utc->local tz win-start) 1440))
(local-we (+ (ev-tz-utc->local tz win-end) 1440)))
(let
((local-occs (ev-expand-naive event local-ws local-we)))
(let
((utc-occs (map (fn (o) (let ((u (ev-tz-local->utc tz (get o :start))) (dur (- (get o :end) (get o :start)))) {:id (get o :id) :start u :end (+ u dur)})) local-occs)))
(ev-sort-occs
(filter
(fn
(o)
(and
(>= (get o :start) win-start)
(<= (get o :start) win-end)))
utc-occs)))))))

View File

@@ -18,7 +18,7 @@ capacity rules, transactional booking, and a flow-driven notification dispatcher
## Status (rolling)
`bash lib/events/conformance.sh`**0/0** (not yet started)
`bash lib/events/conformance.sh`**295/295** (Phases 1-4 + 8 ext: fed f/b, waitlist, EXDATE/RDATE, overrides, booking/reschedule-notify, fed transport, timezones+DST)
## Ground rules
@@ -54,28 +54,204 @@ lib/events/api.sx ── (events/schedule) (events/book) (events/agenda) ──
```
## Phase 1 — Calendar + recurrence
- [ ] `calendar.sx` — event facts, RRULE expansion in a window
- [ ] `availability.sx` — free/busy rules
- [ ] `api.sx` + tests + scoreboard + conformance.sh
- [x] `calendar.sx` — event facts, RRULE expansion in a window (DAILY/WEEKLY)
- [x] `calendar.sx` — MONTHLY (bymonthday + nth-weekday byday)
- [x] `availability.sx` — free/busy rules (busy/conflict/busy_in on Datalog)
- [x] `availability.sx` — next-free slot search (same rules, different bindings)
- [x] `api.sx` — public entry points (schedule/agenda/book/free/next-free/conflicts)
- [x] tests + scoreboard + conformance.sh (73/73)
## Phase 2 — Ticketing + booking
- [ ] capacity rules; transactional booking → `persist` (no overbooking)
- [ ] paid tickets compose with `commerce` order flow
- [ ] tests: capacity edge, double-book guard, conflict detection
- [x] capacity rules; transactional booking → `persist` (no overbooking)
- [x] wire `booking.sx` into `api.sx` (persist-backed `ev/book-occ!` + derived availability)
- [x] cancellation (tombstone events) + seat release
- [x] provisional holds (hold/confirm/release) — reserve a seat during pending payment
- [x] paid tickets compose with `commerce` order flow (contract module over holds)
- [x] tests: capacity edge, double-book guard, conflict detection
## Phase 3 — Notification delivery (flow)
- [ ] `notify.sx` — reminder/digest flows over injected transport
- [ ] retry/backoff on transport failure (flow suspend/resume)
- [ ] tests: delivery success, retry path, idempotent re-send
- [x] `notify.sx` — reminder/digest flows over injected transport
- [x] retry/backoff on transport failure (flow suspend/resume)
- [x] tests: delivery success, retry path, idempotent re-send
- [x] wire reminders to occurrences (`reminders.sx` — derive from agenda + roster)
- [ ] NOTE: shared with `feed/notify` — candidate for later extraction to a
`delivery-on-sx` once a second consumer is real
`delivery-on-sx` once a second consumer is real. **Delivery core
(request→dispatch→resume, idempotent, bounded retry) is the extraction seam.**
## Phase 4 — Federation
- [ ] cross-instance events (peer calendar) — trust-gated stub
- [ ] tests: federated agenda merge
- [x] cross-instance events (peer calendar) — trust-gated stub
- [x] tests: federated agenda merge
- [x] federated availability/free-busy across trusted peers
- [x] injected transport (`ev/federated-agenda-via` + fetch) — fed-sx-ready, graceful degradation
## Progress log
(loop fills this in)
- 2026-06-07 — Timezone + DST support (user request). `timezone.sx`: a tz maps
wall-clock LOCAL ↔ absolute UTC (offset = local-utc). :fixed (constant) and
:dst (std/dst offsets + two UTC transition rules, e.g. EU last-Sun-Mar/Oct
01:00 UTC) zones, no IANA DB — transitions computed via calendar helpers
(ev-resolve-nth-weekday). `ev-event-tz` authors an event in local time + a tz;
`ev-expand` dispatches: tz events expand in LOCAL time (recurrence + EXDATE/
RDATE + overrides all wall-clock), then each occurrence converts to UTC, so a
"09:00 weekly" meeting stays 09:00 across a DST change (its UTC instant
shifts). Predefined ev-tz-utc/london/paris. local->utc inverts with a one-step
refinement. Plain events unaffected (ev-expand-naive). +17 tests, 295/295 green.
- 2026-06-07 — Injected federation transport (last plan item). `fetch` abstracts
how a peer's agenda arrives: (fetch peer-id ws we) -> {:status :ok :occurrences}
| {:status :error}. `ev/federated-agenda-via` merges local + each trusted
peer fetched via the transport, tagged with :origin; an unreachable peer is
skipped (graceful degradation), never breaking the agenda.
`ev/peer-fetch` is the in-process adapter (runs the existing store model
through the same interface); a real fed-sx/signed-fetch transport drops in
unchanged. `ev/federation-status` reports per-peer reachability. +6 tests,
278/278 green. All plan checkboxes (incl. extensions) now ticked.
- 2026-06-07 — Reschedule notifications (extension). When an event carries
per-occurrence overrides, `ev/reschedule-notifications` reads the roster at
each overridden occurrence's ORIGINAL occ-key and produces a reschedule
message per booked attendee (old-start, new-start, new-duration). Idempotency
key = original-key/reschedule/new-start. `ev/reschedule-notify->msg` for the
notify wire shape. Combines overrides (calendar) + rosters (booking) + the
message-derivation pattern. +7 tests, 272/272 green.
- 2026-06-07 — Booking lifecycle notifications (extension). `booking-notify.sx`
walks the booking stream into ordered notifications classified by kind:
:booked / :promoted / :held / :confirmed / :released / :cancelled /
:waitlisted. Promotion is detected by folding the waitlist as we walk (a
:booking for a currently-waitlisted actor is a promotion, not a fresh
booking). id = occ-key/seq (stable stream seq → idempotent re-derivation, no
double-ping). `ev/booking-notifications`, `ev/notify-of-kind`,
`ev/booking-notify->msg` (notify wire shape). Connects ticketing to the
delivery layer. +11 tests, 265/265 green.
- 2026-06-07 — Per-occurrence overrides / reschedule (RFC 5545 RECURRENCE-ID).
`ev-with-override event orig-start new-start new-duration` adds an :overrides
entry keyed by the occurrence's original start. `ev-expand` applies overrides
after EXDATE/RDATE: a targeted instance is re-timed/re-sized and the agenda
re-sorted; an instance moved out of the window is dropped (slot vacated);
override of a non-occurring start is a no-op. Used `assoc` for immutable
event update. +6 tests, 254/254 green.
- 2026-06-07 — RRULE exceptions EXDATE/RDATE (extension). `ev-event-full`
carries :exdate/:rdate (epoch-minute starts). Raw expansion renamed
`ev-expand-base`; `ev-expand` now applies exceptions: RDATE adds explicit
in-window occurrences, EXDATE removes matching starts, duplicates de-duped,
EXDATE wins over RDATE and the rrule (RFC 5545). RDATE-only events (no rrule)
supported. Plain `ev-event` (no exception keys) unaffected. +8 tests,
248/248 green.
- 2026-06-07 — Waitlist + auto-promotion (extension). When an occurrence is
full, `ev/waitlist!` queues actors FIFO (:waitlist/:unwaitlist events on the
same stream; waiting fold is independent of the seat fold since taking a seat
removes from the queue). `ev/waitlist` (queue), `ev/waitlist-position`,
`ev/leave-waitlist!`. `ev/cancel-promote!` cancels a seat and auto-promotes
the head of the queue to a confirmed booking when capacity opens. Idempotent
(:already / :already-waiting). +21 tests, 240/240 green.
- 2026-06-07 — Federated free/busy (extension). 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 "is X free in [qs,qe)?" across instances,
half-open, trust-gated (untrusted peers' busy ignored; revocation immediate).
+10 tests, 219/219 green.
- 2026-06-07 — **Phase 4: federation (trust-gated stub).** `federation.sx`:
a peer publishes a schedule (events store); `ev/federated-agenda` merges the
local agenda (origin :local) with every TRUSTED peer's agenda, sorted by
start, each occurrence tagged with :origin provenance. Trust is a peer-id set
re-checked per merge (revocation is immediate); untrusted peers contribute
nothing. `ev/peer`, `ev/trusts?`, `ev/trusted-peers`, `ev/peer-agenda`
(expands the peer's recurrence in-window), `ev/from-origin` (filter by
source). Real transport slots behind `ev/peer-agenda` unchanged. +13 tests,
**209/209 green — all four plan phases implemented.**
- 2026-06-07 — Reminders + digests from the agenda. `reminders.sx` bridges
calendar + durable rosters to notify: `ev/occurrence-reminders` (one per
booked attendee, fires `lead` before start, idempotency key
occ-key/recipient/lead), `ev/agenda-reminders` (window-wide, sorted by
fire-at), `ev/due-reminders` (fire-at ≤ now — the scheduler query),
`ev/reminder->msg` (projects to notify's (id recipient body) shape),
`ev/agenda-digest` + `ev/agenda-for-p` (an actor's upcoming booked
occurrences). +14 tests, 196/196 green.
- 2026-06-07 — **Phase 3 start: notification delivery flows.** `notify.sx`:
reminders + digests as durable `flow`s over an INJECTED transport (the host
`dispatch`). A flow `request`s delivery (suspend), the host sends and resumes
with the outcome; flow's replay log means a completed send is never re-run on
recovery. At-least-once + idempotent: messages carry an id; the transport
dedups (re-send is a no-op that still reports ok) and replay logs each
outcome. Retry rides suspend/resume — each attempt uses a DISTINCT tag
`(deliver <id> <n>)` so replay stays correct; dispatch returns (ok) /
(retry reason), bounded by maxn → (failed id reason). Digest delivers a batch
with independent per-message outcomes. Authored as Scheme flow source run via
`ev/notify-run` (scheme + flow substrate preloaded). +7 tests, 182/182 green.
Delivery core is the `delivery-on-sx` extraction seam for feed/notify.
- 2026-06-07 — **Phase 2 complete: paid-ticket contract.** `ticket.sx` defines
the two wire messages between events and commerce — `checkout-request`
(events→commerce) and `payment-result` (commerce→events, :paid/:failed/
:expired) — so commerce imports the contract, not vice versa. Orchestration
over holds: `ev/request-ticket!` places a capacity-safe hold + emits a
checkout-request; `ev/settle-payment!` confirms on :paid, releases on
failure/expiry. Idempotent (redelivered :paid stays confirmed, redelivered
release is :noop); a late :paid for a vanished hold → :paid-but-no-hold
(refund signal), no phantom seat. occ-key+actor locate the hold so no side
table. +31 tests, 175/175 green. Phase 3 (notification flows) is next.
- 2026-06-07 — Provisional holds (paid-ticket foundation). Booking stream now
carries :booking/:hold/:confirm/:release/:cancel; the fold tracks per-actor
seat STATE (:held / :confirmed). A held seat counts toward capacity, so a
pending payment cannot be oversold. `ev/hold!` (capacity-safe, retrying),
`ev/confirm!` (held→confirmed), `ev/release!` (frees a held seat only),
`ev/seat-state`. Seat-acquiring writes (:booking/:hold) go through
append-expect; seat-freeing writes (:cancel/:release) and :confirm append
directly (never oversell). Holds race test mirrors the booking race. +24
tests, 144/144 green. Next: ticket.sx contract module over holds.
- 2026-06-07 — Wired `booking.sx` into `api.sx`: durable persist-backed booking
path alongside the in-memory one. `ev/book-occ!`, `ev/cancel-occ!`,
`ev/roster-occ`, `ev/seats-left-occ` (capacity from the scheduled event);
`ev/free-p?`, `ev/next-free-p`, `ev/conflicts-p` derive availability by
replaying persist booking streams for in-window occurrences. Capacity-safe +
cancellable bookings now flow through the public API. Reordered conformance
preloads (persist + booking before events/api). +10 tests, 120/120 green.
- 2026-06-07 — Cancellation + seat release. Booking stream now carries
:booking / :cancel events; the live roster is the FOLDED replay (book adds,
cancel removes) so capacity reopens when a seat is freed. `ev/cancel!`
(retrying, append-expect), `ev/cancel-with-observed`. Edge cases: cancelling
an unbooked actor → :not-booked (no-op), double cancel → :not-booked,
cancelled actor may re-book. Capacity count is the folded roster size, not
the physical event count. +13 tests, 110/110 green.
- 2026-06-07 — **Phase 2 start: capacity-safe booking.** `booking.sx`: one
append-only persist stream per occurrence; roster = stream replayed. Booking
decisions made against an OBSERVED (roster, last-seq) snapshot, committed via
`persist/append-expect` — append only if last-seq unchanged, else a conflict
value the booker retries. This makes capacity-check + append atomic at the
persist boundary: no overbooking, no lock. `ev/book!` (retrying),
`ev/book-with-observed`, `ev/roster`, `ev/seats-left`. Idempotent per actor
(:already). Explicit last-seat race test: two bookers on the same snapshot →
one :booked, one :conflict, roster never exceeds capacity; loser retry →
:full (or next seat when room remains). 24 tests, 97/97 green.
- 2026-06-07 — **Phase 1 complete.** `api.sx`: immutable `store`
({:events :bookings}) facade over calendar + availability. `ev/schedule`,
`ev/book`, `ev/agenda`, `ev/agenda-for`, `ev/free?`, `ev/next-free`,
`ev/conflicts`. Availability queries auto-widen the expansion window back by
the longest event so any overlapping occurrence is captured. 14 tests,
73/73 green. Phase 2 (transactional booking on persist) is next — `ev/book`
becomes capacity-safe via a persist append at that point.
- 2026-06-07 — `next-free` slot search: earliest start ≥ after where
[s,s+duration) is free and ends ≤ horizon, else nil. Candidates are `after`
plus each busy-interval end (interval-packing); each probe reuses the
`busy_in` Datalog rule via `ev-free?`. Finds gaps between bookings, skips
too-short gaps, half-open at edges. +6 tests, 59/59.
- 2026-06-07 — `availability.sx`: free/busy + conflict detection as forward-
chained Datalog over `occurrence`/`booking` EDB. Rules `busy(A,S,E)`,
`conflict(A,O1,O2)` (canonical `O1<O2`, half-open overlap `S1<E2 ∧ S2<E1`),
`busy_in(A,QS,QE)` for window queries. API: `ev-busy`, `ev-conflicts`,
`ev-has-conflict?`, `ev-free?` (transient qwindow assert/retract). Integrates
with calendar expansion (book expanded occurrences). 16 tests, 53/53 green.
- 2026-06-06 — MONTHLY recurrence. `ev-days-in-month`, `ev-add-months`,
BYMONTHDAY (incl. negative = from month end), ordinal BYDAY (`{:ord N :wd W}`,
ord<0 = nth-from-last), default day-of-month (skips months too short, e.g.
day-31 monthly skips Feb/Apr). Refactored weekly+monthly onto a shared
`ev-emit-occs` per-period emitter. 37/37 green (+13).
- 2026-06-06 — Phase 1 scaffold + calendar recurrence. `calendar.sx`: integer
epoch-minute datetimes, Hinnant civil<->day-number conversion, DAILY/WEEKLY
RRULE expansion in a bounded (start,end) window with INTERVAL, COUNT (window-
independent), UNTIL, BYDAY (weekly). `ev-expand-all` merges + sorts. Wired
conformance harness (conf + thin wrapper reusing `lib/guest/conformance.sh`),
scoreboard. 24/24 green. MONTHLY deferred to next commit.
## Blockers
(loop fills this in)
- None. Substrates present: `lib/datalog` (276/276), `lib/persist`, `lib/flow`
all exist — Phase 2/3 unblocked when reached.