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

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