Compare commits
27 Commits
loops/comm
...
loops/iden
| Author | SHA1 | Date | |
|---|---|---|---|
| d466ca3414 | |||
| 3b782eba8a | |||
| 8130521f02 | |||
| 398209d484 | |||
| 3c3b09688a | |||
| ded7170540 | |||
| b1f9c6bef0 | |||
| db885e15bc | |||
| d2f5b49d3f | |||
| 226d755b57 | |||
| 3f3459d129 | |||
| 9860582b4a | |||
| a43825f25f | |||
| e951f23f14 | |||
| 21673b6731 | |||
| e448220b33 | |||
| a5c22c5a01 | |||
| 785faf2441 | |||
| dc00ed9786 | |||
| 56cf920041 | |||
| 20ba152e36 | |||
| baee67f561 | |||
| 27f43dbf10 | |||
| 064bbf18b3 | |||
| 938e90455d | |||
| ac63501266 | |||
| 1c6b80404e |
@@ -1,56 +0,0 @@
|
||||
;; lib/commerce/api.sx — public commerce surface.
|
||||
;;
|
||||
;; A session bundles a pricing context with a cart: {:ctx CTX :cart CART}.
|
||||
;; All operations are pure and return a new session. The total and the
|
||||
;; per-line breakdown are deterministic functions of (ctx, cart).
|
||||
;;
|
||||
;; commerce-checkout is a Phase-3 stub — the order lifecycle is a durable
|
||||
;; flow that suspends at the SumUp payment boundary.
|
||||
|
||||
(define commerce-session (fn (ctx) {:cart empty-cart :ctx ctx}))
|
||||
|
||||
(define commerce-ctx (fn (sess) (get sess :ctx)))
|
||||
(define commerce-cart (fn (sess) (get sess :cart)))
|
||||
(define commerce-lines (fn (sess) (cart-lines (get sess :cart))))
|
||||
(define commerce-count (fn (sess) (cart-count (get sess :cart))))
|
||||
|
||||
(define
|
||||
commerce-add
|
||||
(fn
|
||||
(sess sku variant qty)
|
||||
(assoc sess :cart (cart-add (get sess :cart) sku variant qty))))
|
||||
|
||||
(define
|
||||
commerce-remove
|
||||
(fn
|
||||
(sess sku variant)
|
||||
(assoc sess :cart (cart-remove (get sess :cart) sku variant))))
|
||||
|
||||
(define
|
||||
commerce-set-qty
|
||||
(fn
|
||||
(sess sku variant qty)
|
||||
(assoc sess :cart (cart-set-qty (get sess :cart) sku variant qty))))
|
||||
|
||||
;; True when the sku exists in the session's catalog snapshot.
|
||||
(define
|
||||
commerce-can-add?
|
||||
(fn (sess sku) (catalog-has? (ctx-catalog (get sess :ctx)) sku)))
|
||||
|
||||
(define
|
||||
commerce-total
|
||||
(fn (sess) (cart-total (get sess :ctx) (get sess :cart))))
|
||||
|
||||
;; Per-line audit breakdown — the "which line contributed what" view.
|
||||
(define
|
||||
line-detail
|
||||
(fn (ctx line) (let ((cat (ctx-catalog ctx))) {:sku (line-sku line) :unit (line-unit-price cat (line-sku line) (line-variant line)) :qty (line-qty line) :variant (line-variant line) :extended (line-extended cat line) :tax (line-tax ctx line)})))
|
||||
|
||||
(define
|
||||
commerce-explain
|
||||
(fn
|
||||
(sess)
|
||||
(map (fn (l) (line-detail (get sess :ctx) l)) (get sess :cart))))
|
||||
|
||||
;; Phase 3 — order lifecycle flow (reserve -> pay -> fulfil) lands here.
|
||||
(define commerce-checkout (fn (sess) {:note "order lifecycle flow lands in Phase 3" :phase 3 :status :not-implemented}))
|
||||
@@ -1,100 +0,0 @@
|
||||
;; lib/commerce/attribution.sx — line-level discount attribution.
|
||||
;;
|
||||
;; The briefing's marquee backward query: "which line item triggered this
|
||||
;; discount?". promo.sx computes discount amounts at the class/order level;
|
||||
;; this layer answers the *scope* question relationally and in both directions:
|
||||
;; forward — which lines does code C touch? (lines-for-code)
|
||||
;; backward — which codes touch this line? (codes-for-line)
|
||||
;; Both are the same relation promo-toucheso run with different vars bound.
|
||||
;;
|
||||
;; A :fixed promo is order-level (touches no single line); query those with
|
||||
;; order-level-codes. Only promos that actually apply (amount > 0) touch lines.
|
||||
|
||||
;; Lines whose sku is in product-class `cls`.
|
||||
(define
|
||||
class-lines
|
||||
(fn
|
||||
(ctx cart cls)
|
||||
(filter
|
||||
(fn (l) (= (catalog-class (ctx-catalog ctx) (line-sku l)) cls))
|
||||
cart)))
|
||||
|
||||
;; The lines a promo applies to (its scope). :fixed is order-level → no lines.
|
||||
(define
|
||||
promo-lines
|
||||
(fn
|
||||
(ctx cart p)
|
||||
(let
|
||||
((k (promo-kind p)))
|
||||
(cond
|
||||
((= k :percent) (class-lines ctx cart (nth p 2)))
|
||||
((= k :member)
|
||||
(if
|
||||
(= (get ctx :customer) :member)
|
||||
(class-lines ctx cart (nth p 2))
|
||||
(list)))
|
||||
((= k :bundle)
|
||||
(filter (fn (l) (= (line-sku l) (nth p 2))) cart))
|
||||
(:else (list))))))
|
||||
|
||||
;; Relation: promo `code` touches `line`. Only applying promos (amount > 0)
|
||||
;; touch anything, so an inapplicable promo contributes no pairs.
|
||||
(define
|
||||
promo-toucheso
|
||||
(fn
|
||||
(ctx cart ruleset code line)
|
||||
(fresh
|
||||
(p)
|
||||
(membero p ruleset)
|
||||
(project
|
||||
(p)
|
||||
(if
|
||||
(> (promo-amount ctx cart p) 0)
|
||||
(mk-conj
|
||||
(== code (promo-code p))
|
||||
(membero line (promo-lines ctx cart p)))
|
||||
fail)))))
|
||||
|
||||
;; --- query helpers ---
|
||||
|
||||
(define
|
||||
lines-for-code
|
||||
(fn
|
||||
(ctx cart ruleset code)
|
||||
(run* line (promo-toucheso ctx cart ruleset code line))))
|
||||
|
||||
(define
|
||||
codes-for-line
|
||||
(fn
|
||||
(ctx cart ruleset line)
|
||||
(run* code (promo-toucheso ctx cart ruleset code line))))
|
||||
|
||||
(define
|
||||
line-touched-by?
|
||||
(fn
|
||||
(ctx cart ruleset code line)
|
||||
(not
|
||||
(empty?
|
||||
(run
|
||||
1
|
||||
c
|
||||
(mk-conj (promo-toucheso ctx cart ruleset code line) (== c true)))))))
|
||||
|
||||
;; Applying order-level (:fixed) promos — discounts with no single line.
|
||||
(define
|
||||
order-level-codes
|
||||
(fn
|
||||
(ctx cart ruleset)
|
||||
(run*
|
||||
code
|
||||
(fresh
|
||||
(p)
|
||||
(membero p ruleset)
|
||||
(project
|
||||
(p)
|
||||
(if
|
||||
(and
|
||||
(> (promo-amount ctx cart p) 0)
|
||||
(= (promo-kind p) :fixed))
|
||||
(== code (promo-code p))
|
||||
fail))))))
|
||||
@@ -1,86 +0,0 @@
|
||||
;; lib/commerce/cart.sx — cart as an ordered list of line items.
|
||||
;;
|
||||
;; A cart is a native list of lines; a line is (list sku variant qty).
|
||||
;; All operations are pure: they return a new cart, never mutate. Line
|
||||
;; order is insertion order (stable) so totals are reproducible.
|
||||
;;
|
||||
;; cart-lineo is the relational view — because a line *is* a (sku variant qty)
|
||||
;; tuple, membero queries the cart directly, forward or backward.
|
||||
|
||||
(define empty-cart (list))
|
||||
|
||||
(define make-line (fn (sku variant qty) (list sku variant qty)))
|
||||
(define line-sku (fn (l) (nth l 0)))
|
||||
(define line-variant (fn (l) (nth l 1)))
|
||||
(define line-qty (fn (l) (nth l 2)))
|
||||
|
||||
(define
|
||||
same-line?
|
||||
(fn
|
||||
(l sku variant)
|
||||
(and (= (line-sku l) sku) (= (line-variant l) variant))))
|
||||
|
||||
(define
|
||||
cart-qty
|
||||
(fn
|
||||
(cart sku variant)
|
||||
(let
|
||||
((m (filter (fn (l) (same-line? l sku variant)) cart)))
|
||||
(if (empty? m) 0 (line-qty (first m))))))
|
||||
|
||||
(define
|
||||
cart-remove
|
||||
(fn
|
||||
(cart sku variant)
|
||||
(filter (fn (l) (not (same-line? l sku variant))) cart)))
|
||||
|
||||
;; Add qty units; merges into an existing (sku,variant) line in place,
|
||||
;; otherwise appends a new line at the end.
|
||||
(define
|
||||
cart-add
|
||||
(fn
|
||||
(cart sku variant qty)
|
||||
(let
|
||||
((existing (cart-qty cart sku variant)))
|
||||
(if
|
||||
(= existing 0)
|
||||
(append cart (list (make-line sku variant qty)))
|
||||
(map
|
||||
(fn
|
||||
(l)
|
||||
(if
|
||||
(same-line? l sku variant)
|
||||
(make-line sku variant (+ existing qty))
|
||||
l))
|
||||
cart)))))
|
||||
|
||||
;; Set the absolute quantity; qty <= 0 removes the line.
|
||||
(define
|
||||
cart-set-qty
|
||||
(fn
|
||||
(cart sku variant qty)
|
||||
(if
|
||||
(<= qty 0)
|
||||
(cart-remove cart sku variant)
|
||||
(if
|
||||
(= (cart-qty cart sku variant) 0)
|
||||
(append cart (list (make-line sku variant qty)))
|
||||
(map
|
||||
(fn
|
||||
(l)
|
||||
(if (same-line? l sku variant) (make-line sku variant qty) l))
|
||||
cart)))))
|
||||
|
||||
(define cart-empty? (fn (cart) (empty? cart)))
|
||||
(define cart-lines (fn (cart) cart))
|
||||
(define cart-skus (fn (cart) (map line-sku cart)))
|
||||
|
||||
;; Total number of units across all lines.
|
||||
(define
|
||||
cart-count
|
||||
(fn (cart) (reduce (fn (acc l) (+ acc (line-qty l))) 0 cart)))
|
||||
|
||||
;; Relational view of cart lines.
|
||||
(define
|
||||
cart-lineo
|
||||
(fn (cart sku variant qty) (membero (list sku variant qty) cart)))
|
||||
@@ -1,83 +0,0 @@
|
||||
;; lib/commerce/catalog.sx — catalog snapshot + relational accessors.
|
||||
;;
|
||||
;; A catalog snapshot is an immutable dict:
|
||||
;; {:products (list (list sku price class) ...)
|
||||
;; :variants (list (list sku variant delta) ...)
|
||||
;; :stock (list (list sku variant qty) ...)}
|
||||
;;
|
||||
;; Money is integer minor units (pence/cents). class is a keyword product
|
||||
;; class consumed later by tax and promotion relations. delta is a signed
|
||||
;; price adjustment for a variant; qty is on-hand stock for (sku,variant).
|
||||
;;
|
||||
;; Accessor relations take the snapshot as the first argument and are fully
|
||||
;; multidirectional: (producto cat "widget" p c) binds p,c forward;
|
||||
;; (producto cat s 1000 c) enumerates every sku priced 1000 backward.
|
||||
|
||||
(define empty-catalog {:products (list) :stock (list) :variants (list)})
|
||||
|
||||
(define make-catalog (fn (products variants stock) {:products products :stock stock :variants variants}))
|
||||
|
||||
(define cat-products (fn (cat) (get cat :products)))
|
||||
(define cat-variants (fn (cat) (get cat :variants)))
|
||||
(define cat-stock (fn (cat) (get cat :stock)))
|
||||
|
||||
;; --- core fact relations ---
|
||||
|
||||
(define
|
||||
producto
|
||||
(fn
|
||||
(cat sku price class)
|
||||
(membero (list sku price class) (get cat :products))))
|
||||
|
||||
(define
|
||||
varianto
|
||||
(fn
|
||||
(cat sku variant delta)
|
||||
(membero (list sku variant delta) (get cat :variants))))
|
||||
|
||||
(define
|
||||
stocko
|
||||
(fn
|
||||
(cat sku variant qty)
|
||||
(membero (list sku variant qty) (get cat :stock))))
|
||||
|
||||
;; --- derived relations ---
|
||||
|
||||
(define
|
||||
priceo
|
||||
(fn (cat sku price) (fresh (c) (producto cat sku price c))))
|
||||
|
||||
(define
|
||||
classo
|
||||
(fn (cat sku class) (fresh (p) (producto cat sku p class))))
|
||||
|
||||
;; Effective unit price of a (sku,variant): base + variant delta.
|
||||
(define
|
||||
unit-priceo
|
||||
(fn
|
||||
(cat sku variant price)
|
||||
(fresh
|
||||
(base delta)
|
||||
(priceo cat sku base)
|
||||
(varianto cat sku variant delta)
|
||||
(pluso-i base delta price))))
|
||||
|
||||
;; --- deterministic lookups (first solution under fixed fact order) ---
|
||||
|
||||
(define
|
||||
catalog-price
|
||||
(fn
|
||||
(cat sku)
|
||||
(let
|
||||
((rs (run 1 p (priceo cat sku p))))
|
||||
(if (empty? rs) nil (first rs)))))
|
||||
|
||||
(define
|
||||
catalog-class
|
||||
(fn
|
||||
(cat sku)
|
||||
(let
|
||||
((rs (run 1 c (classo cat sku c))))
|
||||
(if (empty? rs) nil (first rs)))))
|
||||
|
||||
(define catalog-has? (fn (cat sku) (not (nil? (catalog-price cat sku)))))
|
||||
@@ -1,153 +0,0 @@
|
||||
#!/usr/bin/env bash
|
||||
# lib/commerce/conformance.sh — run commerce test suites in one sx_server
|
||||
# process per suite, emit scoreboard.json + scoreboard.md.
|
||||
#
|
||||
# commerce-on-sx builds pricing/promotion as miniKanren relations, so every
|
||||
# suite loads the miniKanren stack first, then the commerce modules.
|
||||
|
||||
set -uo pipefail
|
||||
cd "$(git rev-parse --show-toplevel)"
|
||||
|
||||
SX_SERVER="${SX_SERVER:-/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe}"
|
||||
if [ ! -x "$SX_SERVER" ]; then
|
||||
SX_SERVER="hosts/ocaml/_build/default/bin/sx_server.exe"
|
||||
fi
|
||||
if [ ! -x "$SX_SERVER" ]; then
|
||||
echo "ERROR: sx_server.exe not found." >&2
|
||||
exit 1
|
||||
fi
|
||||
|
||||
SUITES=(catalog cart price api promo stack quote ledger order recon federation attribution payment window nettax stock refund integration)
|
||||
|
||||
OUT_JSON="lib/commerce/scoreboard.json"
|
||||
OUT_MD="lib/commerce/scoreboard.md"
|
||||
|
||||
run_suite() {
|
||||
local suite=$1
|
||||
local file="lib/commerce/tests/${suite}.sx"
|
||||
local TMP
|
||||
TMP=$(mktemp)
|
||||
cat > "$TMP" << EPOCHS
|
||||
(epoch 1)
|
||||
(load "spec/stdlib.sx")
|
||||
(load "lib/r7rs.sx")
|
||||
(load "lib/guest/match.sx")
|
||||
(load "lib/minikanren/unify.sx")
|
||||
(load "lib/minikanren/stream.sx")
|
||||
(load "lib/minikanren/goals.sx")
|
||||
(load "lib/minikanren/fresh.sx")
|
||||
(load "lib/minikanren/conde.sx")
|
||||
(load "lib/minikanren/run.sx")
|
||||
(load "lib/minikanren/relations.sx")
|
||||
(load "lib/minikanren/project.sx")
|
||||
(load "lib/minikanren/intarith.sx")
|
||||
(load "lib/minikanren/matche.sx")
|
||||
(load "lib/minikanren/defrel.sx")
|
||||
(load "lib/persist/event.sx")
|
||||
(load "lib/persist/backend.sx")
|
||||
(load "lib/persist/log.sx")
|
||||
(load "lib/persist/kv.sx")
|
||||
(load "lib/persist/idempotency.sx")
|
||||
(load "lib/guest/lex.sx")
|
||||
(load "lib/guest/reflective/env.sx")
|
||||
(load "lib/guest/reflective/quoting.sx")
|
||||
(load "lib/scheme/parser.sx")
|
||||
(load "lib/scheme/eval.sx")
|
||||
(load "lib/scheme/runtime.sx")
|
||||
(load "lib/flow/spec.sx")
|
||||
(load "lib/flow/store.sx")
|
||||
(load "lib/flow/remote.sx")
|
||||
(load "lib/flow/host.sx")
|
||||
(load "lib/flow/api.sx")
|
||||
(load "lib/commerce/catalog.sx")
|
||||
(load "lib/commerce/cart.sx")
|
||||
(load "lib/commerce/price.sx")
|
||||
(load "lib/commerce/api.sx")
|
||||
(load "lib/commerce/promo.sx")
|
||||
(load "lib/commerce/stack.sx")
|
||||
(load "lib/commerce/quote.sx")
|
||||
(load "lib/commerce/window.sx")
|
||||
(load "lib/commerce/nettax.sx")
|
||||
(load "lib/commerce/stock.sx")
|
||||
(load "lib/commerce/ledger.sx")
|
||||
(load "lib/commerce/order.sx")
|
||||
(load "lib/commerce/refund.sx")
|
||||
(load "lib/commerce/payment.sx")
|
||||
(load "lib/commerce/recon.sx")
|
||||
(load "lib/commerce/federation.sx")
|
||||
(load "lib/commerce/attribution.sx")
|
||||
(epoch 2)
|
||||
(eval "(define ct-pass 0)")
|
||||
(eval "(define ct-fail 0)")
|
||||
(eval "(define ct-fails (list))")
|
||||
(eval "(define commerce-test (fn (name got expected) (if (= got expected) (set! ct-pass (+ ct-pass 1)) (begin (set! ct-fail (+ ct-fail 1)) (append! ct-fails name)))))")
|
||||
(epoch 3)
|
||||
(load "${file}")
|
||||
(epoch 4)
|
||||
(eval "(list ct-pass ct-fail)")
|
||||
(eval "ct-fails")
|
||||
EPOCHS
|
||||
|
||||
local OUTPUT
|
||||
OUTPUT=$(timeout 560 "$SX_SERVER" < "$TMP" 2>/dev/null)
|
||||
rm -f "$TMP"
|
||||
|
||||
# The (list ct-pass ct-fail) result follows its (ok-len 2 N) ack line.
|
||||
local LINE
|
||||
LINE=$(echo "$OUTPUT" | grep -oE '^\([0-9]+ [0-9]+\)$' | tail -1)
|
||||
local P F
|
||||
P=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\)$/\1/')
|
||||
F=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\)$/\2/')
|
||||
P=${P:-0}
|
||||
F=${F:-0}
|
||||
echo "${P} ${F}"
|
||||
}
|
||||
|
||||
declare -A SUITE_PASS
|
||||
declare -A SUITE_FAIL
|
||||
TOTAL_PASS=0
|
||||
TOTAL_FAIL=0
|
||||
|
||||
echo "Running commerce conformance suite..." >&2
|
||||
for s in "${SUITES[@]}"; do
|
||||
read -r p f < <(run_suite "$s")
|
||||
SUITE_PASS[$s]=$p
|
||||
SUITE_FAIL[$s]=$f
|
||||
TOTAL_PASS=$((TOTAL_PASS + p))
|
||||
TOTAL_FAIL=$((TOTAL_FAIL + f))
|
||||
printf " %-12s %d/%d\n" "$s" "$p" "$((p+f))" >&2
|
||||
done
|
||||
|
||||
{
|
||||
printf '{\n'
|
||||
printf ' "suites": {\n'
|
||||
first=1
|
||||
for s in "${SUITES[@]}"; do
|
||||
if [ $first -eq 0 ]; then printf ',\n'; fi
|
||||
printf ' "%s": {"pass": %d, "fail": %d}' "$s" "${SUITE_PASS[$s]}" "${SUITE_FAIL[$s]}"
|
||||
first=0
|
||||
done
|
||||
printf '\n },\n'
|
||||
printf ' "total_pass": %d,\n' "$TOTAL_PASS"
|
||||
printf ' "total_fail": %d,\n' "$TOTAL_FAIL"
|
||||
printf ' "total": %d\n' "$((TOTAL_PASS + TOTAL_FAIL))"
|
||||
printf '}\n'
|
||||
} > "$OUT_JSON"
|
||||
|
||||
{
|
||||
printf '# commerce Conformance Scoreboard\n\n'
|
||||
printf '_Generated by `lib/commerce/conformance.sh`_\n\n'
|
||||
printf '| Suite | Pass | Fail | Total |\n'
|
||||
printf '|-------|-----:|-----:|------:|\n'
|
||||
for s in "${SUITES[@]}"; do
|
||||
p=${SUITE_PASS[$s]}
|
||||
f=${SUITE_FAIL[$s]}
|
||||
printf '| %s | %d | %d | %d |\n' "$s" "$p" "$f" "$((p+f))"
|
||||
done
|
||||
printf '| **Total** | **%d** | **%d** | **%d** |\n' "$TOTAL_PASS" "$TOTAL_FAIL" "$((TOTAL_PASS + TOTAL_FAIL))"
|
||||
} > "$OUT_MD"
|
||||
|
||||
echo "Wrote $OUT_JSON and $OUT_MD" >&2
|
||||
echo "Total: $TOTAL_PASS pass, $TOTAL_FAIL fail" >&2
|
||||
|
||||
[ "$TOTAL_FAIL" -eq 0 ]
|
||||
@@ -1,86 +0,0 @@
|
||||
;; lib/commerce/federation.sx — cross-instance catalog (federated marketplace).
|
||||
;;
|
||||
;; STUB: instances are registered in-process; there is no real network or
|
||||
;; ActivityPub transport here (that lives in the federation service). The point
|
||||
;; is the relational model: a federated catalog is just the UNION of each
|
||||
;; instance's product facts, tagged with origin, so the same miniKanren
|
||||
;; relations answer cross-instance questions — "which instances sell this sku?",
|
||||
;; "which is cheapest?" — as backward queries, no new query engine.
|
||||
|
||||
(define federation-stub? true)
|
||||
|
||||
(define make-federation (fn (instance cat) {:instances (list (list instance cat))}))
|
||||
|
||||
(define
|
||||
federation-add
|
||||
(fn
|
||||
(fed instance cat)
|
||||
(assoc
|
||||
fed
|
||||
:instances (append (get fed :instances) (list (list instance cat))))))
|
||||
|
||||
(define federation-instances (fn (fed) (map first (get fed :instances))))
|
||||
|
||||
;; Flatten to (instance sku price class) origin-tagged tuples.
|
||||
(define
|
||||
fed-products
|
||||
(fn
|
||||
(fed)
|
||||
(reduce
|
||||
(fn
|
||||
(acc pair)
|
||||
(let
|
||||
((instance (first pair)) (cat (nth pair 1)))
|
||||
(append
|
||||
acc
|
||||
(map (fn (p) (cons instance p)) (get cat :products)))))
|
||||
(list)
|
||||
(get fed :instances))))
|
||||
|
||||
;; --- relations over the federated catalog (multidirectional) ---
|
||||
|
||||
(define
|
||||
fed-producto
|
||||
(fn
|
||||
(fed instance sku price class)
|
||||
(membero (list instance sku price class) (fed-products fed))))
|
||||
|
||||
(define
|
||||
fed-priceo
|
||||
(fn
|
||||
(fed instance sku price)
|
||||
(fresh (c) (fed-producto fed instance sku price c))))
|
||||
|
||||
;; --- query helpers ---
|
||||
|
||||
;; Which instances carry a sku? (backward query)
|
||||
(define
|
||||
instances-with-sku
|
||||
(fn (fed sku) (run* inst (fresh (p c) (fed-producto fed inst sku p c)))))
|
||||
|
||||
;; All (price instance) offers for a sku, in federation order.
|
||||
(define
|
||||
sku-offers
|
||||
(fn
|
||||
(fed sku)
|
||||
(run*
|
||||
pair
|
||||
(fresh
|
||||
(inst p c)
|
||||
(fed-producto fed inst sku p c)
|
||||
(== pair (list p inst))))))
|
||||
|
||||
;; Cheapest (price instance) for a sku — the deterministic selection layer.
|
||||
(define
|
||||
cheapest-offer
|
||||
(fn
|
||||
(fed sku)
|
||||
(let
|
||||
((offers (sku-offers fed sku)))
|
||||
(if
|
||||
(empty? offers)
|
||||
nil
|
||||
(reduce
|
||||
(fn (best x) (if (< (first x) (first best)) x best))
|
||||
(first offers)
|
||||
offers)))))
|
||||
@@ -1,176 +0,0 @@
|
||||
;; lib/commerce/ledger.sx — the order ledger as a persist event stream.
|
||||
;;
|
||||
;; Each order is an append-only stream "order/<id>" in a persist backend.
|
||||
;; Order state is never stored directly — it is a projection (fold) over the
|
||||
;; events, so the ledger is the single source of truth and replays identically.
|
||||
;;
|
||||
;; Lifecycle events:
|
||||
;; :created quote snapshot {:subtotal :discount :tax :total :codes ...}
|
||||
;; :reserved stock reserved
|
||||
;; :paid {:amount :ref} — recorded idempotently on the payment ref
|
||||
;; :fulfilled order shipped/delivered
|
||||
;; :cancelled / :refunded
|
||||
;;
|
||||
;; Idempotency: the SumUp webhook can fire twice for one payment. order-pay
|
||||
;; uses persist/append-once keyed by the payment ref, so a replayed webhook
|
||||
;; yields the SAME :paid event without double-recording. Reconciliation then
|
||||
;; detects genuine mismatches (paid != ordered) across the whole ledger.
|
||||
|
||||
(define order-stream (fn (order-id) (str "order/" order-id)))
|
||||
|
||||
;; --- writes ---
|
||||
|
||||
(define
|
||||
order-create
|
||||
(fn
|
||||
(b order-id at quote)
|
||||
(persist/append b (order-stream order-id) :created at quote)))
|
||||
|
||||
(define
|
||||
order-reserve
|
||||
(fn
|
||||
(b order-id at data)
|
||||
(persist/append b (order-stream order-id) :reserved at data)))
|
||||
|
||||
;; Idempotent on payment ref — a replayed webhook does not double-record.
|
||||
(define
|
||||
order-pay
|
||||
(fn
|
||||
(b order-id ref at amount)
|
||||
(persist/append-once b (order-stream order-id) ref :paid at {:amount amount :ref ref})))
|
||||
|
||||
(define
|
||||
order-fulfil
|
||||
(fn
|
||||
(b order-id at data)
|
||||
(persist/append b (order-stream order-id) :fulfilled at data)))
|
||||
|
||||
(define
|
||||
order-cancel
|
||||
(fn
|
||||
(b order-id at reason)
|
||||
(persist/append b (order-stream order-id) :cancelled at {:reason reason})))
|
||||
|
||||
(define
|
||||
order-refund
|
||||
(fn
|
||||
(b order-id ref at amount)
|
||||
(persist/append-once
|
||||
b
|
||||
(order-stream order-id)
|
||||
(str "refund/" ref)
|
||||
:refunded at
|
||||
{:amount amount :ref ref})))
|
||||
|
||||
;; --- reads ---
|
||||
|
||||
(define
|
||||
order-events
|
||||
(fn (b order-id) (persist/read b (order-stream order-id))))
|
||||
|
||||
;; --- projections over an event list ---
|
||||
|
||||
(define
|
||||
order-status-of
|
||||
(fn
|
||||
(events)
|
||||
(reduce
|
||||
(fn
|
||||
(st e)
|
||||
(let
|
||||
((t (persist/event-type e)))
|
||||
(cond
|
||||
((= t :created) :pending)
|
||||
((= t :reserved) :reserved)
|
||||
((= t :paid) :paid)
|
||||
((= t :fulfilled) :fulfilled)
|
||||
((= t :cancelled) :cancelled)
|
||||
((= t :refunded) :refunded)
|
||||
(:else st))))
|
||||
:new events)))
|
||||
|
||||
(define
|
||||
order-total-of
|
||||
(fn
|
||||
(events)
|
||||
(let
|
||||
((created (filter (fn (e) (= (persist/event-type e) :created)) events)))
|
||||
(if
|
||||
(empty? created)
|
||||
0
|
||||
(get (persist/event-data (first created)) :total)))))
|
||||
|
||||
(define
|
||||
order-paid-amount-of
|
||||
(fn
|
||||
(events)
|
||||
(reduce
|
||||
(fn
|
||||
(acc e)
|
||||
(if
|
||||
(= (persist/event-type e) :paid)
|
||||
(+ acc (get (persist/event-data e) :amount))
|
||||
acc))
|
||||
0
|
||||
events)))
|
||||
|
||||
(define
|
||||
order-refunded-amount-of
|
||||
(fn
|
||||
(events)
|
||||
(reduce
|
||||
(fn
|
||||
(acc e)
|
||||
(if
|
||||
(= (persist/event-type e) :refunded)
|
||||
(+ acc (get (persist/event-data e) :amount))
|
||||
acc))
|
||||
0
|
||||
events)))
|
||||
|
||||
;; Net settled = paid - refunded. Reconciliation compares this to the order
|
||||
;; total, but only once a payment exists.
|
||||
(define
|
||||
order-recon-of
|
||||
(fn
|
||||
(events)
|
||||
(let
|
||||
((net (- (order-paid-amount-of events) (order-refunded-amount-of events)))
|
||||
(total (order-total-of events))
|
||||
(has-paid (some (fn (e) (= (persist/event-type e) :paid)) events)))
|
||||
(cond
|
||||
((not has-paid) :unpaid)
|
||||
((= net total) :ok)
|
||||
((< net total) :underpaid)
|
||||
(:else :overpaid)))))
|
||||
|
||||
;; --- backend-level helpers ---
|
||||
|
||||
(define
|
||||
order-status
|
||||
(fn (b order-id) (order-status-of (order-events b order-id))))
|
||||
(define
|
||||
order-total
|
||||
(fn (b order-id) (order-total-of (order-events b order-id))))
|
||||
(define
|
||||
order-paid
|
||||
(fn (b order-id) (order-paid-amount-of (order-events b order-id))))
|
||||
(define
|
||||
order-recon
|
||||
(fn (b order-id) (order-recon-of (order-events b order-id))))
|
||||
|
||||
(define order-ids (fn (b) (persist/backend-streams b)))
|
||||
|
||||
;; Streams whose net payment does not match the order total (true mismatches,
|
||||
;; excluding orders that are simply not yet paid).
|
||||
(define
|
||||
ledger-mismatches
|
||||
(fn
|
||||
(b)
|
||||
(filter
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((r (order-recon-of (persist/read b s))))
|
||||
(or (= r :underpaid) (= r :overpaid))))
|
||||
(persist/backend-streams b))))
|
||||
@@ -1,80 +0,0 @@
|
||||
;; lib/commerce/nettax.sx — discount-aware tax (alternative policy).
|
||||
;;
|
||||
;; price.sx / quote.sx tax the GROSS per-line amounts (discount reduces payable
|
||||
;; but not the tax base). This module is the alternative explicit policy: tax the
|
||||
;; NET (post-discount) base. The basket-level discount is allocated across lines
|
||||
;; in proportion to each line's extended price, with a deterministic
|
||||
;; largest-remainder pass so per-line shares sum EXACTLY to the discount; tax is
|
||||
;; then charged on each line's net at its class rate.
|
||||
;;
|
||||
;; Both policies are reproducible from (ctx, cart, ruleset, exclusions); pick the
|
||||
;; one the jurisdiction requires. cart-quote-net mirrors cart-quote's shape.
|
||||
|
||||
(define ct-sum (fn (xs) (reduce (fn (a x) (+ a x)) 0 xs)))
|
||||
|
||||
;; Add 1 to the first `rem` elements (deterministic remainder distribution).
|
||||
(define
|
||||
ct-add-rem
|
||||
(fn
|
||||
(xs rem)
|
||||
(cond
|
||||
((empty? xs) (list))
|
||||
((> rem 0)
|
||||
(cons
|
||||
(+ (first xs) 1)
|
||||
(ct-add-rem (rest xs) (- rem 1))))
|
||||
(:else xs))))
|
||||
|
||||
;; Per-line discount allocation (parallel to cart), summing exactly to
|
||||
;; total-discount, proportional to line-extended share.
|
||||
(define
|
||||
allocate-discount
|
||||
(fn
|
||||
(cat cart total-discount)
|
||||
(let
|
||||
((sub (cart-subtotal cat cart)))
|
||||
(if
|
||||
(= sub 0)
|
||||
(map (fn (l) 0) cart)
|
||||
(let
|
||||
((floors (map (fn (l) (quotient (* total-discount (line-extended cat l)) sub)) cart)))
|
||||
(ct-add-rem floors (- total-discount (ct-sum floors))))))))
|
||||
|
||||
;; Tax on one line's net (extended - allocated discount), clamped at 0.
|
||||
(define
|
||||
net-line-tax
|
||||
(fn
|
||||
(ctx line alloc)
|
||||
(let
|
||||
((cat (ctx-catalog ctx)))
|
||||
(let
|
||||
((net (- (line-extended cat line) alloc)))
|
||||
(apply-bps
|
||||
(if (< net 0) 0 net)
|
||||
(rate-bps
|
||||
(get ctx :tax-rules)
|
||||
(get ctx :jurisdiction)
|
||||
(catalog-class cat (line-sku line))
|
||||
(get ctx :customer)))))))
|
||||
|
||||
(define
|
||||
net-tax
|
||||
(fn
|
||||
(ctx cart allocations)
|
||||
(ct-sum
|
||||
(map (fn (line alloc) (net-line-tax ctx line alloc)) cart allocations))))
|
||||
|
||||
;; Discount-aware quote: tax computed on the net (post-discount) base.
|
||||
(define
|
||||
cart-quote-net
|
||||
(fn
|
||||
(ctx cart ruleset exclusions)
|
||||
(let
|
||||
((cat (ctx-catalog ctx)))
|
||||
(let
|
||||
((sub (cart-subtotal cat cart))
|
||||
(disc (best-promo-discount ctx cart ruleset exclusions))
|
||||
(codes (best-promo-codes ctx cart ruleset exclusions)))
|
||||
(let
|
||||
((tax (net-tax ctx cart (allocate-discount cat cart disc))))
|
||||
{:codes codes :subtotal sub :discount disc :total (+ (- sub disc) tax) :tax tax})))))
|
||||
@@ -1,119 +0,0 @@
|
||||
;; lib/commerce/order.sx — order lifecycle as a durable flow-on-sx flow.
|
||||
;;
|
||||
;; The lifecycle (reserve -> await payment -> fulfil) is a Scheme flow running
|
||||
;; in the flow-on-sx guest (lib/flow). The flow is PURE ORCHESTRATION: it
|
||||
;; carries only the order-id and enforces step ordering + the suspension at the
|
||||
;; payment IO boundary. All IO/state lives in SX: the SX driver here services
|
||||
;; each flow request by appending to the persist ledger (ledger.sx).
|
||||
;;
|
||||
;; reserve -> SX appends :reserved, resumes (synchronous host effect)
|
||||
;; payment -> flow stays SUSPENDED until the SumUp webhook resumes it
|
||||
;; fulfil -> SX appends :fulfilled, resumes (synchronous host effect)
|
||||
;;
|
||||
;; Durability: the flow's replay log is plain data (flow-store-export), so a
|
||||
;; suspended order survives a process restart — order-flow-restart! simulates
|
||||
;; that entirely Scheme-side. Idempotency: order-settle! only resumes a flow
|
||||
;; still waiting on payment, so a replayed webhook is a no-op at the flow level,
|
||||
;; and order-pay is idempotent at the ledger level.
|
||||
|
||||
;; The flow definition (Scheme source). oid is in scope throughout the begin.
|
||||
(define
|
||||
order-flow-src
|
||||
"(defflow order-lifecycle (lambda (oid) (begin (request (quote reserve) oid) (request (quote payment) oid) (request (quote fulfil) oid))))")
|
||||
|
||||
;; Build a flow env with the order flow registered. Never returns the env from
|
||||
;; an eval boundary (the env is large/cyclic — serializing it hangs).
|
||||
(define
|
||||
order-make-env
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((env (flow-make-env)))
|
||||
(begin (flow-run-in env order-flow-src) env))))
|
||||
|
||||
;; --- thin Scheme bridge (string-interpolated flow ops) ---
|
||||
|
||||
(define
|
||||
order-flow-start
|
||||
(fn
|
||||
(env oid)
|
||||
(flow-run-in env (str "(flow/start order-lifecycle \"" oid "\")"))))
|
||||
|
||||
(define
|
||||
order-flow-resume
|
||||
(fn
|
||||
(env id sym)
|
||||
(flow-run-in env (str "(flow/resume " id " (quote " sym "))"))))
|
||||
|
||||
(define
|
||||
order-flow-status
|
||||
(fn (env id) (flow-run-in env (str "(flow/status " id ")"))))
|
||||
(define
|
||||
order-flow-result
|
||||
(fn (env id) (flow-run-in env (str "(flow/result " id ")"))))
|
||||
|
||||
;; The request kind the flow with this id is waiting on, or nil if it is not
|
||||
;; suspended on a host request (done / cancelled / unknown).
|
||||
(define
|
||||
order-flow-waiting
|
||||
(fn
|
||||
(env id)
|
||||
(let
|
||||
((reqs (flow-run-in env "(flow-host-requests)")))
|
||||
(let
|
||||
((mine (filter (fn (r) (= (first r) id)) reqs)))
|
||||
(if (empty? mine) nil (nth (first mine) 1))))))
|
||||
|
||||
;; Id out of a (flow-suspended id tag) start/resume result.
|
||||
(define order-susp-id (fn (susp) (nth susp 1)))
|
||||
|
||||
;; --- high-level lifecycle (flow + ledger composed) ---
|
||||
|
||||
;; Create the order, start the flow, service the reserve step, and leave the
|
||||
;; flow suspended at payment. Returns the flow id (needed to settle later).
|
||||
(define
|
||||
order-begin!
|
||||
(fn
|
||||
(env b oid at quote)
|
||||
(begin
|
||||
(order-create b oid at quote)
|
||||
(let
|
||||
((id (order-susp-id (order-flow-start env oid))))
|
||||
(begin
|
||||
(order-reserve b oid (+ at 1) {})
|
||||
(order-flow-resume env id :reserved)
|
||||
id)))))
|
||||
|
||||
;; Settle a payment: record it, resume the flow past payment, service fulfil.
|
||||
;; Idempotent — only acts when the flow is still waiting on payment, so a
|
||||
;; replayed webhook returns :already-settled without double-charging.
|
||||
(define
|
||||
order-settle!
|
||||
(fn
|
||||
(env b id oid ref at amount)
|
||||
(if
|
||||
(= (order-flow-waiting env id) "payment")
|
||||
(begin
|
||||
(order-pay b oid ref at amount)
|
||||
(order-flow-resume env id :paid)
|
||||
(order-fulfil b oid (+ at 1) {})
|
||||
(order-flow-resume env id :fulfilled)
|
||||
:settled)
|
||||
:already-settled)))
|
||||
|
||||
;; Simulate a process restart: export the flow store, reset the runtime, reload
|
||||
;; the flow definition, reimport the store. Done entirely Scheme-side so the
|
||||
;; (large) store is never marshalled across the boundary. The persist ledger is
|
||||
;; a separate store and is unaffected. Suspended flows resume afterwards.
|
||||
(define
|
||||
order-flow-restart!
|
||||
(fn
|
||||
(env)
|
||||
(flow-run-in
|
||||
env
|
||||
(str
|
||||
"(begin (define _saved (flow-store-export)) "
|
||||
flow-reset-src
|
||||
" "
|
||||
order-flow-src
|
||||
" (flow-store-import! _saved) #t)"))))
|
||||
@@ -1,41 +0,0 @@
|
||||
;; lib/commerce/payment.sx — provider-neutral payment-request envelope.
|
||||
;;
|
||||
;; The order flow (order.sx) suspends on `(request 'payment oid)` — it carries
|
||||
;; ONLY the order-id and calls no provider. This layer materialises, at the IO
|
||||
;; edge, the envelope a provider adapter needs to initiate payment:
|
||||
;;
|
||||
;; {:order oid :amount <ledger total> :currency C :return-url U}
|
||||
;;
|
||||
;; amount comes from the ledger (the :created quote total); currency + return-url
|
||||
;; are host/provider config (legitimately host-supplied). The engine stays
|
||||
;; vendor-agnostic: SumUp/Stripe/etc. adapters consume this envelope, and
|
||||
;; order-settle!(ref, amount) is the vendor-neutral resume seam. No provider
|
||||
;; SDK, HTTP, or webhook parsing lives here — that is the orders service's job.
|
||||
|
||||
(define payment-request (fn (b oid currency return-url) {:order oid :amount (order-total b oid) :return-url return-url :currency currency}))
|
||||
|
||||
(define payment-request-order (fn (pr) (get pr :order)))
|
||||
(define payment-request-amount (fn (pr) (get pr :amount)))
|
||||
(define payment-request-currency (fn (pr) (get pr :currency)))
|
||||
(define payment-request-return-url (fn (pr) (get pr :return-url)))
|
||||
|
||||
;; A Scheme string carried as a flow payload round-trips back to SX wrapped as
|
||||
;; {:scm-string "..."}; unwrap it to the bare order-id.
|
||||
(define
|
||||
scm->string
|
||||
(fn
|
||||
(v)
|
||||
(if (and (dict? v) (has-key? v :scm-string)) (get v :scm-string) v)))
|
||||
|
||||
;; Host poller seam: every order currently suspended awaiting payment, each with
|
||||
;; its envelope. A provider adapter iterates these, initiates payment, and later
|
||||
;; calls order-settle! when the webhook arrives. Needs the flow env.
|
||||
(define
|
||||
pending-payments
|
||||
(fn
|
||||
(env b currency return-url)
|
||||
(let
|
||||
((reqs (flow-run-in env "(flow-host-requests)")))
|
||||
(map
|
||||
(fn (r) {:id (first r) :request (payment-request b (scm->string (nth r 2)) currency return-url)})
|
||||
(filter (fn (r) (= (nth r 1) "payment")) reqs)))))
|
||||
@@ -1,110 +0,0 @@
|
||||
;; lib/commerce/price.sx — deterministic subtotal + jurisdiction-relational tax.
|
||||
;;
|
||||
;; A pricing context bundles the inputs that make a total reproducible:
|
||||
;; {:catalog CAT :tax-rules RULES :jurisdiction J :customer C}
|
||||
;; Same context + same cart => identical total, every run.
|
||||
;;
|
||||
;; Tax is NOT a hardcoded VAT rate. Rules are facts indexed by
|
||||
;; (jurisdiction, product-class, customer-class) -> rate-bps
|
||||
;; where rate-bps is an integer in basis points (2000 = 20%). taxo queries
|
||||
;; them multidirectionally. Money stays in integer minor units; rounding is
|
||||
;; half-up per line via integer arithmetic only — never floats.
|
||||
|
||||
(define
|
||||
make-pricing-context
|
||||
(fn (catalog tax-rules jurisdiction customer) {:customer customer :jurisdiction jurisdiction :catalog catalog :tax-rules tax-rules}))
|
||||
|
||||
(define ctx-catalog (fn (ctx) (get ctx :catalog)))
|
||||
|
||||
;; --- unit + line pricing ---
|
||||
|
||||
;; Variant delta, defaulting to 0 when the (sku,variant) has no variant fact.
|
||||
(define
|
||||
variant-delta
|
||||
(fn
|
||||
(cat sku variant)
|
||||
(let
|
||||
((rs (run 1 d (varianto cat sku variant d))))
|
||||
(if (empty? rs) 0 (first rs)))))
|
||||
|
||||
;; Effective unit price = base price + variant delta. nil if sku unknown.
|
||||
(define
|
||||
line-unit-price
|
||||
(fn
|
||||
(cat sku variant)
|
||||
(let
|
||||
((base (catalog-price cat sku)))
|
||||
(if (nil? base) nil (+ base (variant-delta cat sku variant))))))
|
||||
|
||||
;; Extended (line) price = unit price * quantity.
|
||||
(define
|
||||
line-extended
|
||||
(fn
|
||||
(cat line)
|
||||
(*
|
||||
(line-unit-price cat (line-sku line) (line-variant line))
|
||||
(line-qty line))))
|
||||
|
||||
(define
|
||||
cart-subtotal
|
||||
(fn
|
||||
(cat cart)
|
||||
(reduce (fn (acc l) (+ acc (line-extended cat l))) 0 cart)))
|
||||
|
||||
;; --- tax (jurisdiction-relational) ---
|
||||
|
||||
;; rules: (list (list jurisdiction class customer bps) ...)
|
||||
(define
|
||||
taxo
|
||||
(fn
|
||||
(rules juris class cust bps)
|
||||
(membero (list juris class cust bps) rules)))
|
||||
|
||||
;; Deterministic rate lookup; 0 when no rule matches.
|
||||
(define
|
||||
rate-bps
|
||||
(fn
|
||||
(rules juris class cust)
|
||||
(let
|
||||
((rs (run 1 b (taxo rules juris class cust b))))
|
||||
(if (empty? rs) 0 (first rs)))))
|
||||
|
||||
;; Apply a basis-point rate to an integer amount, rounding half up.
|
||||
(define
|
||||
apply-bps
|
||||
(fn (amount bps) (quotient (+ (* amount bps) 5000) 10000)))
|
||||
|
||||
(define
|
||||
line-tax
|
||||
(fn
|
||||
(ctx line)
|
||||
(let
|
||||
((cat (ctx-catalog ctx)))
|
||||
(let
|
||||
((class (catalog-class cat (line-sku line))))
|
||||
(apply-bps
|
||||
(line-extended cat line)
|
||||
(rate-bps
|
||||
(get ctx :tax-rules)
|
||||
(get ctx :jurisdiction)
|
||||
class
|
||||
(get ctx :customer)))))))
|
||||
|
||||
(define
|
||||
cart-tax
|
||||
(fn
|
||||
(ctx cart)
|
||||
(reduce (fn (acc l) (+ acc (line-tax ctx l))) 0 cart)))
|
||||
|
||||
;; --- total ---
|
||||
|
||||
;; Returns {:subtotal :discounts :tax :total}. discounts is 0 until Phase 2.
|
||||
(define
|
||||
cart-total
|
||||
(fn
|
||||
(ctx cart)
|
||||
(let
|
||||
((cat (ctx-catalog ctx)))
|
||||
(let
|
||||
((sub (cart-subtotal cat cart)) (tax (cart-tax ctx cart)))
|
||||
{:subtotal sub :discounts 0 :total (+ sub tax) :tax tax}))))
|
||||
@@ -1,153 +0,0 @@
|
||||
;; lib/commerce/promo.sx — promotions as relations over the cart + catalog.
|
||||
;;
|
||||
;; A promo is a tagged tuple; the second field is always its code:
|
||||
;; (:percent code class pct-bps) pct-bps off every line of product-class
|
||||
;; (:fixed code threshold amount) amount off when subtotal >= threshold
|
||||
;; (:bundle code sku n) every nth unit of sku is free
|
||||
;; (:member code class pct-bps) like :percent, members only
|
||||
;;
|
||||
;; A ruleset is a list of promo tuples. The discount a promo yields on a
|
||||
;; given cart is a pure integer computation (minor units); the *enumeration*
|
||||
;; of which promos apply is relational, so promo-applieso runs forward
|
||||
;; ("which codes apply and for how much?") and backward ("which code yields
|
||||
;; this discount?"). Stacking precedence is a separate layer (stack.sx).
|
||||
|
||||
(define promo-kind (fn (p) (nth p 0)))
|
||||
(define promo-code (fn (p) (nth p 1)))
|
||||
|
||||
;; Extended price of all lines whose sku is in product-class `class`.
|
||||
(define
|
||||
class-extended
|
||||
(fn
|
||||
(ctx cart class)
|
||||
(let
|
||||
((cat (ctx-catalog ctx)))
|
||||
(reduce
|
||||
(fn
|
||||
(acc l)
|
||||
(if
|
||||
(= (catalog-class cat (line-sku l)) class)
|
||||
(+ acc (line-extended cat l))
|
||||
acc))
|
||||
0
|
||||
cart))))
|
||||
|
||||
(define
|
||||
sku-qty
|
||||
(fn
|
||||
(cart sku)
|
||||
(reduce
|
||||
(fn (acc l) (if (= (line-sku l) sku) (+ acc (line-qty l)) acc))
|
||||
0
|
||||
cart)))
|
||||
|
||||
;; --- per-type discount amounts (pure, integer minor units) ---
|
||||
|
||||
(define
|
||||
percent-amount
|
||||
(fn
|
||||
(ctx cart p)
|
||||
(apply-bps
|
||||
(class-extended ctx cart (nth p 2))
|
||||
(nth p 3))))
|
||||
|
||||
(define
|
||||
fixed-amount
|
||||
(fn
|
||||
(ctx cart p)
|
||||
(let
|
||||
((sub (cart-subtotal (ctx-catalog ctx) cart)))
|
||||
(if
|
||||
(>= sub (nth p 2))
|
||||
(min (nth p 3) sub)
|
||||
0))))
|
||||
|
||||
(define
|
||||
bundle-amount
|
||||
(fn
|
||||
(ctx cart p)
|
||||
(let
|
||||
((sku (nth p 2)) (n (nth p 3)))
|
||||
(let
|
||||
((free (quotient (sku-qty cart sku) n)))
|
||||
(* free (catalog-price (ctx-catalog ctx) sku))))))
|
||||
|
||||
(define
|
||||
member-amount
|
||||
(fn
|
||||
(ctx cart p)
|
||||
(if
|
||||
(= (get ctx :customer) :member)
|
||||
(apply-bps
|
||||
(class-extended ctx cart (nth p 2))
|
||||
(nth p 3))
|
||||
0)))
|
||||
|
||||
;; Discount this promo yields on this cart (0 if it does not apply).
|
||||
(define
|
||||
promo-amount
|
||||
(fn
|
||||
(ctx cart p)
|
||||
(let
|
||||
((k (promo-kind p)))
|
||||
(cond
|
||||
((= k :percent) (percent-amount ctx cart p))
|
||||
((= k :fixed) (fixed-amount ctx cart p))
|
||||
((= k :bundle) (bundle-amount ctx cart p))
|
||||
((= k :member) (member-amount ctx cart p))
|
||||
(:else 0)))))
|
||||
|
||||
;; --- relational enumeration ---
|
||||
|
||||
;; (code, amount) for every promo in the ruleset (amount may be 0).
|
||||
(define
|
||||
promo-discounto
|
||||
(fn
|
||||
(ctx cart ruleset code amount)
|
||||
(fresh
|
||||
(p)
|
||||
(membero p ruleset)
|
||||
(project
|
||||
(p)
|
||||
(== code (promo-code p))
|
||||
(== amount (promo-amount ctx cart p))))))
|
||||
|
||||
;; (code, amount) restricted to promos that actually apply (amount > 0).
|
||||
(define
|
||||
promo-applieso
|
||||
(fn
|
||||
(ctx cart ruleset code amount)
|
||||
(fresh
|
||||
(p)
|
||||
(membero p ruleset)
|
||||
(project
|
||||
(p)
|
||||
(if
|
||||
(> (promo-amount ctx cart p) 0)
|
||||
(mk-conj
|
||||
(== code (promo-code p))
|
||||
(== amount (promo-amount ctx cart p)))
|
||||
fail)))))
|
||||
|
||||
;; --- deterministic helpers ---
|
||||
|
||||
;; List of (list code amount) for applicable promos, in ruleset order.
|
||||
(define
|
||||
applicable-promos
|
||||
(fn
|
||||
(ctx cart ruleset)
|
||||
(run*
|
||||
pair
|
||||
(fresh
|
||||
(code amount)
|
||||
(promo-applieso ctx cart ruleset code amount)
|
||||
(== pair (list code amount))))))
|
||||
|
||||
;; Discount for one code (0 if absent / inapplicable).
|
||||
(define
|
||||
promo-amount-for
|
||||
(fn
|
||||
(ctx cart ruleset code)
|
||||
(let
|
||||
((rs (run 1 a (promo-applieso ctx cart ruleset code a))))
|
||||
(if (empty? rs) 0 (first rs)))))
|
||||
@@ -1,36 +0,0 @@
|
||||
;; lib/commerce/quote.sx — the final priced quote: price + promo + stacking.
|
||||
;;
|
||||
;; A quote is the deterministic composition of the pricing pipeline for a
|
||||
;; (context, cart, ruleset, exclusions) tuple:
|
||||
;; {:subtotal S :discount D :tax T :total (S - D + T) :codes (...)}
|
||||
;;
|
||||
;; Tax policy (explicit, for the determinism contract): tax is computed on the
|
||||
;; GROSS per-line amounts (pre-discount), via price.sx cart-tax. The best
|
||||
;; promo stacking reduces the payable total but not the tax base. Same inputs
|
||||
;; always yield the same quote — this is the value the order flow carries.
|
||||
|
||||
(define
|
||||
cart-quote
|
||||
(fn
|
||||
(ctx cart ruleset exclusions)
|
||||
(let
|
||||
((cat (ctx-catalog ctx)))
|
||||
(let
|
||||
((sub (cart-subtotal cat cart))
|
||||
(disc (best-promo-discount ctx cart ruleset exclusions))
|
||||
(tax (cart-tax ctx cart))
|
||||
(codes (best-promo-codes ctx cart ruleset exclusions)))
|
||||
{:codes codes :subtotal sub :discount disc :total (+ (- sub disc) tax) :tax tax}))))
|
||||
|
||||
(define quote-subtotal (fn (q) (get q :subtotal)))
|
||||
(define quote-discount (fn (q) (get q :discount)))
|
||||
(define quote-tax (fn (q) (get q :tax)))
|
||||
(define quote-total (fn (q) (get q :total)))
|
||||
(define quote-codes (fn (q) (get q :codes)))
|
||||
|
||||
;; Session-level convenience (a session is {:ctx :cart}).
|
||||
(define
|
||||
session-quote
|
||||
(fn
|
||||
(sess ruleset exclusions)
|
||||
(cart-quote (get sess :ctx) (get sess :cart) ruleset exclusions)))
|
||||
@@ -1,100 +0,0 @@
|
||||
;; lib/commerce/recon.sx — reconciliation as relational queries over the ledger.
|
||||
;;
|
||||
;; The ledger (ledger.sx) is the source of truth; reconciliation projects it
|
||||
;; into per-order summary tuples and then asks miniKanren questions about them.
|
||||
;; "Which orders are overpaid?" / "which order settled to net N?" are backward
|
||||
;; queries (run*) over the same relation, not separate code paths.
|
||||
;;
|
||||
;; A summary tuple is positional:
|
||||
;; (order-stream total paid refunded net status)
|
||||
;; net = paid - refunded; status = :unpaid|:ok|:underpaid|:overpaid.
|
||||
|
||||
(define
|
||||
order-summary
|
||||
(fn
|
||||
(b stream)
|
||||
(let
|
||||
((events (persist/read b stream)))
|
||||
(let
|
||||
((total (order-total-of events))
|
||||
(paid (order-paid-amount-of events))
|
||||
(refunded (order-refunded-amount-of events)))
|
||||
(list
|
||||
stream
|
||||
total
|
||||
paid
|
||||
refunded
|
||||
(- paid refunded)
|
||||
(order-recon-of events))))))
|
||||
|
||||
(define
|
||||
ledger-summaries
|
||||
(fn (b) (map (fn (s) (order-summary b s)) (persist/backend-streams b))))
|
||||
|
||||
;; --- relations over the summary set ---
|
||||
|
||||
(define
|
||||
summaryo
|
||||
(fn
|
||||
(summaries id total paid refunded net status)
|
||||
(membero (list id total paid refunded net status) summaries)))
|
||||
|
||||
(define
|
||||
recon-statuso
|
||||
(fn
|
||||
(summaries id status)
|
||||
(fresh (t p r n) (summaryo summaries id t p r n status))))
|
||||
|
||||
(define
|
||||
neto
|
||||
(fn
|
||||
(summaries id net)
|
||||
(fresh (t p r status) (summaryo summaries id t p r net status))))
|
||||
|
||||
;; A mismatch is any order whose money does not reconcile (over or under).
|
||||
(define
|
||||
mismatcho
|
||||
(fn
|
||||
(summaries id)
|
||||
(fresh
|
||||
(status)
|
||||
(recon-statuso summaries id status)
|
||||
(conde ((== status :underpaid)) ((== status :overpaid))))))
|
||||
|
||||
;; --- deterministic query helpers (run* over the live ledger) ---
|
||||
|
||||
(define
|
||||
orders-with-status
|
||||
(fn (b status) (run* id (recon-statuso (ledger-summaries b) id status))))
|
||||
|
||||
(define overpaid-orders (fn (b) (orders-with-status b :overpaid)))
|
||||
(define underpaid-orders (fn (b) (orders-with-status b :underpaid)))
|
||||
(define settled-orders (fn (b) (orders-with-status b :ok)))
|
||||
(define unpaid-orders (fn (b) (orders-with-status b :unpaid)))
|
||||
|
||||
(define
|
||||
mismatched-orders
|
||||
(fn (b) (run* id (mismatcho (ledger-summaries b) id))))
|
||||
|
||||
;; Backward: which order(s) settled to a given net amount?
|
||||
(define
|
||||
orders-with-net
|
||||
(fn (b net) (run* id (neto (ledger-summaries b) id net))))
|
||||
|
||||
;; Total signed discrepancy across the ledger (net - total over paid orders);
|
||||
;; 0 when every settled order reconciles exactly.
|
||||
(define
|
||||
ledger-discrepancy
|
||||
(fn
|
||||
(b)
|
||||
(reduce
|
||||
(fn
|
||||
(acc s)
|
||||
(let
|
||||
((status (nth s 5)))
|
||||
(if
|
||||
(= status :unpaid)
|
||||
acc
|
||||
(+ acc (- (nth s 4) (nth s 1))))))
|
||||
0
|
||||
(ledger-summaries b))))
|
||||
@@ -1,97 +0,0 @@
|
||||
;; lib/commerce/refund.sx — refund lifecycle as a second flow-on-sx flow.
|
||||
;;
|
||||
;; A refund is request → approve → settle, with TWO genuine suspension points:
|
||||
;; approval (a human/policy decision) and settlement (the provider issuing the
|
||||
;; refund). Like order.sx the flow is pure orchestration carrying only the
|
||||
;; order-id; the SX driver does all ledger IO and reuses order.sx's generic flow
|
||||
;; helpers (order-flow-waiting/-resume/-status, order-susp-id).
|
||||
;;
|
||||
;; refund-begin! → ledger :refund-requested, flow suspends at 'approve
|
||||
;; refund-approve! → resume past approval, flow suspends at 'settle
|
||||
;; refund-settle! → ledger :refunded (idempotent), flow completes
|
||||
;; refund-reject! → ledger :refund-rejected, flow cancelled
|
||||
;;
|
||||
;; Only :refunded moves the books (recon.sx), so a requested-but-unsettled or
|
||||
;; rejected refund leaves reconciliation unchanged.
|
||||
|
||||
(define
|
||||
refund-flow-src
|
||||
"(defflow refund-lifecycle (lambda (oid) (begin (request (quote approve) oid) (request (quote settle) oid))))")
|
||||
|
||||
(define
|
||||
refund-make-env
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((env (flow-make-env)))
|
||||
(begin (flow-run-in env refund-flow-src) env))))
|
||||
|
||||
;; Register the refund flow into an existing (e.g. order) env.
|
||||
(define
|
||||
refund-flow-load!
|
||||
(fn (env) (begin (flow-run-in env refund-flow-src) env)))
|
||||
|
||||
(define
|
||||
refund-flow-start
|
||||
(fn
|
||||
(env oid)
|
||||
(flow-run-in env (str "(flow/start refund-lifecycle \"" oid "\")"))))
|
||||
|
||||
;; --- ledger writes ---
|
||||
|
||||
(define
|
||||
refund-request
|
||||
(fn
|
||||
(b oid ref at amount)
|
||||
(persist/append-once
|
||||
b
|
||||
(order-stream oid)
|
||||
(str "refund-req/" ref)
|
||||
:refund-requested at
|
||||
{:amount amount :ref ref})))
|
||||
|
||||
;; --- lifecycle ---
|
||||
|
||||
;; Open a refund: record the request, start the flow, suspend at approval.
|
||||
(define
|
||||
refund-begin!
|
||||
(fn
|
||||
(env b oid ref at amount)
|
||||
(begin
|
||||
(refund-request b oid ref at amount)
|
||||
(order-susp-id (refund-flow-start env oid)))))
|
||||
|
||||
(define
|
||||
refund-approve!
|
||||
(fn
|
||||
(env id)
|
||||
(if
|
||||
(= (order-flow-waiting env id) "approve")
|
||||
(begin (order-flow-resume env id :approved) :approved)
|
||||
:not-pending-approval)))
|
||||
|
||||
(define
|
||||
refund-reject!
|
||||
(fn
|
||||
(env b oid id at reason)
|
||||
(if
|
||||
(= (order-flow-waiting env id) "approve")
|
||||
(begin
|
||||
(persist/append b (order-stream oid) :refund-rejected at {:reason reason})
|
||||
(flow-run-in env (str "(flow/cancel " id ")"))
|
||||
:rejected)
|
||||
:not-pending-approval)))
|
||||
|
||||
;; Settle (provider issued the refund): idempotent — only acts while waiting on
|
||||
;; settle, so a replayed provider callback returns :already-settled.
|
||||
(define
|
||||
refund-settle!
|
||||
(fn
|
||||
(env b id oid ref at amount)
|
||||
(if
|
||||
(= (order-flow-waiting env id) "settle")
|
||||
(begin
|
||||
(order-refund b oid ref at amount)
|
||||
(order-flow-resume env id :settled)
|
||||
:settled)
|
||||
:already-settled)))
|
||||
@@ -1,25 +0,0 @@
|
||||
{
|
||||
"suites": {
|
||||
"catalog": {"pass": 16, "fail": 0},
|
||||
"cart": {"pass": 18, "fail": 0},
|
||||
"price": {"pass": 20, "fail": 0},
|
||||
"api": {"pass": 12, "fail": 0},
|
||||
"promo": {"pass": 17, "fail": 0},
|
||||
"stack": {"pass": 16, "fail": 0},
|
||||
"quote": {"pass": 13, "fail": 0},
|
||||
"ledger": {"pass": 20, "fail": 0},
|
||||
"order": {"pass": 22, "fail": 0},
|
||||
"recon": {"pass": 20, "fail": 0},
|
||||
"federation": {"pass": 12, "fail": 0},
|
||||
"attribution": {"pass": 16, "fail": 0},
|
||||
"payment": {"pass": 7, "fail": 0},
|
||||
"window": {"pass": 19, "fail": 0},
|
||||
"nettax": {"pass": 11, "fail": 0},
|
||||
"stock": {"pass": 19, "fail": 0},
|
||||
"refund": {"pass": 20, "fail": 0},
|
||||
"integration": {"pass": 19, "fail": 0}
|
||||
},
|
||||
"total_pass": 297,
|
||||
"total_fail": 0,
|
||||
"total": 297
|
||||
}
|
||||
@@ -1,25 +0,0 @@
|
||||
# commerce Conformance Scoreboard
|
||||
|
||||
_Generated by `lib/commerce/conformance.sh`_
|
||||
|
||||
| Suite | Pass | Fail | Total |
|
||||
|-------|-----:|-----:|------:|
|
||||
| catalog | 16 | 0 | 16 |
|
||||
| cart | 18 | 0 | 18 |
|
||||
| price | 20 | 0 | 20 |
|
||||
| api | 12 | 0 | 12 |
|
||||
| promo | 17 | 0 | 17 |
|
||||
| stack | 16 | 0 | 16 |
|
||||
| quote | 13 | 0 | 13 |
|
||||
| ledger | 20 | 0 | 20 |
|
||||
| order | 22 | 0 | 22 |
|
||||
| recon | 20 | 0 | 20 |
|
||||
| federation | 12 | 0 | 12 |
|
||||
| attribution | 16 | 0 | 16 |
|
||||
| payment | 7 | 0 | 7 |
|
||||
| window | 19 | 0 | 19 |
|
||||
| nettax | 11 | 0 | 11 |
|
||||
| stock | 19 | 0 | 19 |
|
||||
| refund | 20 | 0 | 20 |
|
||||
| integration | 19 | 0 | 19 |
|
||||
| **Total** | **297** | **0** | **297** |
|
||||
@@ -1,121 +0,0 @@
|
||||
;; lib/commerce/stack.sx — promotion stacking precedence + best price.
|
||||
;;
|
||||
;; Per the miniKanren design rule, precedence is NOT encoded inside the promo
|
||||
;; rules. promo.sx enumerates which promos apply; this layer enumerates which
|
||||
;; *combinations* are legal and selects the best one by an explicit cost
|
||||
;; function (max total discount = min price).
|
||||
;;
|
||||
;; Exclusivity is a list of unordered code pairs that may not both apply:
|
||||
;; exclusions = (list (list code-a code-b) ...)
|
||||
;; A stacking is a subset of applicable (code amount) pairs containing no
|
||||
;; excluded pair. valid-stackings enumerates them; best-stacking is the
|
||||
;; deterministic selection layer; stacking-by-totalo is the backward query
|
||||
;; ("which legal stacking yields this total discount?").
|
||||
|
||||
(define
|
||||
excluded-pair?
|
||||
(fn
|
||||
(exclusions a b)
|
||||
(some
|
||||
(fn
|
||||
(p)
|
||||
(or
|
||||
(and (= (first p) a) (= (nth p 1) b))
|
||||
(and (= (first p) b) (= (nth p 1) a))))
|
||||
exclusions)))
|
||||
|
||||
;; True when no two distinct codes in the list are mutually excluded.
|
||||
(define
|
||||
compatible?
|
||||
(fn
|
||||
(exclusions codes)
|
||||
(every?
|
||||
(fn
|
||||
(a)
|
||||
(every?
|
||||
(fn (b) (or (= a b) (not (excluded-pair? exclusions a b))))
|
||||
codes))
|
||||
codes)))
|
||||
|
||||
;; All subsets of xs, preserving element order. 2^n entries.
|
||||
(define
|
||||
powerset
|
||||
(fn
|
||||
(xs)
|
||||
(if
|
||||
(empty? xs)
|
||||
(list (list))
|
||||
(let
|
||||
((r (powerset (cdr xs))))
|
||||
(append r (map (fn (s) (cons (first xs) s)) r))))))
|
||||
|
||||
(define stacking-codes (fn (st) (map first st)))
|
||||
|
||||
(define
|
||||
stacking-total
|
||||
(fn
|
||||
(st)
|
||||
(reduce (fn (acc pair) (+ acc (nth pair 1))) 0 st)))
|
||||
|
||||
;; Every legal stacking of the applicable (code amount) pairs.
|
||||
(define
|
||||
valid-stackings
|
||||
(fn
|
||||
(exclusions applicable)
|
||||
(filter
|
||||
(fn (st) (compatible? exclusions (stacking-codes st)))
|
||||
(powerset applicable))))
|
||||
|
||||
;; Deterministic selection: the legal stacking with the greatest total
|
||||
;; discount; ties keep the earlier (stable) candidate, so the result is a
|
||||
;; reproducible function of (exclusions, applicable).
|
||||
(define
|
||||
best-stacking
|
||||
(fn
|
||||
(exclusions applicable)
|
||||
(reduce
|
||||
(fn
|
||||
(best st)
|
||||
(if (> (stacking-total st) (stacking-total best)) st best))
|
||||
(list)
|
||||
(valid-stackings exclusions applicable))))
|
||||
|
||||
(define
|
||||
best-discount
|
||||
(fn
|
||||
(exclusions applicable)
|
||||
(stacking-total (best-stacking exclusions applicable))))
|
||||
|
||||
(define
|
||||
best-codes
|
||||
(fn
|
||||
(exclusions applicable)
|
||||
(stacking-codes (best-stacking exclusions applicable))))
|
||||
|
||||
;; Backward query: legal stackings (as code lists) whose total discount = D.
|
||||
(define
|
||||
stacking-by-totalo
|
||||
(fn
|
||||
(stackings codes total)
|
||||
(fresh
|
||||
(st)
|
||||
(membero st stackings)
|
||||
(project
|
||||
(st)
|
||||
(mk-conj
|
||||
(== codes (stacking-codes st))
|
||||
(== total (stacking-total st)))))))
|
||||
|
||||
;; --- top-level entry: best discount for a cart under a ruleset ---
|
||||
|
||||
(define
|
||||
best-promo-discount
|
||||
(fn
|
||||
(ctx cart ruleset exclusions)
|
||||
(best-discount exclusions (applicable-promos ctx cart ruleset))))
|
||||
|
||||
(define
|
||||
best-promo-codes
|
||||
(fn
|
||||
(ctx cart ruleset exclusions)
|
||||
(best-codes exclusions (applicable-promos ctx cart ruleset))))
|
||||
@@ -1,106 +0,0 @@
|
||||
;; lib/commerce/stock.sx — stock-constrained reservation.
|
||||
;;
|
||||
;; Reservation is a precondition the host checks BEFORE order-begin! (validate →
|
||||
;; begin), so the order flow stays pure orchestration. Availability is read
|
||||
;; relationally from the catalog stock facts (catalog.sx stocko); a stock view
|
||||
;; subtracts already-reserved quantities so concurrent orders can't over-reserve.
|
||||
;;
|
||||
;; can-reserve? cat cart — every line fits available stock
|
||||
;; reservation-shortfalls cat cart — the lines that do not, with detail
|
||||
;; effective-available cat reservations … — availability net of reservations
|
||||
;; sufficient-stocko cat sku variant qty — relational "can supply qty?" query
|
||||
|
||||
;; Deterministic on-hand stock for a (sku,variant); 0 if absent.
|
||||
(define
|
||||
available-stock
|
||||
(fn
|
||||
(cat sku variant)
|
||||
(let
|
||||
((rs (run 1 q (stocko cat sku variant q))))
|
||||
(if (empty? rs) 0 (first rs)))))
|
||||
|
||||
;; Units a line cannot fulfil from on-hand stock (0 if it fits).
|
||||
(define
|
||||
line-shortfall
|
||||
(fn
|
||||
(cat line)
|
||||
(let
|
||||
((short (- (line-qty line) (available-stock cat (line-sku line) (line-variant line)))))
|
||||
(if (< short 0) 0 short))))
|
||||
|
||||
(define
|
||||
line-reservable?
|
||||
(fn (cat line) (= (line-shortfall cat line) 0)))
|
||||
|
||||
;; Lines that cannot be fully reserved, each with requested/available/short.
|
||||
(define
|
||||
reservation-shortfalls
|
||||
(fn
|
||||
(cat cart)
|
||||
(reduce
|
||||
(fn
|
||||
(acc line)
|
||||
(let
|
||||
((short (line-shortfall cat line)))
|
||||
(if (> short 0) (append acc (list {:requested (line-qty line) :available (available-stock cat (line-sku line) (line-variant line)) :sku (line-sku line) :variant (line-variant line) :short short})) acc)))
|
||||
(list)
|
||||
cart)))
|
||||
|
||||
(define
|
||||
can-reserve?
|
||||
(fn (cat cart) (empty? (reservation-shortfalls cat cart))))
|
||||
|
||||
;; Validate → reject; the host gates order-begin! on this.
|
||||
(define
|
||||
reserve-check
|
||||
(fn (cat cart) (if (can-reserve? cat cart) :ok {:shortfalls (reservation-shortfalls cat cart) :rejected :insufficient-stock})))
|
||||
|
||||
;; --- reservation view (concurrent-safety) ---
|
||||
;; reservations: list of (sku variant qty) already held.
|
||||
|
||||
(define
|
||||
reserved-qty
|
||||
(fn
|
||||
(reservations sku variant)
|
||||
(reduce
|
||||
(fn
|
||||
(acc r)
|
||||
(if
|
||||
(and (= (first r) sku) (= (nth r 1) variant))
|
||||
(+ acc (nth r 2))
|
||||
acc))
|
||||
0
|
||||
reservations)))
|
||||
|
||||
;; On-hand minus already-reserved (clamped at 0).
|
||||
(define
|
||||
effective-available
|
||||
(fn
|
||||
(cat reservations sku variant)
|
||||
(let
|
||||
((eff (- (available-stock cat sku variant) (reserved-qty reservations sku variant))))
|
||||
(if (< eff 0) 0 eff))))
|
||||
|
||||
;; Can a line be reserved given existing reservations?
|
||||
(define
|
||||
line-reservable-with?
|
||||
(fn
|
||||
(cat reservations line)
|
||||
(<=
|
||||
(line-qty line)
|
||||
(effective-available
|
||||
cat
|
||||
reservations
|
||||
(line-sku line)
|
||||
(line-variant line)))))
|
||||
|
||||
;; --- relational availability query (the showcase) ---
|
||||
|
||||
;; Succeeds when on-hand stock for (sku,variant) covers qty. Multidirectional
|
||||
;; over the stock facts: "which variants of widget can supply 5?" is a backward
|
||||
;; query.
|
||||
(define
|
||||
sufficient-stocko
|
||||
(fn
|
||||
(cat sku variant qty)
|
||||
(fresh (avail) (stocko cat sku variant avail) (lteo-i qty avail))))
|
||||
@@ -1,73 +0,0 @@
|
||||
;; lib/commerce/tests/api.sx — public commerce session surface.
|
||||
;; Uses (commerce-test name got expected) provided by conformance.sh.
|
||||
|
||||
(define
|
||||
acat
|
||||
(make-catalog
|
||||
(list
|
||||
(list "widget" 1000 :standard)
|
||||
(list "book" 800 :zero-rated))
|
||||
(list (list "widget" :small -200))
|
||||
(list)))
|
||||
|
||||
(define
|
||||
arules
|
||||
(list
|
||||
(list :uk :standard :guest 2000)
|
||||
(list :uk :zero-rated :guest 0)))
|
||||
|
||||
(define actx (make-pricing-context acat arules :uk :guest))
|
||||
(define sess0 (commerce-session actx))
|
||||
|
||||
;; --- empty session ---
|
||||
|
||||
(commerce-test "new-session-empty" (commerce-cart sess0) empty-cart)
|
||||
(commerce-test "new-count" (commerce-count sess0) 0)
|
||||
(commerce-test "new-total" (commerce-total sess0) {:subtotal 0 :discounts 0 :total 0 :tax 0})
|
||||
|
||||
;; --- add + total ---
|
||||
|
||||
(define
|
||||
sess1
|
||||
(commerce-add
|
||||
(commerce-add sess0 "widget" :small 2)
|
||||
"book"
|
||||
:none 1))
|
||||
|
||||
(commerce-test "add-count" (commerce-count sess1) 3)
|
||||
(commerce-test
|
||||
"add-lines"
|
||||
(commerce-lines sess1)
|
||||
(list (list "widget" :small 2) (list "book" :none 1)))
|
||||
(commerce-test "add-total" (commerce-total sess1) {:subtotal 2400 :discounts 0 :total 2720 :tax 320})
|
||||
|
||||
;; --- mutate ---
|
||||
|
||||
(commerce-test
|
||||
"set-qty"
|
||||
(commerce-lines (commerce-set-qty sess1 "widget" :small 1))
|
||||
(list (list "widget" :small 1) (list "book" :none 1)))
|
||||
|
||||
(commerce-test
|
||||
"remove"
|
||||
(commerce-lines (commerce-remove sess1 "book" :none))
|
||||
(list (list "widget" :small 2)))
|
||||
|
||||
;; --- validation ---
|
||||
|
||||
(commerce-test "can-add-yes" (commerce-can-add? sess0 "widget") true)
|
||||
(commerce-test "can-add-no" (commerce-can-add? sess0 "ghost") false)
|
||||
|
||||
;; --- audit breakdown ---
|
||||
|
||||
(commerce-test
|
||||
"explain"
|
||||
(commerce-explain sess1)
|
||||
(list {:sku "widget" :unit 800 :qty 2 :variant :small :extended 1600 :tax 320} {:sku "book" :unit 800 :qty 1 :variant :none :extended 800 :tax 0}))
|
||||
|
||||
;; --- checkout stub ---
|
||||
|
||||
(commerce-test
|
||||
"checkout-stub"
|
||||
(get (commerce-checkout sess1) :status)
|
||||
:not-implemented)
|
||||
@@ -1,124 +0,0 @@
|
||||
;; lib/commerce/tests/attribution.sx — line-level discount attribution.
|
||||
;; Uses (commerce-test name got expected) provided by conformance.sh.
|
||||
|
||||
(define
|
||||
pcat
|
||||
(make-catalog
|
||||
(list
|
||||
(list "widget" 1000 :standard)
|
||||
(list "gizmo" 2000 :standard)
|
||||
(list "book" 800 :zero-rated)
|
||||
(list "tea" 1000 :reduced))
|
||||
(list)
|
||||
(list)))
|
||||
|
||||
(define gctx (make-pricing-context pcat (list) :uk :guest))
|
||||
(define mctx (make-pricing-context pcat (list) :uk :member))
|
||||
|
||||
(define
|
||||
cart
|
||||
(list
|
||||
(list "widget" :none 2)
|
||||
(list "gizmo" :none 1)
|
||||
(list "book" :none 1)
|
||||
(list "tea" :none 6)))
|
||||
|
||||
(define
|
||||
ruleset
|
||||
(list
|
||||
(list :percent "TEN" :standard 1000)
|
||||
(list :percent "TWENTY" :standard 2000)
|
||||
(list :bundle "B3T" "tea" 3)
|
||||
(list :fixed "FIVE" 0 500)
|
||||
(list :member "MEM" :standard 1500)))
|
||||
|
||||
(define w-line (list "widget" :none 2))
|
||||
(define t-line (list "tea" :none 6))
|
||||
(define bk-line (list "book" :none 1))
|
||||
|
||||
;; --- scope helpers ---
|
||||
|
||||
(commerce-test
|
||||
"class-lines-standard"
|
||||
(class-lines gctx cart :standard)
|
||||
(list (list "widget" :none 2) (list "gizmo" :none 1)))
|
||||
|
||||
(commerce-test
|
||||
"promo-lines-bundle"
|
||||
(promo-lines gctx cart (list :bundle "B3T" "tea" 3))
|
||||
(list (list "tea" :none 6)))
|
||||
|
||||
(commerce-test
|
||||
"promo-lines-fixed-none"
|
||||
(promo-lines gctx cart (list :fixed "FIVE" 0 500))
|
||||
(list))
|
||||
|
||||
;; --- forward: which lines does a code touch? ---
|
||||
|
||||
(commerce-test
|
||||
"lines-for-ten"
|
||||
(lines-for-code gctx cart ruleset "TEN")
|
||||
(list (list "widget" :none 2) (list "gizmo" :none 1)))
|
||||
|
||||
(commerce-test
|
||||
"lines-for-bundle"
|
||||
(lines-for-code gctx cart ruleset "B3T")
|
||||
(list (list "tea" :none 6)))
|
||||
|
||||
(commerce-test
|
||||
"lines-for-fixed-empty"
|
||||
(lines-for-code gctx cart ruleset "FIVE")
|
||||
(list))
|
||||
(commerce-test
|
||||
"lines-for-mem-guest-empty"
|
||||
(lines-for-code gctx cart ruleset "MEM")
|
||||
(list))
|
||||
|
||||
;; --- backward: which codes touch this line? (the showcase) ---
|
||||
|
||||
(commerce-test
|
||||
"codes-for-widget-guest"
|
||||
(codes-for-line gctx cart ruleset w-line)
|
||||
(list "TEN" "TWENTY"))
|
||||
|
||||
(commerce-test
|
||||
"codes-for-tea"
|
||||
(codes-for-line gctx cart ruleset t-line)
|
||||
(list "B3T"))
|
||||
(commerce-test
|
||||
"codes-for-book-none"
|
||||
(codes-for-line gctx cart ruleset bk-line)
|
||||
(list))
|
||||
|
||||
;; member sees the member rate too
|
||||
(commerce-test
|
||||
"codes-for-widget-member"
|
||||
(codes-for-line mctx cart ruleset w-line)
|
||||
(list "TEN" "TWENTY" "MEM"))
|
||||
|
||||
(commerce-test
|
||||
"lines-for-mem-member"
|
||||
(lines-for-code mctx cart ruleset "MEM")
|
||||
(list (list "widget" :none 2) (list "gizmo" :none 1)))
|
||||
|
||||
;; --- predicate ---
|
||||
|
||||
(commerce-test
|
||||
"touched-yes"
|
||||
(line-touched-by? gctx cart ruleset "TEN" w-line)
|
||||
true)
|
||||
(commerce-test
|
||||
"touched-no-wrong-class"
|
||||
(line-touched-by? gctx cart ruleset "B3T" w-line)
|
||||
false)
|
||||
(commerce-test
|
||||
"touched-no-guest-mem"
|
||||
(line-touched-by? gctx cart ruleset "MEM" w-line)
|
||||
false)
|
||||
|
||||
;; --- order-level (fixed) codes ---
|
||||
|
||||
(commerce-test
|
||||
"order-level"
|
||||
(order-level-codes gctx cart ruleset)
|
||||
(list "FIVE"))
|
||||
@@ -1,103 +0,0 @@
|
||||
;; lib/commerce/tests/cart.sx — cart structure + line operations.
|
||||
;; Uses (commerce-test name got expected) provided by conformance.sh.
|
||||
|
||||
;; --- add ---
|
||||
|
||||
(commerce-test
|
||||
"add-to-empty"
|
||||
(cart-add empty-cart "widget" :small 2)
|
||||
(list (list "widget" :small 2)))
|
||||
|
||||
(commerce-test
|
||||
"add-merges-same-line"
|
||||
(cart-add
|
||||
(cart-add empty-cart "widget" :small 2)
|
||||
"widget"
|
||||
:small 3)
|
||||
(list (list "widget" :small 5)))
|
||||
|
||||
(commerce-test
|
||||
"add-different-variant-separate"
|
||||
(cart-add
|
||||
(cart-add empty-cart "widget" :small 2)
|
||||
"widget"
|
||||
:large 1)
|
||||
(list (list "widget" :small 2) (list "widget" :large 1)))
|
||||
|
||||
(commerce-test
|
||||
"add-different-sku-separate"
|
||||
(cart-add
|
||||
(cart-add empty-cart "widget" :small 2)
|
||||
"gadget"
|
||||
:std 1)
|
||||
(list (list "widget" :small 2) (list "gadget" :std 1)))
|
||||
|
||||
(commerce-test
|
||||
"add-preserves-order"
|
||||
(cart-skus
|
||||
(cart-add
|
||||
(cart-add (cart-add empty-cart "a" :v 1) "b" :v 1)
|
||||
"c"
|
||||
:v 1))
|
||||
(list "a" "b" "c"))
|
||||
|
||||
;; --- qty queries ---
|
||||
|
||||
(define
|
||||
c2
|
||||
(cart-add
|
||||
(cart-add empty-cart "widget" :small 2)
|
||||
"gadget"
|
||||
:std 4))
|
||||
|
||||
(commerce-test "cart-qty-found" (cart-qty c2 "widget" :small) 2)
|
||||
(commerce-test "cart-qty-missing" (cart-qty c2 "widget" :large) 0)
|
||||
(commerce-test "cart-count" (cart-count c2) 6)
|
||||
(commerce-test "cart-empty-yes" (cart-empty? empty-cart) true)
|
||||
(commerce-test "cart-empty-no" (cart-empty? c2) false)
|
||||
|
||||
;; --- set-qty ---
|
||||
|
||||
(commerce-test
|
||||
"set-qty-existing"
|
||||
(cart-set-qty c2 "widget" :small 10)
|
||||
(list (list "widget" :small 10) (list "gadget" :std 4)))
|
||||
|
||||
(commerce-test
|
||||
"set-qty-new-line"
|
||||
(cart-set-qty empty-cart "book" :std 3)
|
||||
(list (list "book" :std 3)))
|
||||
|
||||
(commerce-test
|
||||
"set-qty-zero-removes"
|
||||
(cart-set-qty c2 "widget" :small 0)
|
||||
(list (list "gadget" :std 4)))
|
||||
|
||||
;; --- remove ---
|
||||
|
||||
(commerce-test
|
||||
"remove-line"
|
||||
(cart-remove c2 "gadget" :std)
|
||||
(list (list "widget" :small 2)))
|
||||
|
||||
(commerce-test
|
||||
"remove-missing-noop"
|
||||
(cart-remove c2 "nope" :std)
|
||||
(list (list "widget" :small 2) (list "gadget" :std 4)))
|
||||
|
||||
;; --- relational view ---
|
||||
|
||||
(commerce-test
|
||||
"cart-lineo-forward"
|
||||
(run* q (cart-lineo c2 "gadget" :std q))
|
||||
(list 4))
|
||||
|
||||
(commerce-test
|
||||
"cart-lineo-sku-by-qty-backward"
|
||||
(run* sk (fresh (v) (cart-lineo c2 sk v 4)))
|
||||
(list "gadget"))
|
||||
|
||||
(commerce-test
|
||||
"cart-lineo-all-skus"
|
||||
(run* sk (fresh (v q) (cart-lineo c2 sk v q)))
|
||||
(list "widget" "gadget"))
|
||||
@@ -1,93 +0,0 @@
|
||||
;; lib/commerce/tests/catalog.sx — catalog facts + relational accessors.
|
||||
;; Uses (commerce-test name got expected) provided by conformance.sh.
|
||||
;; Query vars avoid the name `s` (the run-n macro binds `s` internally).
|
||||
|
||||
(define
|
||||
cat
|
||||
(make-catalog
|
||||
(list
|
||||
(list "widget" 1000 :standard)
|
||||
(list "gadget" 2500 :standard)
|
||||
(list "book" 800 :zero-rated)
|
||||
(list "tea" 1000 :reduced))
|
||||
(list
|
||||
(list "widget" :small -200)
|
||||
(list "widget" :large 500)
|
||||
(list "gadget" :std 0))
|
||||
(list
|
||||
(list "widget" :small 5)
|
||||
(list "widget" :large 0)
|
||||
(list "gadget" :std 12))))
|
||||
|
||||
;; --- forward lookups ---
|
||||
|
||||
(commerce-test
|
||||
"price-forward"
|
||||
(run* p (priceo cat "widget" p))
|
||||
(list 1000))
|
||||
(commerce-test
|
||||
"class-forward"
|
||||
(run* c (classo cat "book" c))
|
||||
(list :zero-rated))
|
||||
(commerce-test
|
||||
"product-forward"
|
||||
(run* q (fresh (p c) (producto cat "gadget" p c) (== q (list p c))))
|
||||
(list (list 2500 :standard)))
|
||||
|
||||
;; --- backward lookups (the showcase) ---
|
||||
|
||||
(commerce-test
|
||||
"sku-by-price-backward"
|
||||
(run* sk (priceo cat sk 1000))
|
||||
(list "widget" "tea"))
|
||||
|
||||
(commerce-test
|
||||
"sku-by-class-backward"
|
||||
(run* sk (classo cat sk :standard))
|
||||
(list "widget" "gadget"))
|
||||
|
||||
(commerce-test
|
||||
"all-prices"
|
||||
(run* p (fresh (sk) (priceo cat sk p)))
|
||||
(list 1000 2500 800 1000))
|
||||
|
||||
;; --- variants + effective unit price ---
|
||||
|
||||
(commerce-test
|
||||
"variant-delta-forward"
|
||||
(run* d (varianto cat "widget" :small d))
|
||||
(list -200))
|
||||
|
||||
(commerce-test
|
||||
"unit-price-small"
|
||||
(run* p (unit-priceo cat "widget" :small p))
|
||||
(list 800))
|
||||
|
||||
(commerce-test
|
||||
"unit-price-large"
|
||||
(run* p (unit-priceo cat "widget" :large p))
|
||||
(list 1500))
|
||||
|
||||
(commerce-test
|
||||
"variant-by-delta-backward"
|
||||
(run* v (varianto cat "widget" v -200))
|
||||
(list :small))
|
||||
|
||||
;; --- stock ---
|
||||
|
||||
(commerce-test
|
||||
"stock-forward"
|
||||
(run* q (stocko cat "widget" :small q))
|
||||
(list 5))
|
||||
|
||||
(commerce-test
|
||||
"in-stock-skus-backward"
|
||||
(run* sk (fresh (v q) (stocko cat sk v q) (lto-i 0 q)))
|
||||
(list "widget" "gadget"))
|
||||
|
||||
;; --- deterministic helpers ---
|
||||
|
||||
(commerce-test "catalog-price-helper" (catalog-price cat "gadget") 2500)
|
||||
(commerce-test "catalog-class-helper" (catalog-class cat "tea") :reduced)
|
||||
(commerce-test "catalog-has-yes" (catalog-has? cat "book") true)
|
||||
(commerce-test "catalog-has-no" (catalog-has? cat "nonesuch") false)
|
||||
@@ -1,88 +0,0 @@
|
||||
;; lib/commerce/tests/federation.sx — federated catalog (out-of-scope stub).
|
||||
;; Uses (commerce-test name got expected) provided by conformance.sh.
|
||||
|
||||
(define
|
||||
cat-a
|
||||
(make-catalog
|
||||
(list
|
||||
(list "widget" 1000 :standard)
|
||||
(list "book" 800 :zero-rated))
|
||||
(list)
|
||||
(list)))
|
||||
|
||||
(define
|
||||
cat-b
|
||||
(make-catalog
|
||||
(list
|
||||
(list "widget" 900 :standard)
|
||||
(list "tea" 1200 :reduced))
|
||||
(list)
|
||||
(list)))
|
||||
|
||||
(define
|
||||
cat-c
|
||||
(make-catalog (list (list "widget" 1100 :standard)) (list) (list)))
|
||||
|
||||
(define
|
||||
fed
|
||||
(federation-add
|
||||
(federation-add (make-federation :alpha cat-a) :beta cat-b)
|
||||
:gamma cat-c))
|
||||
|
||||
;; --- structure ---
|
||||
|
||||
(commerce-test "is-stub" federation-stub? true)
|
||||
(commerce-test
|
||||
"instances"
|
||||
(federation-instances fed)
|
||||
(list :alpha :beta :gamma))
|
||||
(commerce-test "product-count" (len (fed-products fed)) 5)
|
||||
|
||||
;; --- forward query ---
|
||||
|
||||
(commerce-test
|
||||
"price-at-instance"
|
||||
(run* p (fed-priceo fed :beta "widget" p))
|
||||
(list 900))
|
||||
|
||||
;; --- backward queries (the showcase) ---
|
||||
|
||||
(commerce-test
|
||||
"instances-with-widget"
|
||||
(instances-with-sku fed "widget")
|
||||
(list :alpha :beta :gamma))
|
||||
|
||||
(commerce-test
|
||||
"instances-with-book"
|
||||
(instances-with-sku fed "book")
|
||||
(list :alpha))
|
||||
|
||||
(commerce-test
|
||||
"instances-with-tea"
|
||||
(instances-with-sku fed "tea")
|
||||
(list :beta))
|
||||
|
||||
(commerce-test
|
||||
"instance-by-price-backward"
|
||||
(run* inst (fresh (c) (fed-producto fed inst "widget" 1100 c)))
|
||||
(list :gamma))
|
||||
|
||||
;; --- offers + cheapest (deterministic selection) ---
|
||||
|
||||
(commerce-test
|
||||
"widget-offers"
|
||||
(sku-offers fed "widget")
|
||||
(list
|
||||
(list 1000 :alpha)
|
||||
(list 900 :beta)
|
||||
(list 1100 :gamma)))
|
||||
|
||||
(commerce-test
|
||||
"cheapest-widget"
|
||||
(cheapest-offer fed "widget")
|
||||
(list 900 :beta))
|
||||
(commerce-test
|
||||
"cheapest-book"
|
||||
(cheapest-offer fed "book")
|
||||
(list 800 :alpha))
|
||||
(commerce-test "cheapest-missing" (cheapest-offer fed "ghost") nil)
|
||||
@@ -1,104 +0,0 @@
|
||||
;; lib/commerce/tests/integration.sx — end-to-end composition proof.
|
||||
;; Uses (commerce-test name got expected) provided by conformance.sh.
|
||||
;;
|
||||
;; One narrative across every module: catalog → stock check → quote
|
||||
;; (promo+stack+tax) → order flow → payment envelope → settle → recon → refund.
|
||||
;; Proves the seams tie together with consistent numbers (the project's thesis:
|
||||
;; minikanren pricing + flow lifecycle + persist ledger compose).
|
||||
;; Builds one flow env with BOTH the order and refund flows.
|
||||
|
||||
(define env (order-make-env))
|
||||
(define _rf (refund-flow-load! env))
|
||||
(define b (persist/mem-backend))
|
||||
|
||||
(define
|
||||
cat
|
||||
(make-catalog
|
||||
(list
|
||||
(list "widget" 1000 :standard)
|
||||
(list "book" 800 :zero-rated))
|
||||
(list (list "widget" :small -200))
|
||||
(list (list "widget" :small 10) (list "book" :none 5))))
|
||||
|
||||
(define
|
||||
rules
|
||||
(list
|
||||
(list :uk :standard :guest 2000)
|
||||
(list :uk :zero-rated :guest 0)))
|
||||
|
||||
(define ctx (make-pricing-context cat rules :uk :guest))
|
||||
|
||||
(define
|
||||
ruleset
|
||||
(list
|
||||
(list :percent "TEN" :standard 1000)
|
||||
(list :fixed "FIVE" 0 50)))
|
||||
|
||||
;; widget :small x2 → unit 800, extended 1600 (standard); book x1 → 800 (zero-rated)
|
||||
(define
|
||||
cart
|
||||
(list (list "widget" :small 2) (list "book" :none 1)))
|
||||
|
||||
;; 1. stock gating passes (widget:small 10 >= 2)
|
||||
(commerce-test "int-can-reserve" (can-reserve? cat cart) true)
|
||||
|
||||
;; 2. quote ties the whole pricing pipeline together
|
||||
;; subtotal 2400; discount TEN 160 + FIVE 50 = 210; tax 1600@20% = 320;
|
||||
;; total 2400 - 210 + 320 = 2510
|
||||
(define q (cart-quote ctx cart ruleset (list)))
|
||||
(commerce-test "int-quote-subtotal" (quote-subtotal q) 2400)
|
||||
(commerce-test "int-quote-discount" (quote-discount q) 210)
|
||||
(commerce-test "int-quote-tax" (quote-tax q) 320)
|
||||
(commerce-test "int-quote-total" (quote-total q) 2510)
|
||||
|
||||
;; 3. attribution explains where the discount landed
|
||||
(commerce-test
|
||||
"int-attribution"
|
||||
(codes-for-line ctx cart ruleset (list "widget" :small 2))
|
||||
(list "TEN"))
|
||||
(commerce-test
|
||||
"int-order-level"
|
||||
(order-level-codes ctx cart ruleset)
|
||||
(list "FIVE"))
|
||||
|
||||
;; 4. order carries the quote total into the ledger; suspends at payment
|
||||
(define oid "INT-1")
|
||||
(define id (order-begin! env b oid 1000 q))
|
||||
(commerce-test "int-order-total-from-quote" (order-total b oid) 2510)
|
||||
(commerce-test "int-waiting-payment" (order-flow-waiting env id) "payment")
|
||||
|
||||
;; 5. the payment envelope reflects the quoted total
|
||||
(commerce-test
|
||||
"int-payment-envelope"
|
||||
(payment-request b oid :GBP "https://shop/return")
|
||||
{:order "INT-1" :amount 2510 :return-url "https://shop/return" :currency :GBP})
|
||||
|
||||
;; 6. settle the quoted amount → reconciles exactly
|
||||
(commerce-test
|
||||
"int-settled"
|
||||
(order-settle! env b id oid "pay-int" 1002 2510)
|
||||
:settled)
|
||||
(commerce-test "int-status-fulfilled" (order-status b oid) :fulfilled)
|
||||
(commerce-test "int-recon-ok" (order-recon b oid) :ok)
|
||||
|
||||
;; 7. partial refund via its own flow → recon moves to underpaid
|
||||
(define rid (refund-begin! env b oid "rf-int" 2000 510))
|
||||
(commerce-test "int-refund-approve" (refund-approve! env rid) :approved)
|
||||
(commerce-test
|
||||
"int-refund-settle"
|
||||
(refund-settle! env b rid oid "rf-int" 2001 510)
|
||||
:settled)
|
||||
(commerce-test
|
||||
"int-refunded-amount"
|
||||
(order-refunded-amount-of (order-events b oid))
|
||||
510)
|
||||
(commerce-test "int-recon-after-refund" (order-recon b oid) :underpaid)
|
||||
|
||||
;; 8. ledger reconciliation flags the now-mismatched order
|
||||
(commerce-test
|
||||
"int-mismatch"
|
||||
(mismatched-orders b)
|
||||
(list (order-stream "INT-1")))
|
||||
|
||||
;; 9. distinct flow ids for the order and the refund
|
||||
(commerce-test "int-distinct-flow-ids" (not (= id rid)) true)
|
||||
@@ -1,80 +0,0 @@
|
||||
;; lib/commerce/tests/ledger.sx — order ledger on persist + idempotent recon.
|
||||
;; Uses (commerce-test name got expected) provided by conformance.sh.
|
||||
|
||||
(define q1 {:codes (list) :subtotal 1000 :discount 0 :total 1200 :tax 200})
|
||||
|
||||
;; --- lifecycle status projection ---
|
||||
|
||||
(define b1 (persist/mem-backend))
|
||||
(define _c1 (order-create b1 "A1" 100 q1))
|
||||
(commerce-test "status-pending" (order-status b1 "A1") :pending)
|
||||
(define _r1 (order-reserve b1 "A1" 101 {:lines 2}))
|
||||
(commerce-test "status-reserved" (order-status b1 "A1") :reserved)
|
||||
(define _p1 (order-pay b1 "A1" "ref-1" 102 1200))
|
||||
(commerce-test "status-paid" (order-status b1 "A1") :paid)
|
||||
(define _f1 (order-fulfil b1 "A1" 103 {:carrier "post"}))
|
||||
(commerce-test "status-fulfilled" (order-status b1 "A1") :fulfilled)
|
||||
|
||||
(commerce-test "total-projection" (order-total b1 "A1") 1200)
|
||||
(commerce-test "paid-projection" (order-paid b1 "A1") 1200)
|
||||
(commerce-test "recon-ok" (order-recon b1 "A1") :ok)
|
||||
(commerce-test "event-count" (len (order-events b1 "A1")) 4)
|
||||
|
||||
;; --- idempotency: replayed webhook does not double-record ---
|
||||
|
||||
(define b2 (persist/mem-backend))
|
||||
(define _c2 (order-create b2 "B1" 200 q1))
|
||||
(define _p2a (order-pay b2 "B1" "sumup-9" 201 1200))
|
||||
(define _p2b (order-pay b2 "B1" "sumup-9" 201 1200))
|
||||
(define _p2c (order-pay b2 "B1" "sumup-9" 201 1200))
|
||||
|
||||
(commerce-test "idem-single-event" (len (order-events b2 "B1")) 2)
|
||||
(commerce-test "idem-paid-once" (order-paid b2 "B1") 1200)
|
||||
(commerce-test "idem-recon-ok" (order-recon b2 "B1") :ok)
|
||||
(commerce-test "idem-same-event" (= _p2a _p2c) true)
|
||||
|
||||
;; --- mismatch detection ---
|
||||
|
||||
(define bun (persist/mem-backend))
|
||||
(define _cu (order-create bun "U1" 300 q1))
|
||||
(commerce-test "unpaid-recon" (order-recon bun "U1") :unpaid)
|
||||
|
||||
(define bup (persist/mem-backend))
|
||||
(define _cp (order-create bup "U2" 300 q1))
|
||||
(define _pp1 (order-pay bup "U2" "r-a" 301 1200))
|
||||
(define _pp2 (order-pay bup "U2" "r-b" 302 1200))
|
||||
(commerce-test "double-charge-overpaid" (order-recon bup "U2") :overpaid)
|
||||
(commerce-test "double-charge-amount" (order-paid bup "U2") 2400)
|
||||
|
||||
(define bsh (persist/mem-backend))
|
||||
(define _cs (order-create bsh "U3" 400 q1))
|
||||
(define _ps (order-pay bsh "U3" "r-short" 401 1000))
|
||||
(commerce-test "underpaid-recon" (order-recon bsh "U3") :underpaid)
|
||||
|
||||
;; --- refund (idempotent) reduces net ---
|
||||
|
||||
(define brf (persist/mem-backend))
|
||||
(define _crf (order-create brf "R1" 500 q1))
|
||||
(define _prf (order-pay brf "R1" "p-1" 501 1200))
|
||||
(define _rf1 (order-refund brf "R1" "rf-1" 502 200))
|
||||
(define _rf2 (order-refund brf "R1" "rf-1" 502 200))
|
||||
(commerce-test "refund-idem-net" (order-recon brf "R1") :underpaid)
|
||||
(commerce-test "refund-idem-events" (len (order-events brf "R1")) 3)
|
||||
|
||||
;; --- cross-ledger reconciliation ---
|
||||
|
||||
(define bL (persist/mem-backend))
|
||||
(define _l1 (order-create bL "OK1" 600 q1))
|
||||
(define _l1p (order-pay bL "OK1" "ok-ref" 601 1200))
|
||||
(define _l2 (order-create bL "OVER1" 600 q1))
|
||||
(define _l2a (order-pay bL "OVER1" "o-a" 602 1200))
|
||||
(define _l2b (order-pay bL "OVER1" "o-b" 603 1200))
|
||||
(define _l3 (order-create bL "UNDER1" 600 q1))
|
||||
(define _l3p (order-pay bL "UNDER1" "u-ref" 604 900))
|
||||
(define _l4 (order-create bL "PENDING1" 600 q1))
|
||||
|
||||
(commerce-test "ledger-order-count" (len (order-ids bL)) 4)
|
||||
(commerce-test
|
||||
"ledger-mismatches"
|
||||
(sort (ledger-mismatches bL))
|
||||
(sort (list (order-stream "OVER1") (order-stream "UNDER1"))))
|
||||
@@ -1,92 +0,0 @@
|
||||
;; lib/commerce/tests/nettax.sx — discount-aware (net) tax policy.
|
||||
;; Uses (commerce-test name got expected) provided by conformance.sh.
|
||||
|
||||
(define
|
||||
pcat
|
||||
(make-catalog
|
||||
(list
|
||||
(list "widget" 1000 :standard)
|
||||
(list "tea" 1000 :reduced))
|
||||
(list)
|
||||
(list)))
|
||||
|
||||
(define
|
||||
rules
|
||||
(list
|
||||
(list :uk :standard :guest 2000)
|
||||
(list :uk :reduced :guest 500)))
|
||||
|
||||
(define gctx (make-pricing-context pcat rules :uk :guest))
|
||||
|
||||
;; widget x3 = 3000 (standard), tea x6 = 6000 (reduced); subtotal 9000
|
||||
(define
|
||||
cart
|
||||
(list (list "widget" :none 3) (list "tea" :none 6)))
|
||||
|
||||
(define ruleset (list (list :percent "TEN" :standard 1000)))
|
||||
|
||||
;; --- allocation: proportional, sums exactly to the discount ---
|
||||
|
||||
(commerce-test
|
||||
"allocate-even"
|
||||
(allocate-discount pcat cart 300)
|
||||
(list 100 200))
|
||||
(commerce-test
|
||||
"allocate-sums-to-discount"
|
||||
(ct-sum (allocate-discount pcat cart 300))
|
||||
300)
|
||||
|
||||
;; remainder distribution: 100 over (3000,6000)/9000 = (33,66) rem 1 -> (34,66)
|
||||
(commerce-test
|
||||
"allocate-remainder"
|
||||
(allocate-discount pcat cart 100)
|
||||
(list 34 66))
|
||||
(commerce-test
|
||||
"allocate-remainder-sums"
|
||||
(ct-sum (allocate-discount pcat cart 100))
|
||||
100)
|
||||
|
||||
(commerce-test
|
||||
"allocate-zero"
|
||||
(allocate-discount pcat cart 0)
|
||||
(list 0 0))
|
||||
(commerce-test
|
||||
"allocate-empty"
|
||||
(allocate-discount pcat empty-cart 0)
|
||||
(list))
|
||||
|
||||
;; --- net tax vs gross tax ---
|
||||
;; discount = TEN 10% of standard 3000 = 300, allocated (100 200).
|
||||
;; net: widget 2900@20%=580, tea 5800@5%=290 -> net tax 870 (gross was 900).
|
||||
|
||||
(commerce-test
|
||||
"net-quote"
|
||||
(cart-quote-net gctx cart ruleset (list))
|
||||
{:codes (list "TEN") :subtotal 9000 :discount 300 :total 9570 :tax 870})
|
||||
|
||||
;; same cart through the gross policy taxes 900 (the documented default)
|
||||
(commerce-test
|
||||
"gross-quote-for-contrast"
|
||||
(quote-tax (cart-quote gctx cart ruleset (list)))
|
||||
900)
|
||||
|
||||
(commerce-test
|
||||
"net-tax-lower"
|
||||
(quote-tax (cart-quote-net gctx cart ruleset (list)))
|
||||
870)
|
||||
|
||||
;; --- no discount: net policy == gross policy ---
|
||||
|
||||
(commerce-test
|
||||
"no-discount-net-equals-gross"
|
||||
(=
|
||||
(cart-quote-net gctx cart (list) (list))
|
||||
(cart-quote gctx cart (list) (list)))
|
||||
true)
|
||||
|
||||
;; --- empty cart ---
|
||||
|
||||
(commerce-test
|
||||
"net-empty"
|
||||
(cart-quote-net gctx empty-cart ruleset (list))
|
||||
{:codes (list) :subtotal 0 :discount 0 :total 0 :tax 0})
|
||||
@@ -1,74 +0,0 @@
|
||||
;; lib/commerce/tests/order.sx — order lifecycle as a flow-on-sx flow.
|
||||
;; Uses (commerce-test name got expected) provided by conformance.sh.
|
||||
;; Builds the (expensive) flow env once; all assertions share it.
|
||||
|
||||
(define env (order-make-env))
|
||||
(define b (persist/mem-backend))
|
||||
(define q1 {:codes (list) :subtotal 1000 :discount 0 :total 1200 :tax 200})
|
||||
|
||||
;; --- happy path: begin suspends at payment ---
|
||||
|
||||
(define id1 (order-begin! env b "O1" 100 q1))
|
||||
|
||||
(commerce-test "begin-status-reserved" (order-status b "O1") :reserved)
|
||||
(commerce-test "begin-waiting-payment" (order-flow-waiting env id1) "payment")
|
||||
(commerce-test "begin-not-yet-paid" (order-paid b "O1") 0)
|
||||
|
||||
;; --- settle: payment webhook drives fulfilment ---
|
||||
|
||||
(define s1 (order-settle! env b id1 "O1" "ref-1" 102 1200))
|
||||
|
||||
(commerce-test "settle-result" s1 :settled)
|
||||
(commerce-test "settle-status-fulfilled" (order-status b "O1") :fulfilled)
|
||||
(commerce-test "settle-flow-done" (order-flow-status env id1) "done")
|
||||
(commerce-test "settle-recon-ok" (order-recon b "O1") :ok)
|
||||
(commerce-test "settle-event-count" (len (order-events b "O1")) 4)
|
||||
|
||||
;; --- webhook replay: a second settle is a no-op ---
|
||||
|
||||
(define s1b (order-settle! env b id1 "O1" "ref-1" 102 1200))
|
||||
|
||||
(commerce-test "replay-already-settled" s1b :already-settled)
|
||||
(commerce-test
|
||||
"replay-no-extra-events"
|
||||
(len (order-events b "O1"))
|
||||
4)
|
||||
(commerce-test "replay-recon-still-ok" (order-recon b "O1") :ok)
|
||||
|
||||
;; --- a second order gets its own flow id and suspends independently ---
|
||||
|
||||
(define id2 (order-begin! env b "O2" 200 q1))
|
||||
|
||||
(commerce-test "second-distinct-id" (not (= id1 id2)) true)
|
||||
(commerce-test
|
||||
"second-waiting-payment"
|
||||
(order-flow-waiting env id2)
|
||||
"payment")
|
||||
(commerce-test "first-unaffected" (order-status b "O1") :fulfilled)
|
||||
|
||||
;; --- durability: a suspended order survives a process restart ---
|
||||
|
||||
(define id3 (order-begin! env b "O3" 300 q1))
|
||||
(commerce-test "pre-restart-waiting" (order-flow-waiting env id3) "payment")
|
||||
|
||||
(define _restart (order-flow-restart! env))
|
||||
|
||||
(commerce-test
|
||||
"post-restart-still-waiting"
|
||||
(order-flow-waiting env id3)
|
||||
"payment")
|
||||
(commerce-test "post-restart-ledger-intact" (order-status b "O3") :reserved)
|
||||
|
||||
(define s3 (order-settle! env b id3 "O3" "ref-3" 302 1200))
|
||||
|
||||
(commerce-test "post-restart-settled" s3 :settled)
|
||||
(commerce-test "post-restart-status" (order-status b "O3") :fulfilled)
|
||||
(commerce-test "post-restart-recon-ok" (order-recon b "O3") :ok)
|
||||
(commerce-test "post-restart-flow-done" (order-flow-status env id3) "done")
|
||||
|
||||
;; --- payment-request envelope (provider-neutral) for the still-suspended O2 ---
|
||||
|
||||
(commerce-test
|
||||
"pending-payments-lists-suspended"
|
||||
(pending-payments env b :GBP "https://shop/return")
|
||||
(list {:id id2 :request {:order "O2" :amount 1200 :return-url "https://shop/return" :currency :GBP}}))
|
||||
@@ -1,43 +0,0 @@
|
||||
;; lib/commerce/tests/payment.sx — provider-neutral payment-request envelope.
|
||||
;; Uses (commerce-test name got expected) provided by conformance.sh.
|
||||
;; Envelope construction is ledger-only (no flow env); pending-payments (which
|
||||
;; needs the flow env) is exercised in the order suite.
|
||||
|
||||
(define q1 {:codes (list) :subtotal 1000 :discount 0 :total 1200 :tax 200})
|
||||
(define q2 {:codes (list) :subtotal 5000 :discount 500 :total 4500 :tax 0})
|
||||
|
||||
(define b (persist/mem-backend))
|
||||
(define _c1 (order-create b "P1" 1 q1))
|
||||
(define _c2 (order-create b "P2" 1 q2))
|
||||
|
||||
(commerce-test
|
||||
"envelope"
|
||||
(payment-request b "P1" :GBP "https://shop/return")
|
||||
{:order "P1" :amount 1200 :return-url "https://shop/return" :currency :GBP})
|
||||
|
||||
(commerce-test
|
||||
"envelope-amount"
|
||||
(payment-request-amount (payment-request b "P1" :GBP "x"))
|
||||
1200)
|
||||
(commerce-test
|
||||
"envelope-currency"
|
||||
(payment-request-currency (payment-request b "P1" :GBP "x"))
|
||||
:GBP)
|
||||
(commerce-test
|
||||
"envelope-order"
|
||||
(payment-request-order (payment-request b "P1" :GBP "x"))
|
||||
"P1")
|
||||
(commerce-test
|
||||
"envelope-return-url"
|
||||
(payment-request-return-url (payment-request b "P1" :GBP "https://r"))
|
||||
"https://r")
|
||||
|
||||
;; amount tracks the ledger total, currency is per-call (provider/instance config)
|
||||
(commerce-test
|
||||
"envelope-amount-2"
|
||||
(payment-request-amount (payment-request b "P2" :EUR "x"))
|
||||
4500)
|
||||
(commerce-test
|
||||
"envelope-currency-2"
|
||||
(payment-request-currency (payment-request b "P2" :EUR "x"))
|
||||
:EUR)
|
||||
@@ -1,100 +0,0 @@
|
||||
;; lib/commerce/tests/price.sx — subtotal + jurisdiction-relational tax.
|
||||
;; Uses (commerce-test name got expected) provided by conformance.sh.
|
||||
|
||||
(define
|
||||
pcat
|
||||
(make-catalog
|
||||
(list
|
||||
(list "widget" 1000 :standard)
|
||||
(list "book" 800 :zero-rated)
|
||||
(list "tea" 1000 :reduced))
|
||||
(list
|
||||
(list "widget" :small -200)
|
||||
(list "widget" :large 500))
|
||||
(list)))
|
||||
|
||||
(define
|
||||
rules
|
||||
(list
|
||||
(list :uk :standard :guest 2000)
|
||||
(list :uk :reduced :guest 500)
|
||||
(list :uk :zero-rated :guest 0)
|
||||
(list :uk :standard :member 1000)
|
||||
(list :ie :standard :guest 2300)))
|
||||
|
||||
(define gctx (make-pricing-context pcat rules :uk :guest))
|
||||
(define mctx (make-pricing-context pcat rules :uk :member))
|
||||
|
||||
;; --- unit + line pricing ---
|
||||
|
||||
(commerce-test
|
||||
"unit-price-variant"
|
||||
(line-unit-price pcat "widget" :small)
|
||||
800)
|
||||
(commerce-test
|
||||
"unit-price-no-variant"
|
||||
(line-unit-price pcat "widget" :none)
|
||||
1000)
|
||||
(commerce-test "unit-price-unknown" (line-unit-price pcat "ghost" :none) nil)
|
||||
(commerce-test
|
||||
"line-extended"
|
||||
(line-extended pcat (list "widget" :small 2))
|
||||
1600)
|
||||
|
||||
;; --- subtotal ---
|
||||
|
||||
(define
|
||||
cart1
|
||||
(list (list "widget" :small 2) (list "book" :none 1)))
|
||||
|
||||
(commerce-test "subtotal" (cart-subtotal pcat cart1) 2400)
|
||||
(commerce-test "subtotal-empty" (cart-subtotal pcat empty-cart) 0)
|
||||
|
||||
;; --- tax rate lookup (relational, both directions) ---
|
||||
|
||||
(commerce-test
|
||||
"rate-forward"
|
||||
(rate-bps rules :uk :standard :guest)
|
||||
2000)
|
||||
(commerce-test
|
||||
"rate-missing"
|
||||
(rate-bps rules :fr :standard :guest)
|
||||
0)
|
||||
(commerce-test
|
||||
"rate-juris-by-bps-backward"
|
||||
(run* j (fresh (cust) (taxo rules j :standard cust 2300)))
|
||||
(list :ie))
|
||||
(commerce-test
|
||||
"rate-customer-by-bps-backward"
|
||||
(run* cust (taxo rules :uk :standard cust 1000))
|
||||
(list :member))
|
||||
|
||||
;; --- apply-bps rounding (half up, integer only) ---
|
||||
|
||||
(commerce-test "bps-exact" (apply-bps 1600 2000) 320)
|
||||
(commerce-test "bps-round-up" (apply-bps 799 2000) 160)
|
||||
(commerce-test "bps-zero" (apply-bps 800 0) 0)
|
||||
|
||||
;; --- line + cart tax ---
|
||||
|
||||
(commerce-test
|
||||
"line-tax-standard"
|
||||
(line-tax gctx (list "widget" :small 2))
|
||||
320)
|
||||
(commerce-test
|
||||
"line-tax-zero-rated"
|
||||
(line-tax gctx (list "book" :none 1))
|
||||
0)
|
||||
(commerce-test
|
||||
"line-tax-member"
|
||||
(line-tax mctx (list "widget" :small 2))
|
||||
160)
|
||||
(commerce-test "cart-tax-guest" (cart-tax gctx cart1) 320)
|
||||
|
||||
;; --- total dict (deterministic) ---
|
||||
|
||||
(commerce-test "total-guest" (cart-total gctx cart1) {:subtotal 2400 :discounts 0 :total 2720 :tax 320})
|
||||
|
||||
(commerce-test "total-member" (cart-total mctx cart1) {:subtotal 2400 :discounts 0 :total 2560 :tax 160})
|
||||
|
||||
(commerce-test "total-empty" (cart-total gctx empty-cart) {:subtotal 0 :discounts 0 :total 0 :tax 0})
|
||||
@@ -1,142 +0,0 @@
|
||||
;; lib/commerce/tests/promo.sx — promo rules + relational enumeration.
|
||||
;; Uses (commerce-test name got expected) provided by conformance.sh.
|
||||
|
||||
(define
|
||||
pcat
|
||||
(make-catalog
|
||||
(list
|
||||
(list "widget" 1000 :standard)
|
||||
(list "book" 800 :zero-rated)
|
||||
(list "tea" 1000 :reduced))
|
||||
(list)
|
||||
(list)))
|
||||
|
||||
(define gctx (make-pricing-context pcat (list) :uk :guest))
|
||||
(define mctx (make-pricing-context pcat (list) :uk :member))
|
||||
|
||||
(define
|
||||
cart
|
||||
(list
|
||||
(list "widget" :none 3)
|
||||
(list "book" :none 1)
|
||||
(list "tea" :none 6)))
|
||||
|
||||
(define
|
||||
ruleset
|
||||
(list
|
||||
(list :percent "TEN" :standard 1000)
|
||||
(list :fixed "FIVER" 5000 500)
|
||||
(list :bundle "B3T" "tea" 3)
|
||||
(list :member "MEM" :standard 1500)))
|
||||
|
||||
;; --- per-type amounts ---
|
||||
|
||||
(commerce-test
|
||||
"percent-amount"
|
||||
(promo-amount gctx cart (list :percent "TEN" :standard 1000))
|
||||
300)
|
||||
|
||||
(commerce-test
|
||||
"fixed-amount-met"
|
||||
(promo-amount gctx cart (list :fixed "FIVER" 5000 500))
|
||||
500)
|
||||
|
||||
(commerce-test
|
||||
"fixed-amount-not-met"
|
||||
(promo-amount
|
||||
gctx
|
||||
(list (list "widget" :none 1))
|
||||
(list :fixed "FIVER" 5000 500))
|
||||
0)
|
||||
|
||||
(commerce-test
|
||||
"fixed-amount-capped"
|
||||
(promo-amount
|
||||
gctx
|
||||
(list (list "book" :none 1))
|
||||
(list :fixed "BIG" 0 9999))
|
||||
800)
|
||||
|
||||
(commerce-test
|
||||
"bundle-amount"
|
||||
(promo-amount gctx cart (list :bundle "B3T" "tea" 3))
|
||||
2000)
|
||||
|
||||
(commerce-test
|
||||
"member-amount-guest"
|
||||
(promo-amount gctx cart (list :member "MEM" :standard 1500))
|
||||
0)
|
||||
|
||||
(commerce-test
|
||||
"member-amount-member"
|
||||
(promo-amount mctx cart (list :member "MEM" :standard 1500))
|
||||
450)
|
||||
|
||||
;; --- relational enumeration: forward ---
|
||||
|
||||
(commerce-test
|
||||
"discounto-all-guest"
|
||||
(run*
|
||||
pair
|
||||
(fresh
|
||||
(code amount)
|
||||
(promo-discounto gctx cart ruleset code amount)
|
||||
(== pair (list code amount))))
|
||||
(list
|
||||
(list "TEN" 300)
|
||||
(list "FIVER" 500)
|
||||
(list "B3T" 2000)
|
||||
(list "MEM" 0)))
|
||||
|
||||
(commerce-test
|
||||
"applicable-guest"
|
||||
(applicable-promos gctx cart ruleset)
|
||||
(list
|
||||
(list "TEN" 300)
|
||||
(list "FIVER" 500)
|
||||
(list "B3T" 2000)))
|
||||
|
||||
(commerce-test
|
||||
"applicable-member"
|
||||
(applicable-promos mctx cart ruleset)
|
||||
(list
|
||||
(list "TEN" 300)
|
||||
(list "FIVER" 500)
|
||||
(list "B3T" 2000)
|
||||
(list "MEM" 450)))
|
||||
|
||||
;; --- relational enumeration: backward (the showcase) ---
|
||||
|
||||
(commerce-test
|
||||
"code-by-discount-2000"
|
||||
(run* code (promo-applieso gctx cart ruleset code 2000))
|
||||
(list "B3T"))
|
||||
|
||||
(commerce-test
|
||||
"code-by-discount-500"
|
||||
(run* code (promo-applieso gctx cart ruleset code 500))
|
||||
(list "FIVER"))
|
||||
|
||||
(commerce-test
|
||||
"code-by-discount-none"
|
||||
(run* code (promo-applieso gctx cart ruleset code 9999))
|
||||
(list))
|
||||
|
||||
;; --- deterministic helpers ---
|
||||
|
||||
(commerce-test
|
||||
"amount-for-ten"
|
||||
(promo-amount-for gctx cart ruleset "TEN")
|
||||
300)
|
||||
(commerce-test
|
||||
"amount-for-mem-guest"
|
||||
(promo-amount-for gctx cart ruleset "MEM")
|
||||
0)
|
||||
(commerce-test
|
||||
"amount-for-mem-member"
|
||||
(promo-amount-for mctx cart ruleset "MEM")
|
||||
450)
|
||||
(commerce-test
|
||||
"amount-for-absent"
|
||||
(promo-amount-for gctx cart ruleset "NOPE")
|
||||
0)
|
||||
@@ -1,108 +0,0 @@
|
||||
;; lib/commerce/tests/quote.sx — composed priced quote (price+promo+stacking).
|
||||
;; Uses (commerce-test name got expected) provided by conformance.sh.
|
||||
|
||||
(define
|
||||
pcat
|
||||
(make-catalog
|
||||
(list
|
||||
(list "widget" 1000 :standard)
|
||||
(list "book" 800 :zero-rated)
|
||||
(list "tea" 1000 :reduced))
|
||||
(list)
|
||||
(list)))
|
||||
|
||||
(define
|
||||
tax-rules
|
||||
(list
|
||||
(list :uk :standard :guest 2000)
|
||||
(list :uk :reduced :guest 500)
|
||||
(list :uk :zero-rated :guest 0)
|
||||
(list :uk :standard :member 2000)
|
||||
(list :uk :reduced :member 500)
|
||||
(list :uk :zero-rated :member 0)))
|
||||
|
||||
(define gctx (make-pricing-context pcat tax-rules :uk :guest))
|
||||
(define mctx (make-pricing-context pcat tax-rules :uk :member))
|
||||
|
||||
(define
|
||||
cart
|
||||
(list
|
||||
(list "widget" :none 3)
|
||||
(list "book" :none 1)
|
||||
(list "tea" :none 6)))
|
||||
|
||||
(define
|
||||
ruleset
|
||||
(list
|
||||
(list :percent "TEN" :standard 1000)
|
||||
(list :percent "TWENTY" :standard 2000)
|
||||
(list :fixed "FIVER" 5000 500)
|
||||
(list :bundle "B3T" "tea" 3)
|
||||
(list :member "MEM" :standard 2500)))
|
||||
|
||||
(define
|
||||
exclusions
|
||||
(list (list "TEN" "TWENTY") (list "TEN" "MEM") (list "TWENTY" "MEM")))
|
||||
|
||||
;; subtotal: 3000 + 800 + 6000 = 9800
|
||||
;; tax (gross): widget 600 + tea 300 + book 0 = 900
|
||||
;; guest discount: TWENTY 600 + FIVER 500 + B3T 2000 = 3100
|
||||
;; guest total: 9800 - 3100 + 900 = 7600
|
||||
|
||||
(define gq (cart-quote gctx cart ruleset exclusions))
|
||||
|
||||
(commerce-test "quote-subtotal" (quote-subtotal gq) 9800)
|
||||
(commerce-test "quote-tax" (quote-tax gq) 900)
|
||||
(commerce-test "quote-discount-guest" (quote-discount gq) 3100)
|
||||
(commerce-test "quote-total-guest" (quote-total gq) 7600)
|
||||
(commerce-test
|
||||
"quote-codes-guest"
|
||||
(quote-codes gq)
|
||||
(list "TWENTY" "FIVER" "B3T"))
|
||||
|
||||
(commerce-test "quote-full-guest" gq {:codes (list "TWENTY" "FIVER" "B3T") :subtotal 9800 :discount 3100 :total 7600 :tax 900})
|
||||
|
||||
;; member discount: MEM 750 + FIVER 500 + B3T 2000 = 3250
|
||||
;; member total: 9800 - 3250 + 900 = 7450
|
||||
(define mq (cart-quote mctx cart ruleset exclusions))
|
||||
|
||||
(commerce-test "quote-discount-member" (quote-discount mq) 3250)
|
||||
(commerce-test "quote-total-member" (quote-total mq) 7450)
|
||||
(commerce-test
|
||||
"quote-codes-member"
|
||||
(quote-codes mq)
|
||||
(list "FIVER" "B3T" "MEM"))
|
||||
|
||||
;; --- determinism: same inputs, identical quote ---
|
||||
|
||||
(commerce-test
|
||||
"quote-deterministic"
|
||||
(=
|
||||
(cart-quote gctx cart ruleset exclusions)
|
||||
(cart-quote gctx cart ruleset exclusions))
|
||||
true)
|
||||
|
||||
;; --- no promos: discount 0, total = subtotal + tax ---
|
||||
|
||||
(commerce-test
|
||||
"quote-no-promos"
|
||||
(cart-quote gctx cart (list) (list))
|
||||
{:codes (list) :subtotal 9800 :discount 0 :total 10700 :tax 900})
|
||||
|
||||
;; --- empty cart ---
|
||||
|
||||
(commerce-test
|
||||
"quote-empty"
|
||||
(cart-quote gctx empty-cart ruleset exclusions)
|
||||
{:codes (list) :subtotal 0 :discount 0 :total 0 :tax 0})
|
||||
|
||||
;; --- session convenience ---
|
||||
|
||||
(define
|
||||
sess
|
||||
(commerce-add (commerce-session gctx) "widget" :none 3))
|
||||
|
||||
(commerce-test
|
||||
"session-quote"
|
||||
(quote-total (session-quote sess ruleset exclusions))
|
||||
3000)
|
||||
@@ -1,109 +0,0 @@
|
||||
;; lib/commerce/tests/recon.sx — reconciliation as relational ledger queries.
|
||||
;; Uses (commerce-test name got expected) provided by conformance.sh.
|
||||
|
||||
(define q1 {:codes (list) :subtotal 1000 :discount 0 :total 1200 :tax 200})
|
||||
|
||||
(define b (persist/mem-backend))
|
||||
|
||||
;; OK1 — clean payment
|
||||
(define _ok (order-create b "OK1" 1 q1))
|
||||
(define _okp (order-pay b "OK1" "ok-ref" 2 1200))
|
||||
|
||||
;; OVER1 — double charge under two different refs
|
||||
(define _ov (order-create b "OVER1" 1 q1))
|
||||
(define _ova (order-pay b "OVER1" "ov-a" 2 1200))
|
||||
(define _ovb (order-pay b "OVER1" "ov-b" 3 1200))
|
||||
|
||||
;; UNDER1 — short payment
|
||||
(define _un (order-create b "UNDER1" 1 q1))
|
||||
(define _unp (order-pay b "UNDER1" "un-ref" 2 900))
|
||||
|
||||
;; PART1 — paid in full, then partially refunded
|
||||
(define _pa (order-create b "PART1" 1 q1))
|
||||
(define _pap (order-pay b "PART1" "pa-ref" 2 1200))
|
||||
(define _par (order-refund b "PART1" "pa-rf" 3 200))
|
||||
|
||||
;; REPLAY1 — webhook fires twice with the same ref (idempotent)
|
||||
(define _rp (order-create b "REPLAY1" 1 q1))
|
||||
(define _rpa (order-pay b "REPLAY1" "rp-ref" 2 1200))
|
||||
(define _rpb (order-pay b "REPLAY1" "rp-ref" 2 1200))
|
||||
|
||||
;; PEND1 — created, not yet paid
|
||||
(define _pe (order-create b "PEND1" 1 q1))
|
||||
|
||||
;; --- summaries ---
|
||||
|
||||
(commerce-test "summary-count" (len (ledger-summaries b)) 6)
|
||||
(commerce-test
|
||||
"summary-ok1"
|
||||
(order-summary b "order/OK1")
|
||||
(list "order/OK1" 1200 1200 0 1200 :ok))
|
||||
(commerce-test
|
||||
"summary-part1"
|
||||
(order-summary b "order/PART1")
|
||||
(list "order/PART1" 1200 1200 200 1000 :underpaid))
|
||||
|
||||
;; --- forward status query ---
|
||||
|
||||
(commerce-test
|
||||
"status-forward-ok"
|
||||
(run* st (recon-statuso (ledger-summaries b) "order/OK1" st))
|
||||
(list :ok))
|
||||
|
||||
;; --- backward status queries (the showcase) ---
|
||||
|
||||
(commerce-test
|
||||
"settled"
|
||||
(sort (settled-orders b))
|
||||
(sort (list "order/OK1" "order/REPLAY1")))
|
||||
(commerce-test "overpaid" (overpaid-orders b) (list "order/OVER1"))
|
||||
(commerce-test
|
||||
"underpaid"
|
||||
(sort (underpaid-orders b))
|
||||
(sort (list "order/UNDER1" "order/PART1")))
|
||||
(commerce-test "unpaid" (unpaid-orders b) (list "order/PEND1"))
|
||||
(commerce-test
|
||||
"mismatched"
|
||||
(sort (mismatched-orders b))
|
||||
(sort (list "order/OVER1" "order/UNDER1" "order/PART1")))
|
||||
|
||||
;; --- backward net-amount query ---
|
||||
|
||||
(commerce-test
|
||||
"net-1200"
|
||||
(sort (orders-with-net b 1200))
|
||||
(sort (list "order/OK1" "order/REPLAY1")))
|
||||
(commerce-test
|
||||
"net-2400"
|
||||
(orders-with-net b 2400)
|
||||
(list "order/OVER1"))
|
||||
(commerce-test
|
||||
"net-900"
|
||||
(orders-with-net b 900)
|
||||
(list "order/UNDER1"))
|
||||
|
||||
;; --- discrepancy: +1200 (over) - 300 (under) - 200 (refund) = 700 ---
|
||||
|
||||
(commerce-test "discrepancy" (ledger-discrepancy b) 700)
|
||||
|
||||
;; --- double-charge guard ---
|
||||
|
||||
(commerce-test "double-charge-detected" (order-recon b "OVER1") :overpaid)
|
||||
(commerce-test "double-charge-amount" (order-paid b "OVER1") 2400)
|
||||
|
||||
;; --- partial refund ---
|
||||
|
||||
(commerce-test "partial-refund-net" (order-recon b "PART1") :underpaid)
|
||||
(commerce-test
|
||||
"partial-refund-amount"
|
||||
(order-refunded-amount-of (order-events b "PART1"))
|
||||
200)
|
||||
|
||||
;; --- webhook replay: same ref twice records once ---
|
||||
|
||||
(commerce-test
|
||||
"replay-single-event"
|
||||
(len (order-events b "REPLAY1"))
|
||||
2)
|
||||
(commerce-test "replay-paid-once" (order-paid b "REPLAY1") 1200)
|
||||
(commerce-test "replay-settled" (order-recon b "REPLAY1") :ok)
|
||||
@@ -1,78 +0,0 @@
|
||||
;; lib/commerce/tests/refund.sx — refund lifecycle as a flow-on-sx flow.
|
||||
;; Uses (commerce-test name got expected) provided by conformance.sh.
|
||||
;; Builds the (expensive) flow env once; all assertions share it.
|
||||
|
||||
(define env (refund-make-env))
|
||||
(define b (persist/mem-backend))
|
||||
(define q1 {:codes (list) :subtotal 1000 :discount 0 :total 1200 :tax 200})
|
||||
|
||||
;; a paid, fulfilled order to refund (set up directly via the ledger)
|
||||
(define _c (order-create b "O1" 1 q1))
|
||||
(define _p (order-pay b "O1" "pay-1" 2 1200))
|
||||
(commerce-test "setup-recon-ok" (order-recon b "O1") :ok)
|
||||
|
||||
;; --- happy path: request -> approve -> settle ---
|
||||
|
||||
(define rid (refund-begin! env b "O1" "rf-1" 10 500))
|
||||
|
||||
(commerce-test "begin-waiting-approve" (order-flow-waiting env rid) "approve")
|
||||
(commerce-test
|
||||
"begin-not-yet-refunded"
|
||||
(order-refunded-amount-of (order-events b "O1"))
|
||||
0)
|
||||
(commerce-test "begin-recon-unchanged" (order-recon b "O1") :ok)
|
||||
|
||||
(define a1 (refund-approve! env rid))
|
||||
(commerce-test "approve-result" a1 :approved)
|
||||
(commerce-test "approve-waiting-settle" (order-flow-waiting env rid) "settle")
|
||||
|
||||
(define s1 (refund-settle! env b rid "O1" "rf-1" 11 500))
|
||||
(commerce-test "settle-result" s1 :settled)
|
||||
(commerce-test "settle-flow-done" (order-flow-status env rid) "done")
|
||||
(commerce-test
|
||||
"settle-refunded-amount"
|
||||
(order-refunded-amount-of (order-events b "O1"))
|
||||
500)
|
||||
;; net 1200 - 500 = 700 < total 1200 -> underpaid (partial refund)
|
||||
(commerce-test "settle-recon-underpaid" (order-recon b "O1") :underpaid)
|
||||
|
||||
;; --- idempotent settle: replayed provider callback is a no-op ---
|
||||
|
||||
(define s1b (refund-settle! env b rid "O1" "rf-1" 11 500))
|
||||
(commerce-test "replay-already-settled" s1b :already-settled)
|
||||
(commerce-test
|
||||
"replay-refunded-once"
|
||||
(order-refunded-amount-of (order-events b "O1"))
|
||||
500)
|
||||
|
||||
;; --- reject path: approval denied, books untouched ---
|
||||
|
||||
(define _c2 (order-create b "O2" 1 q1))
|
||||
(define _p2 (order-pay b "O2" "pay-2" 2 1200))
|
||||
|
||||
(define rid2 (refund-begin! env b "O2" "rf-2" 20 1200))
|
||||
(commerce-test
|
||||
"reject-waiting-approve"
|
||||
(order-flow-waiting env rid2)
|
||||
"approve")
|
||||
|
||||
(define j2 (refund-reject! env b "O2" rid2 21 "policy"))
|
||||
(commerce-test "reject-result" j2 :rejected)
|
||||
(commerce-test "reject-flow-not-waiting" (order-flow-waiting env rid2) nil)
|
||||
(commerce-test
|
||||
"reject-no-refund"
|
||||
(order-refunded-amount-of (order-events b "O2"))
|
||||
0)
|
||||
(commerce-test "reject-recon-ok" (order-recon b "O2") :ok)
|
||||
|
||||
;; settling a rejected/cancelled refund does nothing
|
||||
(define s2 (refund-settle! env b rid2 "O2" "rf-2" 22 1200))
|
||||
(commerce-test "reject-then-settle-noop" s2 :already-settled)
|
||||
(commerce-test
|
||||
"reject-still-no-refund"
|
||||
(order-refunded-amount-of (order-events b "O2"))
|
||||
0)
|
||||
|
||||
;; --- distinct flow ids ---
|
||||
|
||||
(commerce-test "distinct-refund-ids" (not (= rid rid2)) true)
|
||||
@@ -1,127 +0,0 @@
|
||||
;; lib/commerce/tests/stack.sx — stacking precedence, exclusivity, best price.
|
||||
;; Uses (commerce-test name got expected) provided by conformance.sh.
|
||||
|
||||
(define
|
||||
pcat
|
||||
(make-catalog
|
||||
(list
|
||||
(list "widget" 1000 :standard)
|
||||
(list "book" 800 :zero-rated)
|
||||
(list "tea" 1000 :reduced))
|
||||
(list)
|
||||
(list)))
|
||||
|
||||
(define gctx (make-pricing-context pcat (list) :uk :guest))
|
||||
(define mctx (make-pricing-context pcat (list) :uk :member))
|
||||
|
||||
(define
|
||||
cart
|
||||
(list
|
||||
(list "widget" :none 3)
|
||||
(list "book" :none 1)
|
||||
(list "tea" :none 6)))
|
||||
|
||||
(define
|
||||
ruleset
|
||||
(list
|
||||
(list :percent "TEN" :standard 1000)
|
||||
(list :percent "TWENTY" :standard 2000)
|
||||
(list :fixed "FIVER" 5000 500)
|
||||
(list :bundle "B3T" "tea" 3)
|
||||
(list :member "MEM" :standard 2500)))
|
||||
|
||||
;; The three standard-class discounts are mutually exclusive.
|
||||
(define
|
||||
exclusions
|
||||
(list (list "TEN" "TWENTY") (list "TEN" "MEM") (list "TWENTY" "MEM")))
|
||||
|
||||
;; --- exclusivity predicates ---
|
||||
|
||||
(commerce-test
|
||||
"excluded-pair-direct"
|
||||
(excluded-pair? exclusions "TEN" "TWENTY")
|
||||
true)
|
||||
(commerce-test
|
||||
"excluded-pair-symmetric"
|
||||
(excluded-pair? exclusions "TWENTY" "TEN")
|
||||
true)
|
||||
(commerce-test
|
||||
"excluded-pair-none"
|
||||
(excluded-pair? exclusions "TEN" "FIVER")
|
||||
false)
|
||||
(commerce-test
|
||||
"compatible-yes"
|
||||
(compatible? exclusions (list "FIVER" "B3T" "TWENTY"))
|
||||
true)
|
||||
(commerce-test
|
||||
"compatible-no"
|
||||
(compatible? exclusions (list "TEN" "TWENTY" "B3T"))
|
||||
false)
|
||||
|
||||
;; --- powerset + valid stackings ---
|
||||
|
||||
(commerce-test
|
||||
"powerset-size"
|
||||
(len (powerset (list 1 2 3 4)))
|
||||
16)
|
||||
|
||||
(define gappl (applicable-promos gctx cart ruleset))
|
||||
|
||||
(commerce-test "applicable-guest-count" (len gappl) 4)
|
||||
|
||||
;; 16 subsets minus the 4 containing both TEN and TWENTY = 12 legal.
|
||||
(commerce-test
|
||||
"valid-stackings-count"
|
||||
(len (valid-stackings exclusions gappl))
|
||||
12)
|
||||
|
||||
(commerce-test
|
||||
"stacking-total"
|
||||
(stacking-total (list (list "TWENTY" 600) (list "B3T" 2000)))
|
||||
2600)
|
||||
|
||||
;; --- best price (deterministic selection) ---
|
||||
|
||||
(commerce-test
|
||||
"best-discount-guest"
|
||||
(best-promo-discount gctx cart ruleset exclusions)
|
||||
3100)
|
||||
(commerce-test
|
||||
"best-codes-guest"
|
||||
(best-promo-codes gctx cart ruleset exclusions)
|
||||
(list "TWENTY" "FIVER" "B3T"))
|
||||
|
||||
;; exclusivity holds: the cheaper conflicting code is dropped.
|
||||
(commerce-test
|
||||
"best-excludes-ten"
|
||||
(some
|
||||
(fn (c) (= c "TEN"))
|
||||
(best-promo-codes gctx cart ruleset exclusions))
|
||||
false)
|
||||
|
||||
;; --- member vs guest ---
|
||||
|
||||
(commerce-test
|
||||
"best-discount-member"
|
||||
(best-promo-discount mctx cart ruleset exclusions)
|
||||
3250)
|
||||
(commerce-test
|
||||
"best-codes-member"
|
||||
(best-promo-codes mctx cart ruleset exclusions)
|
||||
(list "FIVER" "B3T" "MEM"))
|
||||
|
||||
;; --- best price backward query (the showcase) ---
|
||||
|
||||
(commerce-test
|
||||
"stacking-by-total-backward"
|
||||
(run*
|
||||
codes
|
||||
(stacking-by-totalo (valid-stackings exclusions gappl) codes 3100))
|
||||
(list (list "TWENTY" "FIVER" "B3T")))
|
||||
|
||||
;; --- edge: no applicable promos ---
|
||||
|
||||
(commerce-test
|
||||
"best-empty"
|
||||
(best-promo-discount gctx empty-cart ruleset exclusions)
|
||||
0)
|
||||
@@ -1,122 +0,0 @@
|
||||
;; lib/commerce/tests/stock.sx — stock-constrained reservation.
|
||||
;; Uses (commerce-test name got expected) provided by conformance.sh.
|
||||
|
||||
(define
|
||||
cat
|
||||
(make-catalog
|
||||
(list
|
||||
(list "widget" 1000 :standard)
|
||||
(list "gadget" 2500 :standard))
|
||||
(list)
|
||||
(list
|
||||
(list "widget" :small 5)
|
||||
(list "widget" :large 0)
|
||||
(list "gadget" :std 12))))
|
||||
|
||||
;; --- availability ---
|
||||
|
||||
(commerce-test
|
||||
"available-found"
|
||||
(available-stock cat "widget" :small)
|
||||
5)
|
||||
(commerce-test
|
||||
"available-zero"
|
||||
(available-stock cat "widget" :large)
|
||||
0)
|
||||
(commerce-test
|
||||
"available-absent"
|
||||
(available-stock cat "widget" :none)
|
||||
0)
|
||||
|
||||
;; --- per-line reservability ---
|
||||
|
||||
(commerce-test
|
||||
"shortfall-fits"
|
||||
(line-shortfall cat (list "widget" :small 5))
|
||||
0)
|
||||
(commerce-test
|
||||
"shortfall-over"
|
||||
(line-shortfall cat (list "widget" :small 8))
|
||||
3)
|
||||
(commerce-test
|
||||
"reservable-yes"
|
||||
(line-reservable? cat (list "gadget" :std 12))
|
||||
true)
|
||||
(commerce-test
|
||||
"reservable-no"
|
||||
(line-reservable? cat (list "widget" :large 1))
|
||||
false)
|
||||
|
||||
;; --- cart-level reservation check ---
|
||||
|
||||
(commerce-test
|
||||
"can-reserve-yes"
|
||||
(can-reserve?
|
||||
cat
|
||||
(list (list "widget" :small 5) (list "gadget" :std 2)))
|
||||
true)
|
||||
|
||||
(commerce-test
|
||||
"can-reserve-no"
|
||||
(can-reserve? cat (list (list "widget" :small 9)))
|
||||
false)
|
||||
|
||||
(commerce-test
|
||||
"shortfalls-detail"
|
||||
(reservation-shortfalls
|
||||
cat
|
||||
(list (list "widget" :small 9) (list "gadget" :std 2)))
|
||||
(list {:requested 9 :available 5 :sku "widget" :variant :small :short 4}))
|
||||
|
||||
(commerce-test
|
||||
"reserve-check-ok"
|
||||
(reserve-check cat (list (list "gadget" :std 1)))
|
||||
:ok)
|
||||
|
||||
(commerce-test
|
||||
"reserve-check-rejected"
|
||||
(reserve-check cat (list (list "widget" :large 1)))
|
||||
{:shortfalls (list {:requested 1 :available 0 :sku "widget" :variant :large :short 1}) :rejected :insufficient-stock})
|
||||
|
||||
;; --- reservation view: concurrent holds reduce availability ---
|
||||
|
||||
(define held (list (list "widget" :small 3)))
|
||||
|
||||
(commerce-test
|
||||
"effective-after-hold"
|
||||
(effective-available cat held "widget" :small)
|
||||
2)
|
||||
(commerce-test
|
||||
"effective-other-unaffected"
|
||||
(effective-available cat held "gadget" :std)
|
||||
12)
|
||||
(commerce-test
|
||||
"reservable-with-fits"
|
||||
(line-reservable-with? cat held (list "widget" :small 2))
|
||||
true)
|
||||
(commerce-test
|
||||
"reservable-with-over"
|
||||
(line-reservable-with? cat held (list "widget" :small 3))
|
||||
false)
|
||||
|
||||
;; --- relational availability query (multidirectional) ---
|
||||
|
||||
(commerce-test
|
||||
"sufficient-forward"
|
||||
(run*
|
||||
x
|
||||
(fresh () (sufficient-stocko cat "widget" :small 5) (== x true)))
|
||||
(list true))
|
||||
|
||||
(commerce-test
|
||||
"sufficient-forward-over"
|
||||
(run*
|
||||
x
|
||||
(fresh () (sufficient-stocko cat "widget" :small 6) (== x true)))
|
||||
(list))
|
||||
|
||||
;; backward: which variants of widget can supply 1 unit?
|
||||
(commerce-test
|
||||
"variants-supplying-1"
|
||||
(run* v (fresh (q) (stocko cat "widget" v q) (lteo-i 1 q)))
|
||||
(list :small))
|
||||
@@ -1,112 +0,0 @@
|
||||
;; lib/commerce/tests/window.sx — time-windowed promotions.
|
||||
;; Uses (commerce-test name got expected) provided by conformance.sh.
|
||||
|
||||
(define
|
||||
pcat
|
||||
(make-catalog (list (list "widget" 1000 :standard)) (list) (list)))
|
||||
|
||||
(define gctx (make-pricing-context pcat (list) :uk :guest))
|
||||
(define cart (list (list "widget" :none 3)))
|
||||
|
||||
(define ten (list :percent "TEN" :standard 1000))
|
||||
(define twenty (list :percent "TWENTY" :standard 2000))
|
||||
(define always (list :fixed "ALWAYS" 0 100))
|
||||
|
||||
(define
|
||||
windowed
|
||||
(list
|
||||
(windowed-promo ten 100 200)
|
||||
(windowed-promo twenty 150 300)
|
||||
(windowed-promo always nil nil)))
|
||||
|
||||
(define exclusions (list (list "TEN" "TWENTY")))
|
||||
|
||||
;; --- wp-active? boundaries (inclusive) ---
|
||||
|
||||
(commerce-test
|
||||
"active-at-from"
|
||||
(wp-active? (windowed-promo ten 100 200) 100)
|
||||
true)
|
||||
(commerce-test
|
||||
"active-at-until"
|
||||
(wp-active? (windowed-promo ten 100 200) 200)
|
||||
true)
|
||||
(commerce-test
|
||||
"inactive-before"
|
||||
(wp-active? (windowed-promo ten 100 200) 99)
|
||||
false)
|
||||
(commerce-test
|
||||
"inactive-after"
|
||||
(wp-active? (windowed-promo ten 100 200) 201)
|
||||
false)
|
||||
(commerce-test
|
||||
"open-ended-always"
|
||||
(wp-active? (windowed-promo always nil nil) 99999)
|
||||
true)
|
||||
(commerce-test
|
||||
"open-lower"
|
||||
(wp-active? (windowed-promo ten nil 200) 1)
|
||||
true)
|
||||
(commerce-test
|
||||
"open-upper"
|
||||
(wp-active? (windowed-promo ten 100 nil) 99999)
|
||||
true)
|
||||
|
||||
;; --- active-ruleset filtering ---
|
||||
|
||||
(commerce-test
|
||||
"active-ruleset-120"
|
||||
(active-ruleset windowed 120)
|
||||
(list ten always))
|
||||
(commerce-test
|
||||
"active-ruleset-160"
|
||||
(active-ruleset windowed 160)
|
||||
(list ten twenty always))
|
||||
(commerce-test
|
||||
"active-ruleset-250"
|
||||
(active-ruleset windowed 250)
|
||||
(list twenty always))
|
||||
(commerce-test
|
||||
"active-ruleset-50"
|
||||
(active-ruleset windowed 50)
|
||||
(list always))
|
||||
|
||||
;; --- active-codes (backward query) ---
|
||||
|
||||
(commerce-test
|
||||
"active-codes-120"
|
||||
(active-codes windowed 120)
|
||||
(list "TEN" "ALWAYS"))
|
||||
(commerce-test
|
||||
"active-codes-160"
|
||||
(active-codes windowed 160)
|
||||
(list "TEN" "TWENTY" "ALWAYS"))
|
||||
(commerce-test
|
||||
"active-codes-50"
|
||||
(active-codes windowed 50)
|
||||
(list "ALWAYS"))
|
||||
|
||||
;; --- windowed-quote: discount changes with time (deterministic) ---
|
||||
;; subtotal 3000, no tax. TEN=300, TWENTY=600, ALWAYS=100; TEN/TWENTY exclusive.
|
||||
|
||||
(commerce-test
|
||||
"quote-50"
|
||||
(quote-discount (windowed-quote gctx cart windowed exclusions 50))
|
||||
100)
|
||||
(commerce-test
|
||||
"quote-120"
|
||||
(quote-discount (windowed-quote gctx cart windowed exclusions 120))
|
||||
400)
|
||||
(commerce-test
|
||||
"quote-160"
|
||||
(quote-discount (windowed-quote gctx cart windowed exclusions 160))
|
||||
700)
|
||||
(commerce-test
|
||||
"quote-250"
|
||||
(quote-discount (windowed-quote gctx cart windowed exclusions 250))
|
||||
700)
|
||||
|
||||
(commerce-test
|
||||
"quote-total-160"
|
||||
(quote-total (windowed-quote gctx cart windowed exclusions 160))
|
||||
2300)
|
||||
@@ -1,55 +0,0 @@
|
||||
;; lib/commerce/window.sx — time-windowed promotions.
|
||||
;;
|
||||
;; A promo's validity window is kept SEPARATE from the promo tuple (so promo.sx
|
||||
;; is untouched): a windowed promo is (list promo from until) with inclusive
|
||||
;; integer timestamps (same time model as the ledger `at`). nil from = no lower
|
||||
;; bound; nil until = open-ended.
|
||||
;;
|
||||
;; `active-ruleset` filters a windowed ruleset to the plain promos live at a
|
||||
;; given time, which feeds straight into promo/stack/quote — so a datetime-aware
|
||||
;; quote is just the existing pipeline over the active set. Deterministic: the
|
||||
;; quote is a pure function of (ctx, cart, windowed-ruleset, exclusions, at).
|
||||
|
||||
(define windowed-promo (fn (promo from until) (list promo from until)))
|
||||
|
||||
(define wp-promo (fn (wp) (nth wp 0)))
|
||||
(define wp-from (fn (wp) (nth wp 1)))
|
||||
(define wp-until (fn (wp) (nth wp 2)))
|
||||
|
||||
(define
|
||||
wp-active?
|
||||
(fn
|
||||
(wp at)
|
||||
(let
|
||||
((from (wp-from wp)) (until (wp-until wp)))
|
||||
(and (or (nil? from) (>= at from)) (or (nil? until) (<= at until))))))
|
||||
|
||||
;; Plain promo tuples live at time `at` — feed into cart-quote / best-promo-*.
|
||||
(define
|
||||
active-ruleset
|
||||
(fn
|
||||
(windowed at)
|
||||
(map wp-promo (filter (fn (wp) (wp-active? wp at)) windowed))))
|
||||
|
||||
;; Relation: which promo codes are active at `at`? (backward query)
|
||||
(define
|
||||
active-promoo
|
||||
(fn
|
||||
(windowed at code)
|
||||
(fresh
|
||||
(wp)
|
||||
(membero wp windowed)
|
||||
(project
|
||||
(wp)
|
||||
(if (wp-active? wp at) (== code (promo-code (wp-promo wp))) fail)))))
|
||||
|
||||
(define
|
||||
active-codes
|
||||
(fn (windowed at) (run* code (active-promoo windowed at code))))
|
||||
|
||||
;; Datetime-aware quote: the existing pipeline over the time-active ruleset.
|
||||
(define
|
||||
windowed-quote
|
||||
(fn
|
||||
(ctx cart windowed exclusions at)
|
||||
(cart-quote ctx cart (active-ruleset windowed at) exclusions)))
|
||||
36
lib/identity/api.sx
Normal file
36
lib/identity/api.sx
Normal file
File diff suppressed because one or more lines are too long
27
lib/identity/audit.sx
Normal file
27
lib/identity/audit.sx
Normal file
@@ -0,0 +1,27 @@
|
||||
;; identity/audit.sx — the grant audit ledger.
|
||||
;;
|
||||
;; Every transition that changes a grant — issue, refresh, revoke (and,
|
||||
;; wired from oauth, consent) — appends an immutable event to this
|
||||
;; append-only process. The ledger is queryable by subject, which is what
|
||||
;; `(identity/audit subject)` answers. This is the in-memory realisation
|
||||
;; of the event stream; a persist-backed stream is a later substrate
|
||||
;; concern (Erlang↔persist bridge), kept out of scope here per the loop's
|
||||
;; \"in-memory log until persist lands\" allowance — the queryable
|
||||
;; semantics are identical.
|
||||
;;
|
||||
;; Events are {Seq, Subject, Action}; Seq is a monotonic sequence number.
|
||||
;; Reads return chronological (oldest-first) order:
|
||||
;;
|
||||
;; record(A, Subject, Action) -> ok (one-way; FIFO-ordered)
|
||||
;; audit(A, Subject) -> [{Seq, Subject, Action}, ...]
|
||||
;; actions(A, Subject) -> [Action, ...]
|
||||
;; count(A, Subject) -> N
|
||||
;; all(A) -> [{Seq, Subject, Action}, ...]
|
||||
|
||||
(define
|
||||
identity-audit-source
|
||||
"-module(identity_audit).\n\n start() ->\n spawn(fun () -> loop([], 0) end).\n\n record(A, Subject, Action) ->\n A ! {event, Subject, Action},\n ok.\n\n audit(A, Subject) ->\n A ! {audit, Subject, self()},\n receive {audit_reply, R} -> R end.\n\n actions(A, Subject) ->\n A ! {actions, Subject, self()},\n receive {audit_reply, R} -> R end.\n\n count(A, Subject) ->\n A ! {count, Subject, self()},\n receive {audit_reply, R} -> R end.\n\n all(A) ->\n A ! {all, self()},\n receive {audit_reply, R} -> R end.\n\n loop(Events, Seq) ->\n receive\n {event, Subject, Action} ->\n loop([{Seq, Subject, Action} | Events], Seq + 1);\n {audit, Subject, From} ->\n From ! {audit_reply, collect(Subject, Events, [])},\n loop(Events, Seq);\n {actions, Subject, From} ->\n From ! {audit_reply, action_list(Subject, Events, [])},\n loop(Events, Seq);\n {count, Subject, From} ->\n From ! {audit_reply, count_subj(Subject, Events, 0)},\n loop(Events, Seq);\n {all, From} ->\n From ! {audit_reply, reverse(Events, [])},\n loop(Events, Seq);\n {stop, From} ->\n From ! {audit_reply, ok}\n end.\n\n collect(_, [], Acc) -> Acc;\n collect(Subject, [{Seq, S, A} | Rest], Acc) ->\n case S =:= Subject of\n true -> collect(Subject, Rest, [{Seq, S, A} | Acc]);\n false -> collect(Subject, Rest, Acc)\n end.\n\n action_list(_, [], Acc) -> Acc;\n action_list(Subject, [{_, S, A} | Rest], Acc) ->\n case S =:= Subject of\n true -> action_list(Subject, Rest, [A | Acc]);\n false -> action_list(Subject, Rest, Acc)\n end.\n\n count_subj(_, [], N) -> N;\n count_subj(Subject, [{_, S, _} | Rest], N) ->\n case S =:= Subject of\n true -> count_subj(Subject, Rest, N + 1);\n false -> count_subj(Subject, Rest, N)\n end.\n\n reverse([], Acc) -> Acc;\n reverse([H | T], Acc) -> reverse(T, [H | Acc]).")
|
||||
|
||||
(define
|
||||
identity-load-audit!
|
||||
(fn () (erlang-load-module identity-audit-source)))
|
||||
29
lib/identity/cache.sx
Normal file
29
lib/identity/cache.sx
Normal file
@@ -0,0 +1,29 @@
|
||||
;; identity/cache.sx — a delegated grant-verification cache, mirroring the
|
||||
;; Redis-cache pattern apps use in front of grant verification.
|
||||
;;
|
||||
;; The cache is a process wrapping a token registry. introspect() is
|
||||
;; memoised; issue/issue_grant/refresh/revoke pass through. The danger
|
||||
;; with any cache is staleness: a revoked token must NOT keep reading
|
||||
;; valid out of the cache, not even for a millisecond (the loop's hard
|
||||
;; rule). We get that for free with GENERATION invalidation:
|
||||
;;
|
||||
;; - each cache entry records the generation it was written at;
|
||||
;; - a hit requires entry.generation == current generation;
|
||||
;; - any state-changing op that can invalidate an existing token
|
||||
;; (revoke — which cascades to a grant; refresh — whose reuse cascades)
|
||||
;; bumps the generation.
|
||||
;;
|
||||
;; So a single revoke instantly invalidates every cached positive: the
|
||||
;; next introspect is a miss and re-validates against the live registry,
|
||||
;; which returns {inactive}. Revocation stays real; the cache only ever
|
||||
;; accelerates the steady state, never overrides a revocation.
|
||||
;;
|
||||
;; stats() -> {Hits, Misses} so callers can see the cache is live.
|
||||
|
||||
(define
|
||||
identity-cache-source
|
||||
"-module(identity_grant_cache).\n\n start() ->\n spawn(fun () ->\n Reg = identity_tokens:start(),\n loop(Reg, 1, [], 0, 0)\n end).\n\n issue(C, Subject, Client, Scope) ->\n C ! {issue, Subject, Client, Scope, self()},\n receive {cache_reply, R} -> R end.\n\n issue_grant(C, Subject, Client, Scope) ->\n C ! {issue_grant, Subject, Client, Scope, self()},\n receive {cache_reply, R} -> R end.\n\n refresh(C, RefreshTok) ->\n C ! {refresh, RefreshTok, self()},\n receive {cache_reply, R} -> R end.\n\n introspect(C, Token) ->\n C ! {introspect, Token, self()},\n receive {cache_reply, R} -> R end.\n\n revoke(C, Token) ->\n C ! {revoke, Token, self()},\n receive {cache_reply, R} -> R end.\n\n stats(C) ->\n C ! {stats, self()},\n receive {cache_reply, R} -> R end.\n\n loop(Reg, Gen, Entries, Hits, Misses) ->\n receive\n {introspect, Tok, From} ->\n case lookup_fresh(Tok, Gen, Entries) of\n {hit, Result} ->\n From ! {cache_reply, Result},\n loop(Reg, Gen, Entries, Hits + 1, Misses);\n miss ->\n Result = identity_tokens:introspect(Reg, Tok),\n From ! {cache_reply, Result},\n loop(Reg, Gen, put_entry(Tok, Result, Gen, Entries), Hits, Misses + 1)\n end;\n {issue, Subject, Client, Scope, From} ->\n From ! {cache_reply, identity_tokens:issue(Reg, Subject, Client, Scope)},\n loop(Reg, Gen, Entries, Hits, Misses);\n {issue_grant, Subject, Client, Scope, From} ->\n From ! {cache_reply, identity_tokens:issue_grant(Reg, Subject, Client, Scope)},\n loop(Reg, Gen, Entries, Hits, Misses);\n {refresh, RTok, From} ->\n From ! {cache_reply, identity_tokens:refresh(Reg, RTok)},\n loop(Reg, Gen + 1, Entries, Hits, Misses);\n {revoke, Tok, From} ->\n identity_tokens:revoke(Reg, Tok),\n From ! {cache_reply, ok},\n loop(Reg, Gen + 1, Entries, Hits, Misses);\n {stats, From} ->\n From ! {cache_reply, {Hits, Misses}},\n loop(Reg, Gen, Entries, Hits, Misses)\n end.\n\n lookup_fresh(_, _, []) -> miss;\n lookup_fresh(Tok, Gen, [{T, {Result, G}} | Rest]) ->\n case T =:= Tok of\n true ->\n case G =:= Gen of\n true -> {hit, Result};\n false -> miss\n end;\n false -> lookup_fresh(Tok, Gen, Rest)\n end.\n\n put_entry(Tok, Result, Gen, Entries) ->\n [{Tok, {Result, Gen}} | remove(Tok, Entries)].\n\n remove(_, []) -> [];\n remove(Tok, [{T, V} | Rest]) ->\n case T =:= Tok of\n true -> remove(Tok, Rest);\n false -> [{T, V} | remove(Tok, Rest)]\n end.")
|
||||
|
||||
(define
|
||||
identity-load-cache!
|
||||
(fn () (erlang-load-module identity-cache-source)))
|
||||
28
lib/identity/clients.sx
Normal file
28
lib/identity/clients.sx
Normal file
@@ -0,0 +1,28 @@
|
||||
;; identity/clients.sx — the OAuth client registry (RFC 6749 §2).
|
||||
;;
|
||||
;; A client is registered with a type, a secret, and its allow-listed
|
||||
;; redirect_uris:
|
||||
;;
|
||||
;; public — cannot keep a secret (SPAs, native apps, §2.1);
|
||||
;; identified but not authenticated.
|
||||
;; confidential — can authenticate; MUST present its secret at the token
|
||||
;; endpoint (§3.2.1, §4.1.3). A wrong secret is
|
||||
;; invalid_client — never a soft pass.
|
||||
;;
|
||||
;; Redirect URIs must be pre-registered (§3.1.2.2 + OAuth Security BCP):
|
||||
;; valid_redirect/3 is the exact-match check the authorize/exchange steps
|
||||
;; consult so an attacker cannot redirect the code to an unregistered URI.
|
||||
;;
|
||||
;; register(C, ClientId, Type, Secret, RedirectUris) -> ok | {error, exists}
|
||||
;; lookup(C, ClientId) -> {ok, Type, RedirectUris} | {error, unknown_client}
|
||||
;; authenticate(C, ClientId, Sec) -> {ok, public} | {ok, confidential}
|
||||
;; | {error, invalid_client} | {error, unknown_client}
|
||||
;; valid_redirect(C, ClientId, U) -> true | false
|
||||
|
||||
(define
|
||||
identity-clients-source
|
||||
"-module(identity_clients).\n\n start() ->\n spawn(fun () -> loop([]) end).\n\n register(C, ClientId, Type, Secret, RedirectUris) ->\n C ! {register, ClientId, Type, Secret, RedirectUris, self()},\n receive {client_reply, R} -> R end.\n\n lookup(C, ClientId) ->\n C ! {lookup, ClientId, self()},\n receive {client_reply, R} -> R end.\n\n authenticate(C, ClientId, Secret) ->\n C ! {authenticate, ClientId, Secret, self()},\n receive {client_reply, R} -> R end.\n\n valid_redirect(C, ClientId, Uri) ->\n C ! {valid_redirect, ClientId, Uri, self()},\n receive {client_reply, R} -> R end.\n\n loop(Clients) ->\n receive\n {register, ClientId, Type, Secret, RedirectUris, From} ->\n case find(ClientId, Clients) of\n {ok, _} ->\n From ! {client_reply, {error, exists}},\n loop(Clients);\n none ->\n From ! {client_reply, ok},\n loop([{ClientId, {Type, Secret, RedirectUris}} | Clients])\n end;\n {lookup, ClientId, From} ->\n case find(ClientId, Clients) of\n none -> From ! {client_reply, {error, unknown_client}};\n {ok, {Type, _, Uris}} -> From ! {client_reply, {ok, Type, Uris}}\n end,\n loop(Clients);\n {authenticate, ClientId, Secret, From} ->\n case find(ClientId, Clients) of\n none ->\n From ! {client_reply, {error, unknown_client}};\n {ok, {public, _, _}} ->\n From ! {client_reply, {ok, public}};\n {ok, {confidential, S, _}} ->\n case S =:= Secret of\n true -> From ! {client_reply, {ok, confidential}};\n false -> From ! {client_reply, {error, invalid_client}}\n end\n end,\n loop(Clients);\n {valid_redirect, ClientId, Uri, From} ->\n case find(ClientId, Clients) of\n none -> From ! {client_reply, false};\n {ok, {_, _, Uris}} -> From ! {client_reply, member(Uri, Uris)}\n end,\n loop(Clients);\n {stop, From} ->\n From ! {client_reply, ok}\n end.\n\n member(_, []) -> false;\n member(X, [Y | Rest]) ->\n case X =:= Y of\n true -> true;\n false -> member(X, Rest)\n end.\n\n find(_, []) -> none;\n find(Key, [{K, V} | Rest]) ->\n case K =:= Key of\n true -> {ok, V};\n false -> find(Key, Rest)\n end.")
|
||||
|
||||
(define
|
||||
identity-load-clients!
|
||||
(fn () (erlang-load-module identity-clients-source)))
|
||||
215
lib/identity/conformance.sh
Executable file
215
lib/identity/conformance.sh
Executable file
@@ -0,0 +1,215 @@
|
||||
#!/usr/bin/env bash
|
||||
# identity-on-sx conformance runner.
|
||||
#
|
||||
# Loads the Erlang-on-SX substrate, the identity library, and every
|
||||
# identity test suite via the epoch protocol, collects pass/fail counts,
|
||||
# and writes lib/identity/scoreboard.json + .md.
|
||||
#
|
||||
# Usage:
|
||||
# bash lib/identity/conformance.sh # run all suites
|
||||
# bash lib/identity/conformance.sh -v # verbose per-suite
|
||||
|
||||
set -uo pipefail
|
||||
cd "$(git rev-parse --show-toplevel)"
|
||||
|
||||
SX_SERVER="${SX_SERVER:-hosts/ocaml/_build/default/bin/sx_server.exe}"
|
||||
if [ ! -x "$SX_SERVER" ]; then
|
||||
SX_SERVER="/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe"
|
||||
fi
|
||||
if [ ! -x "$SX_SERVER" ]; then
|
||||
echo "ERROR: sx_server.exe not found." >&2
|
||||
exit 1
|
||||
fi
|
||||
|
||||
VERBOSE="${1:-}"
|
||||
TMPFILE=$(mktemp)
|
||||
OUTFILE=$(mktemp)
|
||||
trap "rm -f $TMPFILE $OUTFILE" EXIT
|
||||
|
||||
# Each suite: name | counter pass | counter total
|
||||
SUITES=(
|
||||
"session|id-session-test-pass|id-session-test-count"
|
||||
"token|id-token-test-pass|id-token-test-count"
|
||||
"registry|id-registry-test-pass|id-registry-test-count"
|
||||
"api|id-api-test-pass|id-api-test-count"
|
||||
"oauth|id-oauth-test-pass|id-oauth-test-count"
|
||||
"sso|id-sso-test-pass|id-sso-test-count"
|
||||
"membership|id-membership-test-pass|id-membership-test-count"
|
||||
"cache|id-cache-test-pass|id-cache-test-count"
|
||||
"audit|id-audit-test-pass|id-audit-test-count"
|
||||
"federation|id-fed-test-pass|id-fed-test-count"
|
||||
"expiry|id-expiry-test-pass|id-expiry-test-count"
|
||||
"clients|id-clients-test-pass|id-clients-test-count"
|
||||
"grants|id-grants-test-pass|id-grants-test-count"
|
||||
"device|id-device-test-pass|id-device-test-count"
|
||||
"facade|id-facade-test-pass|id-facade-test-count"
|
||||
"delegation|id-deleg-test-pass|id-deleg-test-count"
|
||||
"session-mgmt|id-smgmt-test-pass|id-smgmt-test-count"
|
||||
"exchange|id-xchg-test-pass|id-xchg-test-count"
|
||||
"introspect|id-intr-test-pass|id-intr-test-count"
|
||||
"par|id-par-test-pass|id-par-test-count"
|
||||
"dynreg|id-dyn-test-pass|id-dyn-test-count"
|
||||
"account|id-acct-test-pass|id-acct-test-count"
|
||||
)
|
||||
|
||||
cat > "$TMPFILE" << 'EPOCHS'
|
||||
(epoch 1)
|
||||
(load "lib/erlang/tokenizer.sx")
|
||||
(load "lib/erlang/parser.sx")
|
||||
(load "lib/erlang/parser-core.sx")
|
||||
(load "lib/erlang/parser-expr.sx")
|
||||
(load "lib/erlang/parser-module.sx")
|
||||
(load "lib/erlang/transpile.sx")
|
||||
(load "lib/erlang/runtime.sx")
|
||||
(load "lib/identity/session.sx")
|
||||
(load "lib/identity/token.sx")
|
||||
(load "lib/identity/registry.sx")
|
||||
(load "lib/identity/api.sx")
|
||||
(load "lib/identity/oauth.sx")
|
||||
(load "lib/identity/membership.sx")
|
||||
(load "lib/identity/cache.sx")
|
||||
(load "lib/identity/audit.sx")
|
||||
(load "lib/identity/federation.sx")
|
||||
(load "lib/identity/clients.sx")
|
||||
(load "lib/identity/device.sx")
|
||||
(load "lib/identity/delegation.sx")
|
||||
(load "lib/identity/tests/session.sx")
|
||||
(load "lib/identity/tests/token.sx")
|
||||
(load "lib/identity/tests/registry.sx")
|
||||
(load "lib/identity/tests/api.sx")
|
||||
(load "lib/identity/tests/oauth.sx")
|
||||
(load "lib/identity/tests/sso.sx")
|
||||
(load "lib/identity/tests/membership.sx")
|
||||
(load "lib/identity/tests/cache.sx")
|
||||
(load "lib/identity/tests/audit.sx")
|
||||
(load "lib/identity/tests/federation.sx")
|
||||
(load "lib/identity/tests/expiry.sx")
|
||||
(load "lib/identity/tests/clients.sx")
|
||||
(load "lib/identity/tests/grants.sx")
|
||||
(load "lib/identity/tests/device.sx")
|
||||
(load "lib/identity/tests/facade.sx")
|
||||
(load "lib/identity/tests/delegation.sx")
|
||||
(load "lib/identity/tests/session_mgmt.sx")
|
||||
(load "lib/identity/tests/exchange.sx")
|
||||
(load "lib/identity/tests/introspect.sx")
|
||||
(load "lib/identity/tests/par.sx")
|
||||
(load "lib/identity/tests/dynreg.sx")
|
||||
(load "lib/identity/tests/account.sx")
|
||||
(epoch 100)
|
||||
(eval "(list id-session-test-pass id-session-test-count)")
|
||||
(epoch 101)
|
||||
(eval "(list id-token-test-pass id-token-test-count)")
|
||||
(epoch 102)
|
||||
(eval "(list id-registry-test-pass id-registry-test-count)")
|
||||
(epoch 103)
|
||||
(eval "(list id-api-test-pass id-api-test-count)")
|
||||
(epoch 104)
|
||||
(eval "(list id-oauth-test-pass id-oauth-test-count)")
|
||||
(epoch 105)
|
||||
(eval "(list id-sso-test-pass id-sso-test-count)")
|
||||
(epoch 106)
|
||||
(eval "(list id-membership-test-pass id-membership-test-count)")
|
||||
(epoch 107)
|
||||
(eval "(list id-cache-test-pass id-cache-test-count)")
|
||||
(epoch 108)
|
||||
(eval "(list id-audit-test-pass id-audit-test-count)")
|
||||
(epoch 109)
|
||||
(eval "(list id-fed-test-pass id-fed-test-count)")
|
||||
(epoch 110)
|
||||
(eval "(list id-expiry-test-pass id-expiry-test-count)")
|
||||
(epoch 111)
|
||||
(eval "(list id-clients-test-pass id-clients-test-count)")
|
||||
(epoch 112)
|
||||
(eval "(list id-grants-test-pass id-grants-test-count)")
|
||||
(epoch 113)
|
||||
(eval "(list id-device-test-pass id-device-test-count)")
|
||||
(epoch 114)
|
||||
(eval "(list id-facade-test-pass id-facade-test-count)")
|
||||
(epoch 115)
|
||||
(eval "(list id-deleg-test-pass id-deleg-test-count)")
|
||||
(epoch 116)
|
||||
(eval "(list id-smgmt-test-pass id-smgmt-test-count)")
|
||||
(epoch 117)
|
||||
(eval "(list id-xchg-test-pass id-xchg-test-count)")
|
||||
(epoch 118)
|
||||
(eval "(list id-intr-test-pass id-intr-test-count)")
|
||||
(epoch 119)
|
||||
(eval "(list id-par-test-pass id-par-test-count)")
|
||||
(epoch 120)
|
||||
(eval "(list id-dyn-test-pass id-dyn-test-count)")
|
||||
(epoch 121)
|
||||
(eval "(list id-acct-test-pass id-acct-test-count)")
|
||||
EPOCHS
|
||||
|
||||
timeout 1200 "$SX_SERVER" < "$TMPFILE" > "$OUTFILE" 2>&1
|
||||
|
||||
parse_pair() {
|
||||
local epoch="$1"
|
||||
local line
|
||||
line=$(grep -A1 "^(ok-len $epoch " "$OUTFILE" | tail -1)
|
||||
echo "$line" | sed -E 's/[()]//g'
|
||||
}
|
||||
|
||||
TOTAL_PASS=0
|
||||
TOTAL_COUNT=0
|
||||
JSON_SUITES=""
|
||||
MD_ROWS=""
|
||||
|
||||
idx=0
|
||||
for entry in "${SUITES[@]}"; do
|
||||
name="${entry%%|*}"
|
||||
epoch=$((100 + idx))
|
||||
pair=$(parse_pair "$epoch")
|
||||
pass=$(echo "$pair" | awk '{print $1}')
|
||||
count=$(echo "$pair" | awk '{print $2}')
|
||||
if [ -z "$pass" ] || [ -z "$count" ]; then
|
||||
pass=0
|
||||
count=0
|
||||
fi
|
||||
TOTAL_PASS=$((TOTAL_PASS + pass))
|
||||
TOTAL_COUNT=$((TOTAL_COUNT + count))
|
||||
status="ok"
|
||||
marker="✅"
|
||||
if [ "$pass" != "$count" ]; then
|
||||
status="fail"
|
||||
marker="❌"
|
||||
fi
|
||||
if [ "$VERBOSE" = "-v" ]; then
|
||||
printf " %-12s %s/%s\n" "$name" "$pass" "$count"
|
||||
fi
|
||||
if [ -n "$JSON_SUITES" ]; then JSON_SUITES+=","; fi
|
||||
JSON_SUITES+=$'\n '
|
||||
JSON_SUITES+="{\"name\":\"$name\",\"pass\":$pass,\"total\":$count,\"status\":\"$status\"}"
|
||||
MD_ROWS+="| $marker | $name | $pass | $count |"$'\n'
|
||||
idx=$((idx + 1))
|
||||
done
|
||||
|
||||
printf '\nidentity-on-sx conformance: %d / %d\n' "$TOTAL_PASS" "$TOTAL_COUNT"
|
||||
|
||||
cat > lib/identity/scoreboard.json <<JSON
|
||||
{
|
||||
"language": "identity",
|
||||
"total_pass": $TOTAL_PASS,
|
||||
"total": $TOTAL_COUNT,
|
||||
"suites": [$JSON_SUITES
|
||||
]
|
||||
}
|
||||
JSON
|
||||
|
||||
cat > lib/identity/scoreboard.md <<MD
|
||||
# identity-on-sx Scoreboard
|
||||
|
||||
**Total: ${TOTAL_PASS} / ${TOTAL_COUNT} tests passing**
|
||||
|
||||
| | Suite | Pass | Total |
|
||||
|---|---|---|---|
|
||||
$MD_ROWS
|
||||
|
||||
Generated by \`lib/identity/conformance.sh\`.
|
||||
MD
|
||||
|
||||
if [ "$TOTAL_PASS" -eq "$TOTAL_COUNT" ]; then
|
||||
exit 0
|
||||
else
|
||||
exit 1
|
||||
fi
|
||||
34
lib/identity/delegation.sx
Normal file
34
lib/identity/delegation.sx
Normal file
@@ -0,0 +1,34 @@
|
||||
;; identity/delegation.sx — the identity -> acl delegation boundary.
|
||||
;;
|
||||
;; This is the loop's central architectural rule made concrete:
|
||||
;; AUTHENTICATION is identity's job; AUTHORIZATION is acl's. A request is
|
||||
;; checked in two stages, and the order matters:
|
||||
;;
|
||||
;; 1. identity proves WHO via the opaque token (introspect). If the token
|
||||
;; is inactive, the answer is {error, unauthenticated} — a 401. acl is
|
||||
;; NEVER consulted; \"I don't know who you are\" is not a permission
|
||||
;; question.
|
||||
;; 2. only for an authenticated subject does identity construct the
|
||||
;; permission query {Subject, Scope, Action, Resource} and HAND IT OFF
|
||||
;; to acl. acl returns permit | deny; deny is {error, forbidden} — a
|
||||
;; 403. identity itself never decides permission.
|
||||
;;
|
||||
;; The real decider is acl-on-sx (Datalog), which runs as a different
|
||||
;; guest language on SX and is wired in at the integration layer. Here the
|
||||
;; acl side is a labelled STUB process so the boundary is exercised: it
|
||||
;; permits when the Action is within the token's granted Scope. Swap the
|
||||
;; stub pid for the acl adapter and the boundary is unchanged.
|
||||
;;
|
||||
;; check(TokReg, Acl, Token, Action, Resource) ->
|
||||
;; {ok, Subject} | {error, unauthenticated} | {error, forbidden}
|
||||
|
||||
(define
|
||||
identity-delegation-source
|
||||
"-module(identity_delegation).\n\n check(TokReg, Acl, Token, Action, Resource) ->\n case identity_tokens:introspect(TokReg, Token) of\n {inactive} ->\n {error, unauthenticated};\n {active, Subject, _Client, Scope} ->\n Acl ! {acl_query, Subject, Scope, Action, Resource, self()},\n receive {acl_verdict, V} ->\n case V of\n permit -> {ok, Subject};\n deny -> {error, forbidden}\n end\n end\n end.\n\n %% --- stub acl decider (stands in for acl-on-sx / Datalog) ---\n %% Permits iff the Action is one of the token's granted scopes. The real\n %% acl decides on rules + facts; this only exercises the handoff shape.\n stub_acl() ->\n spawn(fun () -> acl_loop() end).\n\n acl_loop() ->\n receive\n {acl_query, _Subject, Scope, Action, _Resource, From} ->\n From ! {acl_verdict, decide(Action, Scope)},\n acl_loop();\n stop ->\n ok\n end.\n\n decide(Action, Scope) ->\n case member(Action, Scope) of\n true -> permit;\n false -> deny\n end.\n\n member(_, []) -> false;\n member(X, [Y | Rest]) ->\n case X =:= Y of\n true -> true;\n false -> member(X, Rest)\n end.")
|
||||
|
||||
(define
|
||||
identity-load-delegation!
|
||||
(fn
|
||||
()
|
||||
(identity-load-token!)
|
||||
(erlang-load-module identity-delegation-source)))
|
||||
33
lib/identity/device.sx
Normal file
33
lib/identity/device.sx
Normal file
@@ -0,0 +1,33 @@
|
||||
;; identity/device.sx — the device authorization grant (RFC 8628).
|
||||
;;
|
||||
;; For input-constrained devices (TVs, CLIs): the device gets a device_code
|
||||
;; + user_code, the user approves out-of-band on another device, and the
|
||||
;; device polls the token endpoint until it flips. The poll status machine
|
||||
;; is RFC 8628 §3.5:
|
||||
;;
|
||||
;; authorize(ClientId, Scope) -> {ok, DeviceCode, UserCode}
|
||||
;; approve(UserCode, Subject) -> ok | {error, ...} (the human's browser)
|
||||
;; deny(UserCode) -> ok | {error, ...}
|
||||
;; poll(DeviceCode) ->
|
||||
;; pending -> {error, authorization_pending}
|
||||
;; denied -> {error, access_denied}
|
||||
;; approved -> {ok, Token} (device code is then single-use)
|
||||
;; consumed -> {error, invalid_grant}
|
||||
;; unknown -> {error, invalid_grant}
|
||||
;;
|
||||
;; Tokens are grant-backed (token.sx) so revocation stays real. Device-code
|
||||
;; expiry and slow_down (poll-rate limiting) are deferred — the substrate
|
||||
;; has no wall clock and the core status machine is the security-relevant
|
||||
;; part; introspect via token.sx already honours token TTL.
|
||||
;;
|
||||
;; State: loop(TokReg, Requests) where Requests is
|
||||
;; [{DeviceCode, UserCode, ClientId, Scope, Status}]
|
||||
;; Status :: pending | {approved, Subject} | denied | consumed
|
||||
|
||||
(define
|
||||
identity-device-source
|
||||
"-module(identity_device).\n\n start() ->\n spawn(fun () ->\n TokReg = identity_tokens:start(),\n loop(TokReg, [])\n end).\n\n authorize(D, ClientId, Scope) ->\n D ! {authorize, ClientId, Scope, self()},\n receive {device_reply, R} -> R end.\n\n approve(D, UserCode, Subject) ->\n D ! {approve, UserCode, Subject, self()},\n receive {device_reply, R} -> R end.\n\n deny(D, UserCode) ->\n D ! {deny, UserCode, self()},\n receive {device_reply, R} -> R end.\n\n poll(D, DeviceCode) ->\n D ! {poll, DeviceCode, self()},\n receive {device_reply, R} -> R end.\n\n introspect(D, Token) ->\n D ! {introspect, Token, self()},\n receive {device_reply, R} -> R end.\n\n loop(TokReg, Requests) ->\n receive\n {authorize, ClientId, Scope, From} ->\n DeviceCode = make_ref(),\n UserCode = make_ref(),\n From ! {device_reply, {ok, DeviceCode, UserCode}},\n loop(TokReg, [{DeviceCode, UserCode, ClientId, Scope, pending} | Requests]);\n {approve, UserCode, Subject, From} ->\n case find_user(UserCode, Requests) of\n none ->\n From ! {device_reply, {error, unknown_code}},\n loop(TokReg, Requests);\n {ok, {_, _, _, _, pending}} ->\n From ! {device_reply, ok},\n loop(TokReg, set_user(UserCode, {approved, Subject}, Requests));\n {ok, {_, _, _, _, St}} ->\n From ! {device_reply, {error, St}},\n loop(TokReg, Requests)\n end;\n {deny, UserCode, From} ->\n case find_user(UserCode, Requests) of\n none ->\n From ! {device_reply, {error, unknown_code}},\n loop(TokReg, Requests);\n {ok, {_, _, _, _, pending}} ->\n From ! {device_reply, ok},\n loop(TokReg, set_user(UserCode, denied, Requests));\n {ok, {_, _, _, _, St}} ->\n From ! {device_reply, {error, St}},\n loop(TokReg, Requests)\n end;\n {poll, DeviceCode, From} ->\n case find_device(DeviceCode, Requests) of\n none ->\n From ! {device_reply, {error, invalid_grant}},\n loop(TokReg, Requests);\n {ok, {_, _, _, _, pending}} ->\n From ! {device_reply, {error, authorization_pending}},\n loop(TokReg, Requests);\n {ok, {_, _, _, _, denied}} ->\n From ! {device_reply, {error, access_denied}},\n loop(TokReg, Requests);\n {ok, {_, _, _, _, consumed}} ->\n From ! {device_reply, {error, invalid_grant}},\n loop(TokReg, Requests);\n {ok, {_, _, ClientId, Scope, {approved, Subject}}} ->\n {ok, Token} = identity_tokens:issue(TokReg, Subject, ClientId, Scope),\n From ! {device_reply, {ok, Token}},\n loop(TokReg, set_device(DeviceCode, consumed, Requests))\n end;\n {introspect, Token, From} ->\n From ! {device_reply, identity_tokens:introspect(TokReg, Token)},\n loop(TokReg, Requests);\n {stop, From} ->\n From ! {device_reply, ok}\n end.\n\n find_device(_, []) -> none;\n find_device(DCode, [{D, U, C, S, St} | Rest]) ->\n case D =:= DCode of\n true -> {ok, {D, U, C, S, St}};\n false -> find_device(DCode, Rest)\n end.\n\n find_user(_, []) -> none;\n find_user(UCode, [{D, U, C, S, St} | Rest]) ->\n case U =:= UCode of\n true -> {ok, {D, U, C, S, St}};\n false -> find_user(UCode, Rest)\n end.\n\n set_device(_, _, []) -> [];\n set_device(DCode, NewSt, [{D, U, C, S, St} | Rest]) ->\n case D =:= DCode of\n true -> [{D, U, C, S, NewSt} | Rest];\n false -> [{D, U, C, S, St} | set_device(DCode, NewSt, Rest)]\n end.\n\n set_user(_, _, []) -> [];\n set_user(UCode, NewSt, [{D, U, C, S, St} | Rest]) ->\n case U =:= UCode of\n true -> [{D, U, C, S, NewSt} | Rest];\n false -> [{D, U, C, S, St} | set_user(UCode, NewSt, Rest)]\n end.")
|
||||
|
||||
(define
|
||||
identity-load-device!
|
||||
(fn () (identity-load-token!) (erlang-load-module identity-device-source)))
|
||||
30
lib/identity/federation.sx
Normal file
30
lib/identity/federation.sx
Normal file
@@ -0,0 +1,30 @@
|
||||
;; identity/federation.sx — federated identity: peer-asserted subjects,
|
||||
;; advisory and trust-gated.
|
||||
;;
|
||||
;; A peer instance can assert \"this remote subject authenticated with me\".
|
||||
;; We accept such an assertion ONLY from a peer we explicitly trust
|
||||
;; (trust-gated); an assertion from an unknown peer is {error, untrusted},
|
||||
;; never silently honoured. Even when accepted, the resulting identity is
|
||||
;; ADVISORY: it is flagged peer_asserted with its origin peer, never
|
||||
;; promoted to local authority. Downstream (acl) decides how much a
|
||||
;; peer-asserted identity may do; identity only records who asserted it.
|
||||
;;
|
||||
;; Cross-instance subject mapping turns a (Peer, RemoteSubject) pair into a
|
||||
;; stable local subject. By default it is namespaced — {federated, Peer,
|
||||
;; RemoteSubject} — so two peers' \"alice\" never collide; an explicit map
|
||||
;; can alias a remote subject to a local one.
|
||||
;;
|
||||
;; trust(F, Peer) / untrust(F, Peer) / trusted(F, Peer)
|
||||
;; map(F, Peer, Remote, Local) -> ok (optional alias)
|
||||
;; resolve(F, Peer, Remote) -> {ok, LocalSubject}
|
||||
;; assert_id(F, Peer, Remote) -> {ok, LocalSubject}
|
||||
;; | {error, untrusted}
|
||||
;; provenance(F, LocalSubject) -> {peer_asserted, Peer} | {local}
|
||||
|
||||
(define
|
||||
identity-federation-source
|
||||
"-module(identity_federation).\n\n start() ->\n spawn(fun () -> loop([], [], []) end).\n\n trust(F, Peer) ->\n F ! {trust, Peer, self()},\n receive {fed_reply, R} -> R end.\n\n untrust(F, Peer) ->\n F ! {untrust, Peer, self()},\n receive {fed_reply, R} -> R end.\n\n trusted(F, Peer) ->\n F ! {trusted, Peer, self()},\n receive {fed_reply, R} -> R end.\n\n map(F, Peer, Remote, Local) ->\n F ! {map, Peer, Remote, Local, self()},\n receive {fed_reply, R} -> R end.\n\n resolve(F, Peer, Remote) ->\n F ! {resolve, Peer, Remote, self()},\n receive {fed_reply, R} -> R end.\n\n assert_id(F, Peer, Remote) ->\n F ! {assert_id, Peer, Remote, self()},\n receive {fed_reply, R} -> R end.\n\n provenance(F, Local) ->\n F ! {provenance, Local, self()},\n receive {fed_reply, R} -> R end.\n\n loop(Trusted, Maps, Asserted) ->\n receive\n {trust, Peer, From} ->\n From ! {fed_reply, ok},\n loop(add_unique(Peer, Trusted), Maps, Asserted);\n {untrust, Peer, From} ->\n From ! {fed_reply, ok},\n loop(drop(Peer, Trusted), Maps, Asserted);\n {trusted, Peer, From} ->\n From ! {fed_reply, member(Peer, Trusted)},\n loop(Trusted, Maps, Asserted);\n {map, Peer, Remote, Local, From} ->\n From ! {fed_reply, ok},\n loop(Trusted, [{{Peer, Remote}, Local} | drop_map(Peer, Remote, Maps)], Asserted);\n {resolve, Peer, Remote, From} ->\n From ! {fed_reply, {ok, resolve_local(Peer, Remote, Maps)}},\n loop(Trusted, Maps, Asserted);\n {assert_id, Peer, Remote, From} ->\n case member(Peer, Trusted) of\n false ->\n From ! {fed_reply, {error, untrusted}},\n loop(Trusted, Maps, Asserted);\n true ->\n Local = resolve_local(Peer, Remote, Maps),\n From ! {fed_reply, {ok, Local}},\n loop(Trusted, Maps, [{Local, Peer} | drop_assert(Local, Asserted)])\n end;\n {provenance, Local, From} ->\n case find_assert(Local, Asserted) of\n {ok, Peer} -> From ! {fed_reply, {peer_asserted, Peer}};\n none -> From ! {fed_reply, {local}}\n end,\n loop(Trusted, Maps, Asserted);\n {stop, From} ->\n From ! {fed_reply, ok}\n end.\n\n resolve_local(Peer, Remote, Maps) ->\n case find_map(Peer, Remote, Maps) of\n {ok, Local} -> Local;\n none -> {federated, Peer, Remote}\n end.\n\n find_map(_, _, []) -> none;\n find_map(Peer, Remote, [{{P, R}, Local} | Rest]) ->\n case same(P, Peer, R, Remote) of\n true -> {ok, Local};\n false -> find_map(Peer, Remote, Rest)\n end.\n\n drop_map(_, _, []) -> [];\n drop_map(Peer, Remote, [{{P, R}, Local} | Rest]) ->\n case same(P, Peer, R, Remote) of\n true -> drop_map(Peer, Remote, Rest);\n false -> [{{P, R}, Local} | drop_map(Peer, Remote, Rest)]\n end.\n\n same(P, Peer, R, Remote) ->\n case P =:= Peer of\n true -> R =:= Remote;\n false -> false\n end.\n\n find_assert(_, []) -> none;\n find_assert(Local, [{L, Peer} | Rest]) ->\n case L =:= Local of\n true -> {ok, Peer};\n false -> find_assert(Local, Rest)\n end.\n\n drop_assert(_, []) -> [];\n drop_assert(Local, [{L, Peer} | Rest]) ->\n case L =:= Local of\n true -> drop_assert(Local, Rest);\n false -> [{L, Peer} | drop_assert(Local, Rest)]\n end.\n\n add_unique(X, Xs) ->\n case member(X, Xs) of\n true -> Xs;\n false -> [X | Xs]\n end.\n\n drop(_, []) -> [];\n drop(X, [Y | Rest]) ->\n case X =:= Y of\n true -> drop(X, Rest);\n false -> [Y | drop(X, Rest)]\n end.\n\n member(_, []) -> false;\n member(X, [Y | Rest]) ->\n case X =:= Y of\n true -> true;\n false -> member(X, Rest)\n end.")
|
||||
|
||||
(define
|
||||
identity-load-federation!
|
||||
(fn () (erlang-load-module identity-federation-source)))
|
||||
31
lib/identity/membership.sx
Normal file
31
lib/identity/membership.sx
Normal file
@@ -0,0 +1,31 @@
|
||||
;; identity/membership.sx — coop membership state + per-app projection.
|
||||
;;
|
||||
;; Membership is canonical subject state held by one process, a guarded
|
||||
;; state machine (invalid transitions are explicit errors, never silent
|
||||
;; no-ops):
|
||||
;;
|
||||
;; none --request--> pending --approve--> active
|
||||
;; active --lapse--> lapsed --reinstate--> active
|
||||
;; {pending|active|lapsed} --revoke--> revoked (terminal)
|
||||
;;
|
||||
;; A per-app GRANT PROJECTION renders that one canonical state into the
|
||||
;; view a given client app consumes — mirroring rose-ash's per-app grant
|
||||
;; verification. The projection is pure identity: it reports WHAT the
|
||||
;; subject's membership is for that app; it does NOT decide whether the
|
||||
;; app should let them in. That permission question is acl's, keyed off
|
||||
;; this projection.
|
||||
;;
|
||||
;; project(Subject, App) ->
|
||||
;; active -> {member, Tier, App}
|
||||
;; pending -> {pending, App}
|
||||
;; lapsed -> {lapsed, App}
|
||||
;; revoked -> {denied, App}
|
||||
;; none -> {non_member, App}
|
||||
|
||||
(define
|
||||
identity-membership-source
|
||||
"-module(identity_membership).\n\n start() ->\n spawn(fun () -> loop([]) end).\n\n request(M, Subject, Tier) ->\n M ! {request, Subject, Tier, self()},\n receive {membership_reply, R} -> R end.\n\n approve(M, Subject) ->\n M ! {approve, Subject, self()},\n receive {membership_reply, R} -> R end.\n\n lapse(M, Subject) ->\n M ! {lapse, Subject, self()},\n receive {membership_reply, R} -> R end.\n\n reinstate(M, Subject) ->\n M ! {reinstate, Subject, self()},\n receive {membership_reply, R} -> R end.\n\n revoke(M, Subject) ->\n M ! {revoke, Subject, self()},\n receive {membership_reply, R} -> R end.\n\n status(M, Subject) ->\n M ! {status, Subject, self()},\n receive {membership_reply, R} -> R end.\n\n project(M, Subject, App) ->\n M ! {project, Subject, App, self()},\n receive {membership_reply, R} -> R end.\n\n loop(Members) ->\n receive\n {request, Subject, Tier, From} ->\n case find(Subject, Members) of\n none ->\n From ! {membership_reply, ok},\n loop([{Subject, {pending, Tier}} | Members]);\n {ok, _} ->\n From ! {membership_reply, {error, exists}},\n loop(Members)\n end;\n {approve, Subject, From} ->\n case find(Subject, Members) of\n none ->\n From ! {membership_reply, {error, not_found}},\n loop(Members);\n {ok, {pending, Tier}} ->\n From ! {membership_reply, ok},\n loop(set_record(Subject, {active, Tier}, Members));\n {ok, {St, _}} ->\n From ! {membership_reply, {error, St}},\n loop(Members)\n end;\n {lapse, Subject, From} ->\n case find(Subject, Members) of\n none ->\n From ! {membership_reply, {error, not_found}},\n loop(Members);\n {ok, {active, Tier}} ->\n From ! {membership_reply, ok},\n loop(set_record(Subject, {lapsed, Tier}, Members));\n {ok, {St, _}} ->\n From ! {membership_reply, {error, St}},\n loop(Members)\n end;\n {reinstate, Subject, From} ->\n case find(Subject, Members) of\n none ->\n From ! {membership_reply, {error, not_found}},\n loop(Members);\n {ok, {lapsed, Tier}} ->\n From ! {membership_reply, ok},\n loop(set_record(Subject, {active, Tier}, Members));\n {ok, {St, _}} ->\n From ! {membership_reply, {error, St}},\n loop(Members)\n end;\n {revoke, Subject, From} ->\n case find(Subject, Members) of\n none ->\n From ! {membership_reply, {error, not_found}},\n loop(Members);\n {ok, {_, Tier}} ->\n From ! {membership_reply, ok},\n loop(set_record(Subject, {revoked, Tier}, Members))\n end;\n {status, Subject, From} ->\n case find(Subject, Members) of\n none -> From ! {membership_reply, {none}};\n {ok, {St, Tier}} -> From ! {membership_reply, {ok, St, Tier}}\n end,\n loop(Members);\n {project, Subject, App, From} ->\n From ! {membership_reply, project_view(Subject, App, Members)},\n loop(Members);\n {stop, From} ->\n From ! {membership_reply, ok}\n end.\n\n project_view(Subject, App, Members) ->\n case find(Subject, Members) of\n none -> {non_member, App};\n {ok, {active, Tier}} -> {member, Tier, App};\n {ok, {pending, _}} -> {pending, App};\n {ok, {lapsed, _}} -> {lapsed, App};\n {ok, {revoked, _}} -> {denied, App}\n end.\n\n set_record(_, _, []) -> [];\n set_record(Subject, Rec, [{S, Old} | Rest]) ->\n case S =:= Subject of\n true -> [{S, Rec} | Rest];\n false -> [{S, Old} | set_record(Subject, Rec, Rest)]\n end.\n\n find(_, []) -> none;\n find(Key, [{K, V} | Rest]) ->\n case K =:= Key of\n true -> {ok, V};\n false -> find(Key, Rest)\n end.")
|
||||
|
||||
(define
|
||||
identity-load-membership!
|
||||
(fn () (erlang-load-module identity-membership-source)))
|
||||
37
lib/identity/oauth.sx
Normal file
37
lib/identity/oauth.sx
Normal file
File diff suppressed because one or more lines are too long
22
lib/identity/registry.sx
Normal file
22
lib/identity/registry.sx
Normal file
@@ -0,0 +1,22 @@
|
||||
;; identity/registry.sx — routes sessions by id and by (subject, client).
|
||||
;;
|
||||
;; The registry is the directory that makes SSO possible: one subject can
|
||||
;; hold many sessions (one per client), and the OAuth machine asks it the
|
||||
;; single question that drives silent login — \"is there a live session
|
||||
;; for this subject + this client?\". It stores (SessionId, Subject,
|
||||
;; Client, Pid) rows and answers:
|
||||
;;
|
||||
;; whereis_session(Id) -> {ok, Pid} | {error, not_found}
|
||||
;; lookup(Subject, Client) -> {ok, Pid} | {error, not_found} (SSO probe)
|
||||
;; sessions_for(Subject) -> {ok, [SessionId, ...]} (fan-out)
|
||||
;;
|
||||
;; The registry only routes — it holds no grant state and decides nothing.
|
||||
;; Liveness of the routed-to session is that session process's own affair.
|
||||
|
||||
(define
|
||||
identity-registry-source
|
||||
"-module(identity_registry).\n\n start() ->\n spawn(fun () -> loop([]) end).\n\n register(Reg, SessionId, Subject, Client, Pid) ->\n Reg ! {register, SessionId, Subject, Client, Pid, self()},\n receive {registry_reply, R} -> R end.\n\n whereis_session(Reg, SessionId) ->\n Reg ! {whereis_session, SessionId, self()},\n receive {registry_reply, R} -> R end.\n\n lookup(Reg, Subject, Client) ->\n Reg ! {lookup, Subject, Client, self()},\n receive {registry_reply, R} -> R end.\n\n sessions_for(Reg, Subject) ->\n Reg ! {sessions_for, Subject, self()},\n receive {registry_reply, R} -> R end.\n\n deregister(Reg, SessionId) ->\n Reg ! {deregister, SessionId, self()},\n receive {registry_reply, R} -> R end.\n\n stop(Reg) ->\n Reg ! {stop, self()},\n receive {registry_reply, R} -> R end.\n\n loop(Entries) ->\n receive\n {register, SessionId, Subject, Client, Pid, From} ->\n From ! {registry_reply, ok},\n loop([{SessionId, Subject, Client, Pid} | remove_id(SessionId, Entries)]);\n {whereis_session, SessionId, From} ->\n From ! {registry_reply, find_id(SessionId, Entries)},\n loop(Entries);\n {lookup, Subject, Client, From} ->\n From ! {registry_reply, find_sc(Subject, Client, Entries)},\n loop(Entries);\n {sessions_for, Subject, From} ->\n From ! {registry_reply, {ok, collect_subject(Subject, Entries)}},\n loop(Entries);\n {deregister, SessionId, From} ->\n From ! {registry_reply, ok},\n loop(remove_id(SessionId, Entries));\n {stop, From} ->\n From ! {registry_reply, ok}\n end.\n\n find_id(_, []) -> {error, not_found};\n find_id(Id, [{Sid, _, _, Pid} | Rest]) ->\n case Sid =:= Id of\n true -> {ok, Pid};\n false -> find_id(Id, Rest)\n end.\n\n find_sc(_, _, []) -> {error, not_found};\n find_sc(Subject, Client, [{_, Su, Cl, Pid} | Rest]) ->\n case Su =:= Subject of\n true ->\n case Cl =:= Client of\n true -> {ok, Pid};\n false -> find_sc(Subject, Client, Rest)\n end;\n false -> find_sc(Subject, Client, Rest)\n end.\n\n collect_subject(_, []) -> [];\n collect_subject(Subject, [{Sid, Su, _, _} | Rest]) ->\n case Su =:= Subject of\n true -> [Sid | collect_subject(Subject, Rest)];\n false -> collect_subject(Subject, Rest)\n end.\n\n remove_id(_, []) -> [];\n remove_id(Id, [{Sid, Su, Cl, Pid} | Rest]) ->\n case Sid =:= Id of\n true -> remove_id(Id, Rest);\n false -> [{Sid, Su, Cl, Pid} | remove_id(Id, Rest)]\n end.")
|
||||
|
||||
(define
|
||||
identity-load-registry!
|
||||
(fn () (erlang-load-module identity-registry-source)))
|
||||
29
lib/identity/scoreboard.json
Normal file
29
lib/identity/scoreboard.json
Normal file
@@ -0,0 +1,29 @@
|
||||
{
|
||||
"language": "identity",
|
||||
"total_pass": 233,
|
||||
"total": 233,
|
||||
"suites": [
|
||||
{"name":"session","pass":11,"total":11,"status":"ok"},
|
||||
{"name":"token","pass":24,"total":24,"status":"ok"},
|
||||
{"name":"registry","pass":9,"total":9,"status":"ok"},
|
||||
{"name":"api","pass":10,"total":10,"status":"ok"},
|
||||
{"name":"oauth","pass":17,"total":17,"status":"ok"},
|
||||
{"name":"sso","pass":10,"total":10,"status":"ok"},
|
||||
{"name":"membership","pass":17,"total":17,"status":"ok"},
|
||||
{"name":"cache","pass":9,"total":9,"status":"ok"},
|
||||
{"name":"audit","pass":11,"total":11,"status":"ok"},
|
||||
{"name":"federation","pass":12,"total":12,"status":"ok"},
|
||||
{"name":"expiry","pass":8,"total":8,"status":"ok"},
|
||||
{"name":"clients","pass":11,"total":11,"status":"ok"},
|
||||
{"name":"grants","pass":9,"total":9,"status":"ok"},
|
||||
{"name":"device","pass":10,"total":10,"status":"ok"},
|
||||
{"name":"facade","pass":9,"total":9,"status":"ok"},
|
||||
{"name":"delegation","pass":8,"total":8,"status":"ok"},
|
||||
{"name":"session-mgmt","pass":8,"total":8,"status":"ok"},
|
||||
{"name":"exchange","pass":8,"total":8,"status":"ok"},
|
||||
{"name":"introspect","pass":9,"total":9,"status":"ok"},
|
||||
{"name":"par","pass":7,"total":7,"status":"ok"},
|
||||
{"name":"dynreg","pass":5,"total":5,"status":"ok"},
|
||||
{"name":"account","pass":11,"total":11,"status":"ok"}
|
||||
]
|
||||
}
|
||||
31
lib/identity/scoreboard.md
Normal file
31
lib/identity/scoreboard.md
Normal file
@@ -0,0 +1,31 @@
|
||||
# identity-on-sx Scoreboard
|
||||
|
||||
**Total: 233 / 233 tests passing**
|
||||
|
||||
| | Suite | Pass | Total |
|
||||
|---|---|---|---|
|
||||
| ✅ | session | 11 | 11 |
|
||||
| ✅ | token | 24 | 24 |
|
||||
| ✅ | registry | 9 | 9 |
|
||||
| ✅ | api | 10 | 10 |
|
||||
| ✅ | oauth | 17 | 17 |
|
||||
| ✅ | sso | 10 | 10 |
|
||||
| ✅ | membership | 17 | 17 |
|
||||
| ✅ | cache | 9 | 9 |
|
||||
| ✅ | audit | 11 | 11 |
|
||||
| ✅ | federation | 12 | 12 |
|
||||
| ✅ | expiry | 8 | 8 |
|
||||
| ✅ | clients | 11 | 11 |
|
||||
| ✅ | grants | 9 | 9 |
|
||||
| ✅ | device | 10 | 10 |
|
||||
| ✅ | facade | 9 | 9 |
|
||||
| ✅ | delegation | 8 | 8 |
|
||||
| ✅ | session-mgmt | 8 | 8 |
|
||||
| ✅ | exchange | 8 | 8 |
|
||||
| ✅ | introspect | 9 | 9 |
|
||||
| ✅ | par | 7 | 7 |
|
||||
| ✅ | dynreg | 5 | 5 |
|
||||
| ✅ | account | 11 | 11 |
|
||||
|
||||
|
||||
Generated by `lib/identity/conformance.sh`.
|
||||
20
lib/identity/session.sx
Normal file
20
lib/identity/session.sx
Normal file
@@ -0,0 +1,20 @@
|
||||
;; identity/session.sx — a session is an Erlang process.
|
||||
;;
|
||||
;; create = spawn a session process holding {subject, client, status}
|
||||
;; lookup = a message; the live process answers {ok, ...} or {error, S}
|
||||
;; expire = explicit message OR an idle timeout the process arms itself
|
||||
;; revoke = explicit message; the grant tombstones immediately
|
||||
;;
|
||||
;; Expiry is the process's own `receive ... after Ttl` timeout, never a
|
||||
;; global sweep. On timeout the process notifies its Owner and becomes a
|
||||
;; tombstone that still answers lookups — with {error, expired}, never a
|
||||
;; silent dead mailbox. A revoked or expired session is an explicit
|
||||
;; negative state, not the absence of a positive one.
|
||||
|
||||
(define
|
||||
identity-session-source
|
||||
"-module(identity_session).\n\n start(SessionId, Subject, Client, Owner, Ttl) ->\n spawn(fun () -> active(SessionId, Subject, Client, Owner, Ttl) end).\n\n lookup(Pid) ->\n Pid ! {lookup, self()},\n receive {session_reply, R} -> R end.\n\n touch(Pid) ->\n Pid ! {touch, self()},\n receive {session_reply, R} -> R end.\n\n expire(Pid) ->\n Pid ! {expire, self()},\n receive {session_reply, R} -> R end.\n\n revoke(Pid) ->\n Pid ! {revoke, self()},\n receive {session_reply, R} -> R end.\n\n stop(Pid) ->\n Pid ! {stop, self()},\n receive {session_reply, R} -> R end.\n\n active(SessionId, Subject, Client, Owner, Ttl) ->\n receive\n {lookup, From} ->\n From ! {session_reply, {ok, {SessionId, Subject, Client, active}}},\n active(SessionId, Subject, Client, Owner, Ttl);\n {touch, From} ->\n From ! {session_reply, ok},\n active(SessionId, Subject, Client, Owner, Ttl);\n {expire, From} ->\n From ! {session_reply, ok},\n tombstone(SessionId, Subject, Client, expired);\n {revoke, From} ->\n From ! {session_reply, ok},\n tombstone(SessionId, Subject, Client, revoked);\n {stop, From} ->\n From ! {session_reply, ok}\n after Ttl ->\n Owner ! {session_expired, SessionId},\n tombstone(SessionId, Subject, Client, expired)\n end.\n\n tombstone(SessionId, Subject, Client, Status) ->\n receive\n {lookup, From} ->\n From ! {session_reply, {error, Status}},\n tombstone(SessionId, Subject, Client, Status);\n {touch, From} ->\n From ! {session_reply, {error, Status}},\n tombstone(SessionId, Subject, Client, Status);\n {expire, From} ->\n From ! {session_reply, ok},\n tombstone(SessionId, Subject, Client, Status);\n {revoke, From} ->\n From ! {session_reply, ok},\n tombstone(SessionId, Subject, Client, revoked);\n {stop, From} ->\n From ! {session_reply, ok}\n end.")
|
||||
|
||||
(define
|
||||
identity-load-session!
|
||||
(fn () (erlang-load-module identity-session-source)))
|
||||
102
lib/identity/tests/account.sx
Normal file
102
lib/identity/tests/account.sx
Normal file
@@ -0,0 +1,102 @@
|
||||
;; identity/tests/account.sx — the account-security surface: \"apps with
|
||||
;; access\" (grants_for / identity:grants) plus \"disconnect this app\"
|
||||
;; (revoke_app / identity:revoke_app). Completes the per-subject view+action
|
||||
;; pair alongside sessions and history.
|
||||
|
||||
(define id-acct-test-count 0)
|
||||
(define id-acct-test-pass 0)
|
||||
(define id-acct-test-fails (list))
|
||||
|
||||
(define
|
||||
id-acct-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(set! id-acct-test-count (+ id-acct-test-count 1))
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! id-acct-test-pass (+ id-acct-test-pass 1))
|
||||
(append! id-acct-test-fails {:name name :expected expected :actual actual}))))
|
||||
|
||||
(define ida-ev erlang-eval-ast)
|
||||
(define idanm (fn (v) (get v :name)))
|
||||
|
||||
(identity-load-all!)
|
||||
|
||||
;; ── token-level grants_for ───────────────────────────────────────
|
||||
|
||||
(id-acct-test
|
||||
"grants_for lists a subject's active grants"
|
||||
(ida-ev
|
||||
"R = identity_tokens:start(),\n identity_tokens:issue(R, alice, web, read),\n identity_tokens:issue(R, alice, cli, write),\n identity_tokens:issue(R, bob, web, read),\n length(identity_tokens:grants_for(R, alice))")
|
||||
2)
|
||||
|
||||
(id-acct-test
|
||||
"grants_for excludes revoked grants"
|
||||
(ida-ev
|
||||
"R = identity_tokens:start(),\n {ok, A} = identity_tokens:issue(R, alice, web, read),\n identity_tokens:issue(R, alice, cli, write),\n identity_tokens:revoke(R, A),\n length(identity_tokens:grants_for(R, alice))")
|
||||
1)
|
||||
|
||||
(id-acct-test
|
||||
"grants_for is empty for a subject with none"
|
||||
(ida-ev
|
||||
"R = identity_tokens:start(),\n identity_tokens:issue(R, alice, web, read),\n length(identity_tokens:grants_for(R, ghost))")
|
||||
0)
|
||||
|
||||
(id-acct-test
|
||||
"each grant entry carries the client"
|
||||
(idanm
|
||||
(ida-ev
|
||||
"R = identity_tokens:start(),\n identity_tokens:issue(R, alice, web, read),\n case identity_tokens:grants_for(R, alice) of\n [{Client, _Scope}] -> Client;\n _ -> other\n end"))
|
||||
"web")
|
||||
|
||||
;; ── token-level revoke_app (\"disconnect this app\") ────────────────
|
||||
|
||||
(id-acct-test
|
||||
"revoke_app revokes all of a subject's grants for one client"
|
||||
(ida-ev
|
||||
"R = identity_tokens:start(),\n identity_tokens:issue(R, alice, web, read),\n identity_tokens:issue(R, alice, web, write),\n identity_tokens:issue(R, alice, cli, read),\n identity_tokens:revoke_app(R, alice, web),\n length(identity_tokens:grants_for(R, alice))")
|
||||
1)
|
||||
|
||||
(id-acct-test
|
||||
"revoke_app deactivates that client's tokens"
|
||||
(idanm
|
||||
(ida-ev
|
||||
"R = identity_tokens:start(),\n {ok, T} = identity_tokens:issue(R, alice, web, read),\n identity_tokens:revoke_app(R, alice, web),\n case identity_tokens:introspect(R, T) of\n {active, _, _, _} -> active;\n {inactive} -> inactive\n end"))
|
||||
"inactive")
|
||||
|
||||
(id-acct-test
|
||||
"revoke_app leaves another subject's same-client grant intact"
|
||||
(ida-ev
|
||||
"R = identity_tokens:start(),\n identity_tokens:issue(R, alice, web, read),\n identity_tokens:issue(R, bob, web, read),\n identity_tokens:revoke_app(R, alice, web),\n length(identity_tokens:grants_for(R, bob))")
|
||||
1)
|
||||
|
||||
;; ── facade-level grants + revoke_app ─────────────────────────────
|
||||
|
||||
(id-acct-test
|
||||
"identity:grants lists apps a subject has logged into"
|
||||
(ida-ev
|
||||
"Svc = identity:start(),\n identity:login(Svc, alice, web, read),\n identity:login(Svc, alice, mobile, read),\n length(identity:grants(Svc, alice))")
|
||||
2)
|
||||
|
||||
(id-acct-test
|
||||
"identity:revoke_app disconnects one app, leaving the rest"
|
||||
(ida-ev
|
||||
"Svc = identity:start(),\n identity:login(Svc, alice, web, read),\n identity:login(Svc, alice, mobile, read),\n identity:revoke_app(Svc, alice, web),\n length(identity:grants(Svc, alice))")
|
||||
1)
|
||||
|
||||
(id-acct-test
|
||||
"identity:grants is per-subject"
|
||||
(ida-ev
|
||||
"Svc = identity:start(),\n identity:login(Svc, alice, web, read),\n identity:login(Svc, bob, web, read),\n length(identity:grants(Svc, bob))")
|
||||
1)
|
||||
|
||||
(id-acct-test
|
||||
"revoke_app is audited as a revoke"
|
||||
(idanm
|
||||
(ida-ev
|
||||
"Svc = identity:start(),\n identity:login(Svc, alice, web, read),\n identity:revoke_app(Svc, alice, web),\n case identity:history(Svc, alice) of\n [login, issue, revoke] -> audited;\n Other -> Other\n end"))
|
||||
"audited")
|
||||
|
||||
(define
|
||||
id-acct-test-summary
|
||||
(str "account " id-acct-test-pass "/" id-acct-test-count))
|
||||
111
lib/identity/tests/api.sx
Normal file
111
lib/identity/tests/api.sx
Normal file
@@ -0,0 +1,111 @@
|
||||
;; identity/tests/api.sx — the service facade end-to-end: login issues a
|
||||
;; session + token, verify proves identity, revoke and logout take effect
|
||||
;; immediately. Exercises session + token + registry through one door.
|
||||
|
||||
(define id-api-test-count 0)
|
||||
(define id-api-test-pass 0)
|
||||
(define id-api-test-fails (list))
|
||||
|
||||
(define
|
||||
id-api-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(set! id-api-test-count (+ id-api-test-count 1))
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! id-api-test-pass (+ id-api-test-pass 1))
|
||||
(append! id-api-test-fails {:name name :expected expected :actual actual}))))
|
||||
|
||||
(define ida-ev erlang-eval-ast)
|
||||
(define idanm (fn (v) (get v :name)))
|
||||
|
||||
(identity-load-all!)
|
||||
|
||||
;; ── login + verify (happy path) ──────────────────────────────────
|
||||
|
||||
(id-api-test
|
||||
"login then verify is active"
|
||||
(idanm
|
||||
(ida-ev
|
||||
"Svc = identity:start(),\n {ok, _Sid, Tok} = identity:login(Svc, alice, web, read),\n case identity:verify(Svc, Tok) of\n {active, _, _, _} -> active;\n {inactive} -> inactive\n end"))
|
||||
"active")
|
||||
|
||||
(id-api-test
|
||||
"verify returns the logged-in subject"
|
||||
(idanm
|
||||
(ida-ev
|
||||
"Svc = identity:start(),\n {ok, _Sid, Tok} = identity:login(Svc, alice, web, read),\n case identity:verify(Svc, Tok) of\n {active, Subject, _, _} -> Subject\n end"))
|
||||
"alice")
|
||||
|
||||
(id-api-test
|
||||
"verify returns the granted scope"
|
||||
(idanm
|
||||
(ida-ev
|
||||
"Svc = identity:start(),\n {ok, _Sid, Tok} = identity:login(Svc, bob, cli, write),\n case identity:verify(Svc, Tok) of\n {active, _, _, Scope} -> Scope\n end"))
|
||||
"write")
|
||||
|
||||
;; ── revoke is real through the facade ────────────────────────────
|
||||
|
||||
(id-api-test
|
||||
"revoked token verifies inactive immediately"
|
||||
(idanm
|
||||
(ida-ev
|
||||
"Svc = identity:start(),\n {ok, _Sid, Tok} = identity:login(Svc, alice, web, read),\n identity:revoke(Svc, Tok),\n case identity:verify(Svc, Tok) of\n {active, _, _, _} -> still_valid;\n {inactive} -> inactive\n end"))
|
||||
"inactive")
|
||||
|
||||
;; ── session lifecycle through the facade ─────────────────────────
|
||||
|
||||
(id-api-test
|
||||
"fresh session reports active"
|
||||
(idanm
|
||||
(ida-ev
|
||||
"Svc = identity:start(),\n {ok, Sid, _Tok} = identity:login(Svc, alice, web, read),\n identity:session_status(Svc, Sid)"))
|
||||
"active")
|
||||
|
||||
(id-api-test
|
||||
"logout makes the session gone"
|
||||
(idanm
|
||||
(ida-ev
|
||||
"Svc = identity:start(),\n {ok, Sid, _Tok} = identity:login(Svc, alice, web, read),\n identity:logout(Svc, Sid),\n identity:session_status(Svc, Sid)"))
|
||||
"gone")
|
||||
|
||||
(id-api-test
|
||||
"status of an unknown session is gone"
|
||||
(idanm
|
||||
(ida-ev "Svc = identity:start(),\n identity:session_status(Svc, 999)"))
|
||||
"gone")
|
||||
|
||||
;; ── independence: logins do not bleed into each other ────────────
|
||||
|
||||
(id-api-test
|
||||
"revoking one login leaves the other active"
|
||||
(idanm
|
||||
(ida-ev
|
||||
"Svc = identity:start(),\n {ok, _S1, T1} = identity:login(Svc, alice, web, read),\n {ok, _S2, T2} = identity:login(Svc, bob, cli, write),\n identity:revoke(Svc, T1),\n case identity:verify(Svc, T2) of\n {active, Subject, _, _} -> Subject;\n {inactive} -> inactive\n end"))
|
||||
"bob")
|
||||
|
||||
(id-api-test
|
||||
"logging out one session leaves the other active"
|
||||
(idanm
|
||||
(ida-ev
|
||||
"Svc = identity:start(),\n {ok, S1, _T1} = identity:login(Svc, alice, web, read),\n {ok, S2, _T2} = identity:login(Svc, alice, cli, read),\n identity:logout(Svc, S1),\n identity:session_status(Svc, S2)"))
|
||||
"active")
|
||||
|
||||
;; ── coordinator deregisters on a session_expired notification ────
|
||||
;; A live idle session fires its own `after` timeout and notifies its
|
||||
;; owner (the coordinator), which then deregisters it — timeout-driven,
|
||||
;; never swept. The owner-internal path can't be observed by driving the
|
||||
;; scheduler idle from the test's main process, so we assert the handler
|
||||
;; directly: the mailbox is FIFO, so the expiry notification is processed
|
||||
;; before the following status query.
|
||||
|
||||
(id-api-test
|
||||
"session_expired notification deregisters the session"
|
||||
(idanm
|
||||
(ida-ev
|
||||
"Svc = identity:start(),\n {ok, Sid, _Tok} = identity:login(Svc, alice, web, read, 50),\n active = identity:session_status(Svc, Sid),\n Svc ! {session_expired, Sid},\n identity:session_status(Svc, Sid)"))
|
||||
"gone")
|
||||
|
||||
(define
|
||||
id-api-test-summary
|
||||
(str "api " id-api-test-pass "/" id-api-test-count))
|
||||
117
lib/identity/tests/audit.sx
Normal file
117
lib/identity/tests/audit.sx
Normal file
@@ -0,0 +1,117 @@
|
||||
;; identity/tests/audit.sx — the grant audit ledger. Every grant
|
||||
;; transition is recorded; the ledger is queryable per subject and
|
||||
;; chronological. Covers issue/refresh/revoke wiring through the token
|
||||
;; registry, reuse-triggered revoke, per-subject isolation, completeness,
|
||||
;; and direct ledger use.
|
||||
|
||||
(define id-audit-test-count 0)
|
||||
(define id-audit-test-pass 0)
|
||||
(define id-audit-test-fails (list))
|
||||
|
||||
(define
|
||||
id-audit-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(set! id-audit-test-count (+ id-audit-test-count 1))
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! id-audit-test-pass (+ id-audit-test-pass 1))
|
||||
(append! id-audit-test-fails {:name name :expected expected :actual actual}))))
|
||||
|
||||
(define ida-ev erlang-eval-ast)
|
||||
(define idanm (fn (v) (get v :name)))
|
||||
|
||||
(identity-load-audit!)
|
||||
(identity-load-token!)
|
||||
|
||||
;; ── issue is audited ─────────────────────────────────────────────
|
||||
|
||||
(id-audit-test
|
||||
"issue records one event for the subject"
|
||||
(ida-ev
|
||||
"A = identity_audit:start(),\n Reg = identity_tokens:start(A),\n identity_tokens:issue(Reg, alice, web, read),\n identity_audit:count(A, alice)")
|
||||
1)
|
||||
|
||||
(id-audit-test
|
||||
"the recorded action is issue"
|
||||
(idanm
|
||||
(ida-ev
|
||||
"A = identity_audit:start(),\n Reg = identity_tokens:start(A),\n identity_tokens:issue(Reg, alice, web, read),\n case identity_audit:actions(A, alice) of\n [issue] -> matched;\n _ -> nomatch\n end"))
|
||||
"matched")
|
||||
|
||||
;; ── full grant lifecycle is audited in order ─────────────────────
|
||||
|
||||
(id-audit-test
|
||||
"issue, refresh, revoke are recorded in order"
|
||||
(idanm
|
||||
(ida-ev
|
||||
"A = identity_audit:start(),\n Reg = identity_tokens:start(A),\n {ok, G, R} = identity_tokens:issue_grant(Reg, alice, web, read),\n identity_tokens:refresh(Reg, R),\n identity_tokens:revoke(Reg, G),\n case identity_audit:actions(A, alice) of\n [issue, refresh, revoke] -> matched;\n _ -> nomatch\n end"))
|
||||
"matched")
|
||||
|
||||
;; ── reuse-triggered revoke is audited ────────────────────────────
|
||||
|
||||
(id-audit-test
|
||||
"a refresh-reuse cascade records a revoke event"
|
||||
(idanm
|
||||
(ida-ev
|
||||
"A = identity_audit:start(),\n Reg = identity_tokens:start(A),\n {ok, _G, R} = identity_tokens:issue_grant(Reg, alice, web, read),\n identity_tokens:refresh(Reg, R),\n identity_tokens:refresh(Reg, R),\n case identity_audit:actions(A, alice) of\n [issue, refresh, revoke] -> matched;\n _ -> nomatch\n end"))
|
||||
"matched")
|
||||
|
||||
;; ── per-subject isolation ────────────────────────────────────────
|
||||
|
||||
(id-audit-test
|
||||
"the ledger separates subjects"
|
||||
(ida-ev
|
||||
"A = identity_audit:start(),\n Reg = identity_tokens:start(A),\n identity_tokens:issue(Reg, alice, web, read),\n identity_tokens:issue(Reg, bob, cli, write),\n identity_tokens:issue(Reg, alice, mobile, read),\n identity_audit:count(A, alice)")
|
||||
2)
|
||||
|
||||
(id-audit-test
|
||||
"an unaudited subject has zero events"
|
||||
(ida-ev
|
||||
"A = identity_audit:start(),\n Reg = identity_tokens:start(A),\n identity_tokens:issue(Reg, alice, web, read),\n identity_audit:count(A, ghost)")
|
||||
0)
|
||||
|
||||
;; ── the full log accumulates across subjects ─────────────────────
|
||||
|
||||
(id-audit-test
|
||||
"all events accumulate in the ledger"
|
||||
(ida-ev
|
||||
"A = identity_audit:start(),\n Reg = identity_tokens:start(A),\n identity_tokens:issue(Reg, alice, web, read),\n identity_tokens:issue(Reg, bob, cli, write),\n length(identity_audit:all(A))")
|
||||
2)
|
||||
|
||||
;; ── completeness: no grant transition is dropped ─────────────────
|
||||
|
||||
(id-audit-test
|
||||
"the ledger is complete across a mixed transition stream"
|
||||
(ida-ev
|
||||
"A = identity_audit:start(),\n Reg = identity_tokens:start(A),\n identity_tokens:issue(Reg, alice, web, read),\n {ok, _G, R} = identity_tokens:issue_grant(Reg, alice, cli, read),\n identity_tokens:refresh(Reg, R),\n {ok, B} = identity_tokens:issue(Reg, bob, web, read),\n identity_tokens:revoke(Reg, B),\n length(identity_audit:all(A))")
|
||||
5)
|
||||
|
||||
;; ── start/0 stays unaudited (no regression) ──────────────────────
|
||||
|
||||
(id-audit-test
|
||||
"an unaudited registry still issues working tokens"
|
||||
(idanm
|
||||
(ida-ev
|
||||
"Reg = identity_tokens:start(),\n {ok, T} = identity_tokens:issue(Reg, alice, web, read),\n case identity_tokens:introspect(Reg, T) of\n {active, _, _, _} -> active;\n {inactive} -> inactive\n end"))
|
||||
"active")
|
||||
|
||||
;; ── direct ledger use (e.g. login/consent events) ────────────────
|
||||
|
||||
(id-audit-test
|
||||
"events can be recorded directly on the ledger"
|
||||
(idanm
|
||||
(ida-ev
|
||||
"A = identity_audit:start(),\n identity_audit:record(A, alice, login),\n identity_audit:record(A, alice, consent),\n case identity_audit:actions(A, alice) of\n [login, consent] -> matched;\n _ -> nomatch\n end"))
|
||||
"matched")
|
||||
|
||||
(id-audit-test
|
||||
"an audit entry carries its subject"
|
||||
(idanm
|
||||
(ida-ev
|
||||
"A = identity_audit:start(),\n identity_audit:record(A, alice, login),\n case identity_audit:audit(A, alice) of\n [{_, Subject, _}] -> Subject;\n _ -> nomatch\n end"))
|
||||
"alice")
|
||||
|
||||
(define
|
||||
id-audit-test-summary
|
||||
(str "audit " id-audit-test-pass "/" id-audit-test-count))
|
||||
102
lib/identity/tests/cache.sx
Normal file
102
lib/identity/tests/cache.sx
Normal file
@@ -0,0 +1,102 @@
|
||||
;; identity/tests/cache.sx — delegated grant-verification cache. Proves
|
||||
;; the cache is live (hits/misses) AND that revocation stays real: a
|
||||
;; revoked token never reads valid out of the cache, because any revoke
|
||||
;; bumps the generation and forces re-validation.
|
||||
|
||||
(define id-cache-test-count 0)
|
||||
(define id-cache-test-pass 0)
|
||||
(define id-cache-test-fails (list))
|
||||
|
||||
(define
|
||||
id-cache-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(set! id-cache-test-count (+ id-cache-test-count 1))
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! id-cache-test-pass (+ id-cache-test-pass 1))
|
||||
(append! id-cache-test-fails {:name name :expected expected :actual actual}))))
|
||||
|
||||
(define idc-ev erlang-eval-ast)
|
||||
(define idcnm (fn (v) (get v :name)))
|
||||
|
||||
(identity-load-token!)
|
||||
(identity-load-cache!)
|
||||
|
||||
;; ── delegation: cache forwards to the registry ───────────────────
|
||||
|
||||
(id-cache-test
|
||||
"introspect through the cache returns active"
|
||||
(idcnm
|
||||
(idc-ev
|
||||
"C = identity_grant_cache:start(),\n {ok, T} = identity_grant_cache:issue(C, alice, web, read),\n case identity_grant_cache:introspect(C, T) of\n {active, _, _, _} -> active;\n {inactive} -> inactive\n end"))
|
||||
"active")
|
||||
|
||||
;; ── the cache is actually caching ────────────────────────────────
|
||||
|
||||
(id-cache-test
|
||||
"a repeated introspect is a cache hit"
|
||||
(idc-ev
|
||||
"C = identity_grant_cache:start(),\n {ok, T} = identity_grant_cache:issue(C, alice, web, read),\n identity_grant_cache:introspect(C, T),\n identity_grant_cache:introspect(C, T),\n case identity_grant_cache:stats(C) of {H, _} -> H end")
|
||||
1)
|
||||
|
||||
(id-cache-test
|
||||
"the first introspect of a token is a miss"
|
||||
(idc-ev
|
||||
"C = identity_grant_cache:start(),\n {ok, T} = identity_grant_cache:issue(C, alice, web, read),\n identity_grant_cache:introspect(C, T),\n identity_grant_cache:introspect(C, T),\n case identity_grant_cache:stats(C) of {_, M} -> M end")
|
||||
1)
|
||||
|
||||
;; ── revocation stays real through the cache (the centrepiece) ─────
|
||||
|
||||
(id-cache-test
|
||||
"a revoked token introspects inactive through the cache"
|
||||
(idcnm
|
||||
(idc-ev
|
||||
"C = identity_grant_cache:start(),\n {ok, T} = identity_grant_cache:issue(C, alice, web, read),\n identity_grant_cache:introspect(C, T),\n identity_grant_cache:revoke(C, T),\n case identity_grant_cache:introspect(C, T) of\n {active, _, _, _} -> still_valid;\n {inactive} -> inactive\n end"))
|
||||
"inactive")
|
||||
|
||||
(id-cache-test
|
||||
"revoke invalidates the cache (post-revoke read re-validates)"
|
||||
(idc-ev
|
||||
"C = identity_grant_cache:start(),\n {ok, T} = identity_grant_cache:issue(C, alice, web, read),\n identity_grant_cache:introspect(C, T),\n identity_grant_cache:revoke(C, T),\n identity_grant_cache:introspect(C, T),\n case identity_grant_cache:stats(C) of {_, M} -> M end")
|
||||
2)
|
||||
|
||||
;; ── cascade visibility through the cache ──────────────────────────
|
||||
|
||||
(id-cache-test
|
||||
"cascade revocation is visible through the cache"
|
||||
(idcnm
|
||||
(idc-ev
|
||||
"C = identity_grant_cache:start(),\n {ok, A, R} = identity_grant_cache:issue_grant(C, alice, web, read),\n identity_grant_cache:introspect(C, A),\n identity_grant_cache:revoke(C, R),\n case identity_grant_cache:introspect(C, A) of\n {active, _, _, _} -> still_valid;\n {inactive} -> inactive\n end"))
|
||||
"inactive")
|
||||
|
||||
;; ── a sibling token re-validates correctly after a revoke ────────
|
||||
|
||||
(id-cache-test
|
||||
"revoking one token leaves an independent token valid"
|
||||
(idcnm
|
||||
(idc-ev
|
||||
"C = identity_grant_cache:start(),\n {ok, A} = identity_grant_cache:issue(C, alice, web, read),\n {ok, B} = identity_grant_cache:issue(C, bob, cli, write),\n identity_grant_cache:introspect(C, A),\n identity_grant_cache:introspect(C, B),\n identity_grant_cache:revoke(C, A),\n case identity_grant_cache:introspect(C, B) of\n {active, Subject, _, _} -> Subject;\n {inactive} -> inactive\n end"))
|
||||
"bob")
|
||||
|
||||
;; ── refresh flows through the cache and stays correct ────────────
|
||||
|
||||
(id-cache-test
|
||||
"a refreshed token introspects active through the cache"
|
||||
(idcnm
|
||||
(idc-ev
|
||||
"C = identity_grant_cache:start(),\n {ok, _A, R} = identity_grant_cache:issue_grant(C, alice, web, read),\n {ok, A2, _R2} = identity_grant_cache:refresh(C, R),\n case identity_grant_cache:introspect(C, A2) of\n {active, _, _, _} -> active;\n {inactive} -> inactive\n end"))
|
||||
"active")
|
||||
|
||||
;; ── unknown token is inactive, and cached as such ────────────────
|
||||
|
||||
(id-cache-test
|
||||
"an unknown token introspects inactive through the cache"
|
||||
(idcnm
|
||||
(idc-ev
|
||||
"C = identity_grant_cache:start(),\n Bogus = make_ref(),\n case identity_grant_cache:introspect(C, Bogus) of\n {active, _, _, _} -> active;\n {inactive} -> inactive\n end"))
|
||||
"inactive")
|
||||
|
||||
(define
|
||||
id-cache-test-summary
|
||||
(str "cache " id-cache-test-pass "/" id-cache-test-count))
|
||||
108
lib/identity/tests/clients.sx
Normal file
108
lib/identity/tests/clients.sx
Normal file
@@ -0,0 +1,108 @@
|
||||
;; identity/tests/clients.sx — OAuth client registry: registration,
|
||||
;; public vs confidential authentication, and redirect_uri allow-listing.
|
||||
|
||||
(define id-clients-test-count 0)
|
||||
(define id-clients-test-pass 0)
|
||||
(define id-clients-test-fails (list))
|
||||
|
||||
(define
|
||||
id-clients-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(set! id-clients-test-count (+ id-clients-test-count 1))
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! id-clients-test-pass (+ id-clients-test-pass 1))
|
||||
(append! id-clients-test-fails {:name name :expected expected :actual actual}))))
|
||||
|
||||
(define idc-ev erlang-eval-ast)
|
||||
(define idcnm (fn (v) (get v :name)))
|
||||
|
||||
(identity-load-clients!)
|
||||
|
||||
;; ── registration + lookup ────────────────────────────────────────
|
||||
|
||||
(id-clients-test
|
||||
"a registered client looks up its type"
|
||||
(idcnm
|
||||
(idc-ev
|
||||
"C = identity_clients:start(),\n identity_clients:register(C, app1, confidential, s3cret, [uri1]),\n case identity_clients:lookup(C, app1) of\n {ok, Type, _} -> Type;\n {error, W} -> W\n end"))
|
||||
"confidential")
|
||||
|
||||
(id-clients-test
|
||||
"registering the same client twice is an error"
|
||||
(idcnm
|
||||
(idc-ev
|
||||
"C = identity_clients:start(),\n identity_clients:register(C, app1, confidential, s3cret, [uri1]),\n case identity_clients:register(C, app1, public, none, [uri1]) of\n ok -> ok;\n {error, W} -> W\n end"))
|
||||
"exists")
|
||||
|
||||
(id-clients-test
|
||||
"looking up an unregistered client is unknown_client"
|
||||
(idcnm
|
||||
(idc-ev
|
||||
"C = identity_clients:start(),\n case identity_clients:lookup(C, ghost) of\n {ok, _, _} -> found;\n {error, W} -> W\n end"))
|
||||
"unknown_client")
|
||||
|
||||
;; ── confidential client authentication ───────────────────────────
|
||||
|
||||
(id-clients-test
|
||||
"a confidential client authenticates with the right secret"
|
||||
(idcnm
|
||||
(idc-ev
|
||||
"C = identity_clients:start(),\n identity_clients:register(C, app1, confidential, s3cret, [uri1]),\n case identity_clients:authenticate(C, app1, s3cret) of\n {ok, Kind} -> Kind;\n {error, W} -> W\n end"))
|
||||
"confidential")
|
||||
|
||||
(id-clients-test
|
||||
"a confidential client with the wrong secret is invalid_client"
|
||||
(idcnm
|
||||
(idc-ev
|
||||
"C = identity_clients:start(),\n identity_clients:register(C, app1, confidential, s3cret, [uri1]),\n case identity_clients:authenticate(C, app1, wrongsecret) of\n {ok, _} -> accepted;\n {error, W} -> W\n end"))
|
||||
"invalid_client")
|
||||
|
||||
(id-clients-test
|
||||
"a public client needs no secret to authenticate"
|
||||
(idcnm
|
||||
(idc-ev
|
||||
"C = identity_clients:start(),\n identity_clients:register(C, spa, public, none, [uri1]),\n case identity_clients:authenticate(C, spa, anything) of\n {ok, Kind} -> Kind;\n {error, W} -> W\n end"))
|
||||
"public")
|
||||
|
||||
(id-clients-test
|
||||
"authenticating an unknown client is unknown_client"
|
||||
(idcnm
|
||||
(idc-ev
|
||||
"C = identity_clients:start(),\n case identity_clients:authenticate(C, ghost, x) of\n {ok, _} -> accepted;\n {error, W} -> W\n end"))
|
||||
"unknown_client")
|
||||
|
||||
;; ── redirect_uri allow-listing ───────────────────────────────────
|
||||
|
||||
(id-clients-test
|
||||
"a registered redirect_uri is valid"
|
||||
(idcnm
|
||||
(idc-ev
|
||||
"C = identity_clients:start(),\n identity_clients:register(C, app1, confidential, s3cret, [uri1, uri2]),\n case identity_clients:valid_redirect(C, app1, uri1) of\n true -> yes;\n false -> no\n end"))
|
||||
"yes")
|
||||
|
||||
(id-clients-test
|
||||
"a second registered redirect_uri is also valid"
|
||||
(idcnm
|
||||
(idc-ev
|
||||
"C = identity_clients:start(),\n identity_clients:register(C, app1, confidential, s3cret, [uri1, uri2]),\n case identity_clients:valid_redirect(C, app1, uri2) of\n true -> yes;\n false -> no\n end"))
|
||||
"yes")
|
||||
|
||||
(id-clients-test
|
||||
"an unregistered redirect_uri is rejected"
|
||||
(idcnm
|
||||
(idc-ev
|
||||
"C = identity_clients:start(),\n identity_clients:register(C, app1, confidential, s3cret, [uri1]),\n case identity_clients:valid_redirect(C, app1, evil_uri) of\n true -> yes;\n false -> no\n end"))
|
||||
"no")
|
||||
|
||||
(id-clients-test
|
||||
"redirect validation for an unknown client is rejected"
|
||||
(idcnm
|
||||
(idc-ev
|
||||
"C = identity_clients:start(),\n case identity_clients:valid_redirect(C, ghost, uri1) of\n true -> yes;\n false -> no\n end"))
|
||||
"no")
|
||||
|
||||
(define
|
||||
id-clients-test-summary
|
||||
(str "clients " id-clients-test-pass "/" id-clients-test-count))
|
||||
102
lib/identity/tests/delegation.sx
Normal file
102
lib/identity/tests/delegation.sx
Normal file
@@ -0,0 +1,102 @@
|
||||
;; identity/tests/delegation.sx — the identity -> acl boundary.
|
||||
;; Authentication (identity) gates BEFORE authorization (acl): an inactive
|
||||
;; token is unauthenticated (401) and acl is never consulted; only an
|
||||
;; authenticated subject's request is delegated to acl for permit/deny.
|
||||
|
||||
(define id-deleg-test-count 0)
|
||||
(define id-deleg-test-pass 0)
|
||||
(define id-deleg-test-fails (list))
|
||||
|
||||
(define
|
||||
id-deleg-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(set! id-deleg-test-count (+ id-deleg-test-count 1))
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! id-deleg-test-pass (+ id-deleg-test-pass 1))
|
||||
(append! id-deleg-test-fails {:name name :expected expected :actual actual}))))
|
||||
|
||||
(define idl-ev erlang-eval-ast)
|
||||
(define idlnm (fn (v) (get v :name)))
|
||||
|
||||
(identity-load-delegation!)
|
||||
|
||||
;; Shared prelude: a token registry, a stub acl, and a token granting
|
||||
;; [read, write] to alice, all bound.
|
||||
(define
|
||||
idl-setup
|
||||
"R = identity_tokens:start(),\n A = identity_delegation:stub_acl(),\n {ok, T} = identity_tokens:issue(R, alice, web, [read, write])")
|
||||
|
||||
;; ── authenticated + acl permits ──────────────────────────────────
|
||||
|
||||
(id-deleg-test
|
||||
"an authenticated, permitted request returns the subject"
|
||||
(idlnm
|
||||
(idl-ev
|
||||
(str
|
||||
idl-setup
|
||||
", case identity_delegation:check(R, A, T, read, doc1) of\n {ok, S} -> S;\n {error, W} -> W\n end")))
|
||||
"alice")
|
||||
|
||||
;; ── authenticated + acl denies → 403 ─────────────────────────────
|
||||
|
||||
(id-deleg-test
|
||||
"an authenticated but unpermitted request is forbidden"
|
||||
(idlnm
|
||||
(idl-ev
|
||||
"R = identity_tokens:start(),\n A = identity_delegation:stub_acl(),\n {ok, T} = identity_tokens:issue(R, alice, web, [read]),\n case identity_delegation:check(R, A, T, write, doc1) of\n {ok, _} -> permitted;\n {error, W} -> W\n end"))
|
||||
"forbidden")
|
||||
|
||||
;; ── unauthenticated → 401, acl never consulted ───────────────────
|
||||
|
||||
(id-deleg-test
|
||||
"a revoked token is unauthenticated, not forbidden"
|
||||
(idlnm
|
||||
(idl-ev
|
||||
(str
|
||||
idl-setup
|
||||
", identity_tokens:revoke(R, T),\n case identity_delegation:check(R, A, T, read, doc1) of\n {ok, _} -> permitted;\n {error, W} -> W\n end")))
|
||||
"unauthenticated")
|
||||
|
||||
(id-deleg-test
|
||||
"an unknown token is unauthenticated"
|
||||
(idlnm
|
||||
(idl-ev
|
||||
"R = identity_tokens:start(),\n A = identity_delegation:stub_acl(),\n Bogus = make_ref(),\n case identity_delegation:check(R, A, Bogus, read, doc1) of\n {ok, _} -> permitted;\n {error, W} -> W\n end"))
|
||||
"unauthenticated")
|
||||
|
||||
(id-deleg-test
|
||||
"an expired token is unauthenticated"
|
||||
(idlnm
|
||||
(idl-ev
|
||||
"R = identity_tokens:start(),\n A = identity_delegation:stub_acl(),\n {ok, T} = identity_tokens:issue(R, alice, web, [read], 100),\n identity_tokens:advance(R, 100),\n case identity_delegation:check(R, A, T, read, doc1) of\n {ok, _} -> permitted;\n {error, W} -> W\n end"))
|
||||
"unauthenticated")
|
||||
|
||||
;; ── 401 takes precedence over 403 (identity gates first) ─────────
|
||||
|
||||
(id-deleg-test
|
||||
"a revoked token with no matching scope is still unauthenticated"
|
||||
(idlnm
|
||||
(idl-ev
|
||||
"R = identity_tokens:start(),\n A = identity_delegation:stub_acl(),\n {ok, T} = identity_tokens:issue(R, alice, web, [admin]),\n identity_tokens:revoke(R, T),\n case identity_delegation:check(R, A, T, read, doc1) of\n {ok, _} -> permitted;\n {error, W} -> W\n end"))
|
||||
"unauthenticated")
|
||||
|
||||
;; ── acl is what decides for an authenticated subject ─────────────
|
||||
|
||||
(id-deleg-test
|
||||
"the same subject is permitted one action and denied another"
|
||||
(idl-ev
|
||||
"R = identity_tokens:start(),\n A = identity_delegation:stub_acl(),\n {ok, T} = identity_tokens:issue(R, alice, web, [read]),\n Allowed = case identity_delegation:check(R, A, T, read, doc1) of\n {ok, _} -> 1; {error, _} -> 0 end,\n Denied = case identity_delegation:check(R, A, T, write, doc1) of\n {ok, _} -> 1; {error, _} -> 0 end,\n Allowed - Denied")
|
||||
1)
|
||||
|
||||
(id-deleg-test
|
||||
"identity does not widen permission beyond the token scope"
|
||||
(idlnm
|
||||
(idl-ev
|
||||
"R = identity_tokens:start(),\n A = identity_delegation:stub_acl(),\n {ok, T} = identity_tokens:issue(R, alice, web, [read, write]),\n case identity_delegation:check(R, A, T, delete, doc1) of\n {ok, _} -> permitted;\n {error, W} -> W\n end"))
|
||||
"forbidden")
|
||||
|
||||
(define
|
||||
id-deleg-test-summary
|
||||
(str "delegation " id-deleg-test-pass "/" id-deleg-test-count))
|
||||
109
lib/identity/tests/device.sx
Normal file
109
lib/identity/tests/device.sx
Normal file
@@ -0,0 +1,109 @@
|
||||
;; identity/tests/device.sx — device authorization grant (RFC 8628):
|
||||
;; authorize → poll(pending) → approve/deny out-of-band → poll(token/denied).
|
||||
|
||||
(define id-device-test-count 0)
|
||||
(define id-device-test-pass 0)
|
||||
(define id-device-test-fails (list))
|
||||
|
||||
(define
|
||||
id-device-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(set! id-device-test-count (+ id-device-test-count 1))
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! id-device-test-pass (+ id-device-test-pass 1))
|
||||
(append! id-device-test-fails {:name name :expected expected :actual actual}))))
|
||||
|
||||
(define idd-ev erlang-eval-ast)
|
||||
(define iddnm (fn (v) (get v :name)))
|
||||
|
||||
(identity-load-device!)
|
||||
|
||||
;; ── polling before approval ──────────────────────────────────────
|
||||
|
||||
(id-device-test
|
||||
"polling a pending device code is authorization_pending"
|
||||
(iddnm
|
||||
(idd-ev
|
||||
"D = identity_device:start(),\n {ok, Dc, _Uc} = identity_device:authorize(D, tv, watch),\n case identity_device:poll(D, Dc) of\n {ok, _} -> got;\n {error, W} -> W\n end"))
|
||||
"authorization_pending")
|
||||
|
||||
;; ── approve → token ──────────────────────────────────────────────
|
||||
|
||||
(id-device-test
|
||||
"after approval, polling yields a working token"
|
||||
(iddnm
|
||||
(idd-ev
|
||||
"D = identity_device:start(),\n {ok, Dc, Uc} = identity_device:authorize(D, tv, watch),\n identity_device:approve(D, Uc, alice),\n {ok, T} = identity_device:poll(D, Dc),\n case identity_device:introspect(D, T) of\n {active, _, _, _} -> active;\n {inactive} -> inactive\n end"))
|
||||
"active")
|
||||
|
||||
(id-device-test
|
||||
"the device token carries the approving subject"
|
||||
(iddnm
|
||||
(idd-ev
|
||||
"D = identity_device:start(),\n {ok, Dc, Uc} = identity_device:authorize(D, tv, watch),\n identity_device:approve(D, Uc, alice),\n {ok, T} = identity_device:poll(D, Dc),\n case identity_device:introspect(D, T) of\n {active, Subject, _, _} -> Subject\n end"))
|
||||
"alice")
|
||||
|
||||
(id-device-test
|
||||
"the device token carries the requested scope"
|
||||
(iddnm
|
||||
(idd-ev
|
||||
"D = identity_device:start(),\n {ok, Dc, Uc} = identity_device:authorize(D, tv, stream),\n identity_device:approve(D, Uc, alice),\n {ok, T} = identity_device:poll(D, Dc),\n case identity_device:introspect(D, T) of\n {active, _, _, Scope} -> Scope\n end"))
|
||||
"stream")
|
||||
|
||||
;; ── deny ─────────────────────────────────────────────────────────
|
||||
|
||||
(id-device-test
|
||||
"after denial, polling is access_denied"
|
||||
(iddnm
|
||||
(idd-ev
|
||||
"D = identity_device:start(),\n {ok, Dc, Uc} = identity_device:authorize(D, tv, watch),\n identity_device:deny(D, Uc),\n case identity_device:poll(D, Dc) of\n {ok, _} -> got;\n {error, W} -> W\n end"))
|
||||
"access_denied")
|
||||
|
||||
;; ── unknown codes ────────────────────────────────────────────────
|
||||
|
||||
(id-device-test
|
||||
"polling an unknown device code is invalid_grant"
|
||||
(iddnm
|
||||
(idd-ev
|
||||
"D = identity_device:start(),\n Bogus = make_ref(),\n case identity_device:poll(D, Bogus) of\n {ok, _} -> got;\n {error, W} -> W\n end"))
|
||||
"invalid_grant")
|
||||
|
||||
(id-device-test
|
||||
"approving an unknown user code is unknown_code"
|
||||
(iddnm
|
||||
(idd-ev
|
||||
"D = identity_device:start(),\n Bogus = make_ref(),\n case identity_device:approve(D, Bogus, alice) of\n ok -> ok;\n {error, W} -> W\n end"))
|
||||
"unknown_code")
|
||||
|
||||
;; ── single-use device code ───────────────────────────────────────
|
||||
|
||||
(id-device-test
|
||||
"the device code is single-use after issuing a token"
|
||||
(iddnm
|
||||
(idd-ev
|
||||
"D = identity_device:start(),\n {ok, Dc, Uc} = identity_device:authorize(D, tv, watch),\n identity_device:approve(D, Uc, alice),\n identity_device:poll(D, Dc),\n case identity_device:poll(D, Dc) of\n {ok, _} -> got;\n {error, W} -> W\n end"))
|
||||
"invalid_grant")
|
||||
|
||||
;; ── guarded transitions ──────────────────────────────────────────
|
||||
|
||||
(id-device-test
|
||||
"approving an already-denied request is rejected"
|
||||
(iddnm
|
||||
(idd-ev
|
||||
"D = identity_device:start(),\n {ok, _Dc, Uc} = identity_device:authorize(D, tv, watch),\n identity_device:deny(D, Uc),\n case identity_device:approve(D, Uc, alice) of\n ok -> ok;\n {error, W} -> W\n end"))
|
||||
"denied")
|
||||
|
||||
;; ── independence ─────────────────────────────────────────────────
|
||||
|
||||
(id-device-test
|
||||
"two device requests are independent"
|
||||
(iddnm
|
||||
(idd-ev
|
||||
"D = identity_device:start(),\n {ok, Dc1, Uc1} = identity_device:authorize(D, tv, watch),\n {ok, Dc2, _Uc2} = identity_device:authorize(D, cli, deploy),\n identity_device:approve(D, Uc1, alice),\n case identity_device:poll(D, Dc2) of\n {ok, _} -> got;\n {error, W} -> W\n end"))
|
||||
"authorization_pending")
|
||||
|
||||
(define
|
||||
id-device-test-summary
|
||||
(str "device " id-device-test-pass "/" id-device-test-count))
|
||||
68
lib/identity/tests/dynreg.sx
Normal file
68
lib/identity/tests/dynreg.sx
Normal file
@@ -0,0 +1,68 @@
|
||||
;; identity/tests/dynreg.sx — dynamic client registration (RFC 7591): the
|
||||
;; server generates the client_id + secret for self-service onboarding.
|
||||
|
||||
(define id-dyn-test-count 0)
|
||||
(define id-dyn-test-pass 0)
|
||||
(define id-dyn-test-fails (list))
|
||||
|
||||
(define
|
||||
id-dyn-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(set! id-dyn-test-count (+ id-dyn-test-count 1))
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! id-dyn-test-pass (+ id-dyn-test-pass 1))
|
||||
(append! id-dyn-test-fails {:name name :expected expected :actual actual}))))
|
||||
|
||||
(define idd-ev erlang-eval-ast)
|
||||
(define iddnm (fn (v) (get v :name)))
|
||||
|
||||
(identity-load-oauth!)
|
||||
|
||||
;; ── self-service registration yields usable credentials ──────────
|
||||
|
||||
(id-dyn-test
|
||||
"a dynamically registered confidential client can get a token"
|
||||
(iddnm
|
||||
(idd-ev
|
||||
"O = identity_oauth:start(),\n {ok, Cid, Sec} = identity_oauth:register_dynamic(O, confidential, [uri1]),\n {ok, T} = identity_oauth:client_credentials(O, Cid, Sec, batch),\n case identity_oauth:introspect(O, T) of\n {active, _, _, _} -> active;\n {inactive} -> inactive\n end"))
|
||||
"active")
|
||||
|
||||
(id-dyn-test
|
||||
"the token's subject is the generated client id"
|
||||
(iddnm
|
||||
(idd-ev
|
||||
"O = identity_oauth:start(),\n {ok, Cid, Sec} = identity_oauth:register_dynamic(O, confidential, [uri1]),\n {ok, T} = identity_oauth:client_credentials(O, Cid, Sec, batch),\n case identity_oauth:introspect(O, T) of\n {active, Sub, _, _} ->\n case Sub =:= Cid of true -> matches; false -> mismatch end;\n {inactive} -> inactive\n end"))
|
||||
"matches")
|
||||
|
||||
;; ── the generated secret is required ─────────────────────────────
|
||||
|
||||
(id-dyn-test
|
||||
"a wrong secret for a dynamic client is invalid_client"
|
||||
(iddnm
|
||||
(idd-ev
|
||||
"O = identity_oauth:start(),\n {ok, Cid, _Sec} = identity_oauth:register_dynamic(O, confidential, [uri1]),\n case identity_oauth:client_credentials(O, Cid, wrongsecret, batch) of\n {ok, _} -> issued;\n {error, W} -> W\n end"))
|
||||
"invalid_client")
|
||||
|
||||
;; ── uniqueness ───────────────────────────────────────────────────
|
||||
|
||||
(id-dyn-test
|
||||
"two registrations yield distinct client ids"
|
||||
(iddnm
|
||||
(idd-ev
|
||||
"O = identity_oauth:start(),\n {ok, C1, _} = identity_oauth:register_dynamic(O, confidential, [uri1]),\n {ok, C2, _} = identity_oauth:register_dynamic(O, confidential, [uri1]),\n case C1 =:= C2 of true -> collision; false -> distinct end"))
|
||||
"distinct")
|
||||
|
||||
;; ── a dynamic public client still cannot use client-credentials ──
|
||||
|
||||
(id-dyn-test
|
||||
"a dynamic public client is unauthorized for client-credentials"
|
||||
(iddnm
|
||||
(idd-ev
|
||||
"O = identity_oauth:start(),\n {ok, Cid, Sec} = identity_oauth:register_dynamic(O, public, [uri1]),\n case identity_oauth:client_credentials(O, Cid, Sec, batch) of\n {ok, _} -> issued;\n {error, W} -> W\n end"))
|
||||
"unauthorized_client")
|
||||
|
||||
(define
|
||||
id-dyn-test-summary
|
||||
(str "dynreg " id-dyn-test-pass "/" id-dyn-test-count))
|
||||
110
lib/identity/tests/exchange.sx
Normal file
110
lib/identity/tests/exchange.sx
Normal file
@@ -0,0 +1,110 @@
|
||||
;; identity/tests/exchange.sx — token exchange (RFC 8693 §2.1): downscope a
|
||||
;; valid access token into a new independent token for a downstream service.
|
||||
|
||||
(define id-xchg-test-count 0)
|
||||
(define id-xchg-test-pass 0)
|
||||
(define id-xchg-test-fails (list))
|
||||
|
||||
(define
|
||||
id-xchg-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(set! id-xchg-test-count (+ id-xchg-test-count 1))
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! id-xchg-test-pass (+ id-xchg-test-pass 1))
|
||||
(append! id-xchg-test-fails {:name name :expected expected :actual actual}))))
|
||||
|
||||
(define idx-ev erlang-eval-ast)
|
||||
(define idxnm (fn (v) (get v :name)))
|
||||
|
||||
(identity-load-oauth!)
|
||||
|
||||
;; Shared prelude: an access token A for alice with scope [read, write].
|
||||
(define
|
||||
idx-token
|
||||
"O = identity_oauth:start(),\n {consent_required, Rq} = identity_oauth:authorize(O, web, uri1, [read, write], alice, v),\n {code, Cd} = identity_oauth:consent(O, Rq, allow),\n {ok, A, _R} = identity_oauth:exchange(O, Cd, web, uri1, v)")
|
||||
|
||||
;; ── downscoping ──────────────────────────────────────────────────
|
||||
|
||||
(id-xchg-test
|
||||
"exchange downscopes to a subset"
|
||||
(idxnm
|
||||
(idx-ev
|
||||
(str
|
||||
idx-token
|
||||
", {ok, X} = identity_oauth:token_exchange(O, A, [read]),\n case identity_oauth:introspect(O, X) of\n {active, _, _, [read]} -> downscoped;\n {active, _, _, _} -> other;\n {inactive} -> inactive\n end")))
|
||||
"downscoped")
|
||||
|
||||
(id-xchg-test
|
||||
"the exchanged token keeps the subject"
|
||||
(idxnm
|
||||
(idx-ev
|
||||
(str
|
||||
idx-token
|
||||
", {ok, X} = identity_oauth:token_exchange(O, A, [read]),\n case identity_oauth:introspect(O, X) of\n {active, Subject, _, _} -> Subject\n end")))
|
||||
"alice")
|
||||
|
||||
(id-xchg-test
|
||||
"exchange to the same scope is allowed"
|
||||
(idxnm
|
||||
(idx-ev
|
||||
(str
|
||||
idx-token
|
||||
", {ok, X} = identity_oauth:token_exchange(O, A, [read, write]),\n case identity_oauth:introspect(O, X) of\n {active, _, _, [read, write]} -> full;\n {active, _, _, _} -> other;\n {inactive} -> inactive\n end")))
|
||||
"full")
|
||||
|
||||
;; ── scope cannot be widened ──────────────────────────────────────
|
||||
|
||||
(id-xchg-test
|
||||
"exchange cannot widen beyond the subject token's scope"
|
||||
(idxnm
|
||||
(idx-ev
|
||||
"O = identity_oauth:start(),\n {consent_required, Rq} = identity_oauth:authorize(O, web, uri1, [read], alice, v),\n {code, Cd} = identity_oauth:consent(O, Rq, allow),\n {ok, A, _R} = identity_oauth:exchange(O, Cd, web, uri1, v),\n case identity_oauth:token_exchange(O, A, [read, write]) of\n {ok, _} -> widened;\n {error, W} -> W\n end"))
|
||||
"invalid_scope")
|
||||
|
||||
;; ── inactive subject token cannot be exchanged ───────────────────
|
||||
|
||||
(id-xchg-test
|
||||
"exchanging a revoked subject token is invalid_grant"
|
||||
(idxnm
|
||||
(idx-ev
|
||||
(str
|
||||
idx-token
|
||||
", identity_oauth:revoke(O, A),\n case identity_oauth:token_exchange(O, A, [read]) of\n {ok, _} -> issued;\n {error, W} -> W\n end")))
|
||||
"invalid_grant")
|
||||
|
||||
;; ── independent lifecycles ───────────────────────────────────────
|
||||
|
||||
(id-xchg-test
|
||||
"revoking the subject token does not revoke the exchanged token"
|
||||
(idxnm
|
||||
(idx-ev
|
||||
(str
|
||||
idx-token
|
||||
", {ok, X} = identity_oauth:token_exchange(O, A, [read]),\n identity_oauth:revoke(O, A),\n case identity_oauth:introspect(O, X) of\n {active, _, _, _} -> still_active;\n {inactive} -> inactive\n end")))
|
||||
"still_active")
|
||||
|
||||
(id-xchg-test
|
||||
"revoking the exchanged token does not revoke the subject token"
|
||||
(idxnm
|
||||
(idx-ev
|
||||
(str
|
||||
idx-token
|
||||
", {ok, X} = identity_oauth:token_exchange(O, A, [read]),\n identity_oauth:revoke(O, X),\n case identity_oauth:introspect(O, A) of\n {active, _, _, _} -> still_active;\n {inactive} -> inactive\n end")))
|
||||
"still_active")
|
||||
|
||||
;; ── chained downscoping ──────────────────────────────────────────
|
||||
|
||||
(id-xchg-test
|
||||
"an exchanged token can itself be exchanged (chain)"
|
||||
(idxnm
|
||||
(idx-ev
|
||||
(str
|
||||
idx-token
|
||||
", {ok, X1} = identity_oauth:token_exchange(O, A, [read, write]),\n {ok, X2} = identity_oauth:token_exchange(O, X1, [read]),\n case identity_oauth:introspect(O, X2) of\n {active, _, _, [read]} -> chained;\n {active, _, _, _} -> other;\n {inactive} -> inactive\n end")))
|
||||
"chained")
|
||||
|
||||
(define
|
||||
id-xchg-test-summary
|
||||
(str "exchange " id-xchg-test-pass "/" id-xchg-test-count))
|
||||
92
lib/identity/tests/expiry.sx
Normal file
92
lib/identity/tests/expiry.sx
Normal file
@@ -0,0 +1,92 @@
|
||||
;; identity/tests/expiry.sx — access-token expiry on a logical clock
|
||||
;; (RFC 6749 §4.2.2 expires_in). `advance` stands in for time passing;
|
||||
;; introspect returns inactive once the clock reaches a token's expiry.
|
||||
;; Refresh mints a fresh short-lived access token — the point of refresh.
|
||||
|
||||
(define id-expiry-test-count 0)
|
||||
(define id-expiry-test-pass 0)
|
||||
(define id-expiry-test-fails (list))
|
||||
|
||||
(define
|
||||
id-expiry-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(set! id-expiry-test-count (+ id-expiry-test-count 1))
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! id-expiry-test-pass (+ id-expiry-test-pass 1))
|
||||
(append! id-expiry-test-fails {:name name :expected expected :actual actual}))))
|
||||
|
||||
(define ide-ev erlang-eval-ast)
|
||||
(define idenm (fn (v) (get v :name)))
|
||||
|
||||
(identity-load-token!)
|
||||
|
||||
;; ── within TTL is active; past TTL is inactive ───────────────────
|
||||
|
||||
(id-expiry-test
|
||||
"a token within its TTL is active"
|
||||
(idenm
|
||||
(ide-ev
|
||||
"R = identity_tokens:start(),\n {ok, T} = identity_tokens:issue(R, alice, web, read, 100),\n identity_tokens:advance(R, 50),\n case identity_tokens:introspect(R, T) of\n {active, _, _, _} -> active;\n {inactive} -> inactive\n end"))
|
||||
"active")
|
||||
|
||||
(id-expiry-test
|
||||
"a token at its TTL boundary is expired"
|
||||
(idenm
|
||||
(ide-ev
|
||||
"R = identity_tokens:start(),\n {ok, T} = identity_tokens:issue(R, alice, web, read, 100),\n identity_tokens:advance(R, 100),\n case identity_tokens:introspect(R, T) of\n {active, _, _, _} -> active;\n {inactive} -> inactive\n end"))
|
||||
"inactive")
|
||||
|
||||
(id-expiry-test
|
||||
"a token just before its TTL is still active"
|
||||
(idenm
|
||||
(ide-ev
|
||||
"R = identity_tokens:start(),\n {ok, T} = identity_tokens:issue(R, alice, web, read, 100),\n identity_tokens:advance(R, 99),\n case identity_tokens:introspect(R, T) of\n {active, _, _, _} -> active;\n {inactive} -> inactive\n end"))
|
||||
"active")
|
||||
|
||||
;; ── no TTL (infinity) never expires ──────────────────────────────
|
||||
|
||||
(id-expiry-test
|
||||
"a token issued without a TTL never expires"
|
||||
(idenm
|
||||
(ide-ev
|
||||
"R = identity_tokens:start(),\n {ok, T} = identity_tokens:issue(R, alice, web, read),\n identity_tokens:advance(R, 100000),\n case identity_tokens:introspect(R, T) of\n {active, _, _, _} -> active;\n {inactive} -> inactive\n end"))
|
||||
"active")
|
||||
|
||||
;; ── refresh mints a fresh short-lived token ──────────────────────
|
||||
|
||||
(id-expiry-test
|
||||
"refresh renews access after the old token expired"
|
||||
(idenm
|
||||
(ide-ev
|
||||
"R = identity_tokens:start(),\n {ok, A, Rt} = identity_tokens:issue_grant(R, alice, web, read, 100),\n identity_tokens:advance(R, 100),\n inactive = case identity_tokens:introspect(R, A) of\n {active, _, _, _} -> active; {inactive} -> inactive end,\n {ok, A2, _R2} = identity_tokens:refresh(R, Rt),\n case identity_tokens:introspect(R, A2) of\n {active, _, _, _} -> renewed;\n {inactive} -> inactive\n end"))
|
||||
"renewed")
|
||||
|
||||
(id-expiry-test
|
||||
"the renewed token also expires after its own TTL"
|
||||
(idenm
|
||||
(ide-ev
|
||||
"R = identity_tokens:start(),\n {ok, _A, Rt} = identity_tokens:issue_grant(R, alice, web, read, 100),\n identity_tokens:advance(R, 100),\n {ok, A2, _R2} = identity_tokens:refresh(R, Rt),\n identity_tokens:advance(R, 100),\n case identity_tokens:introspect(R, A2) of\n {active, _, _, _} -> active;\n {inactive} -> inactive\n end"))
|
||||
"inactive")
|
||||
|
||||
;; ── the logical clock ────────────────────────────────────────────
|
||||
|
||||
(id-expiry-test
|
||||
"the clock starts at zero and advances"
|
||||
(ide-ev
|
||||
"R = identity_tokens:start(),\n identity_tokens:advance(R, 7),\n identity_tokens:advance(R, 35),\n identity_tokens:now(R)")
|
||||
42)
|
||||
|
||||
;; ── expiry composes with revocation ──────────────────────────────
|
||||
|
||||
(id-expiry-test
|
||||
"an expired token is also inactive after revoke (no contradiction)"
|
||||
(idenm
|
||||
(ide-ev
|
||||
"R = identity_tokens:start(),\n {ok, T} = identity_tokens:issue(R, alice, web, read, 100),\n identity_tokens:advance(R, 200),\n identity_tokens:revoke(R, T),\n case identity_tokens:introspect(R, T) of\n {active, _, _, _} -> active;\n {inactive} -> inactive\n end"))
|
||||
"inactive")
|
||||
|
||||
(define
|
||||
id-expiry-test-summary
|
||||
(str "expiry " id-expiry-test-pass "/" id-expiry-test-count))
|
||||
97
lib/identity/tests/facade.sx
Normal file
97
lib/identity/tests/facade.sx
Normal file
@@ -0,0 +1,97 @@
|
||||
;; identity/tests/facade.sx — the unified facade: one coordinator wiring
|
||||
;; sessions+tokens, the audit ledger, and membership. Exercises the
|
||||
;; cross-module integration (login/logout auditing, audit history, member
|
||||
;; enrollment + projection) through the single `identity` door.
|
||||
|
||||
(define id-facade-test-count 0)
|
||||
(define id-facade-test-pass 0)
|
||||
(define id-facade-test-fails (list))
|
||||
|
||||
(define
|
||||
id-facade-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(set! id-facade-test-count (+ id-facade-test-count 1))
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! id-facade-test-pass (+ id-facade-test-pass 1))
|
||||
(append! id-facade-test-fails {:name name :expected expected :actual actual}))))
|
||||
|
||||
(define idfc-ev erlang-eval-ast)
|
||||
(define idfcnm (fn (v) (get v :name)))
|
||||
|
||||
(identity-load-all!)
|
||||
|
||||
;; ── login + logout are audited through the ledger ────────────────
|
||||
|
||||
(id-facade-test
|
||||
"login then logout records login, issue, logout in order"
|
||||
(idfcnm
|
||||
(idfc-ev
|
||||
"Svc = identity:start(),\n {ok, Sid, _Tok} = identity:login(Svc, alice, web, read),\n identity:logout(Svc, Sid),\n case identity:history(Svc, alice) of\n [login, issue, logout] -> ordered;\n Other -> Other\n end"))
|
||||
"ordered")
|
||||
|
||||
(id-facade-test
|
||||
"revoking a token is audited"
|
||||
(idfcnm
|
||||
(idfc-ev
|
||||
"Svc = identity:start(),\n {ok, _Sid, Tok} = identity:login(Svc, alice, web, read),\n identity:revoke(Svc, Tok),\n case identity:history(Svc, alice) of\n [login, issue, revoke] -> ordered;\n Other -> Other\n end"))
|
||||
"ordered")
|
||||
|
||||
(id-facade-test
|
||||
"history is per-subject"
|
||||
(idfc-ev
|
||||
"Svc = identity:start(),\n identity:login(Svc, alice, web, read),\n identity:login(Svc, bob, cli, read),\n identity:login(Svc, alice, mobile, read),\n length(identity:history(Svc, alice))")
|
||||
4)
|
||||
|
||||
;; ── membership through the facade ────────────────────────────────
|
||||
|
||||
(id-facade-test
|
||||
"enroll makes the subject an active member"
|
||||
(idfcnm
|
||||
(idfc-ev
|
||||
"Svc = identity:start(),\n identity:enroll(Svc, alice, supporter),\n case identity:member_status(Svc, alice) of\n {ok, St, _} -> St;\n {none} -> none\n end"))
|
||||
"active")
|
||||
|
||||
(id-facade-test
|
||||
"enroll keeps the tier"
|
||||
(idfcnm
|
||||
(idfc-ev
|
||||
"Svc = identity:start(),\n identity:enroll(Svc, alice, supporter),\n case identity:member_status(Svc, alice) of\n {ok, _, Tier} -> Tier\n end"))
|
||||
"supporter")
|
||||
|
||||
(id-facade-test
|
||||
"an enrolled member projects per-app"
|
||||
(idfcnm
|
||||
(idfc-ev
|
||||
"Svc = identity:start(),\n identity:enroll(Svc, alice, basic),\n case identity:member_project(Svc, alice, market) of\n {member, _, App} -> App;\n {Tag, _} -> Tag\n end"))
|
||||
"market")
|
||||
|
||||
(id-facade-test
|
||||
"a non-member projects as non_member"
|
||||
(idfcnm
|
||||
(idfc-ev
|
||||
"Svc = identity:start(),\n case identity:member_project(Svc, stranger, blog) of\n {member, _, _} -> member;\n {Tag, _} -> Tag\n end"))
|
||||
"non_member")
|
||||
|
||||
;; ── the facade still proves identity ─────────────────────────────
|
||||
|
||||
(id-facade-test
|
||||
"verify still returns the subject after login"
|
||||
(idfcnm
|
||||
(idfc-ev
|
||||
"Svc = identity:start(),\n {ok, _Sid, Tok} = identity:login(Svc, alice, web, read),\n case identity:verify(Svc, Tok) of\n {active, Subject, _, _} -> Subject;\n {inactive} -> inactive\n end"))
|
||||
"alice")
|
||||
|
||||
;; ── identity and membership are distinct axes ────────────────────
|
||||
|
||||
(id-facade-test
|
||||
"logging in does not enroll membership"
|
||||
(idfcnm
|
||||
(idfc-ev
|
||||
"Svc = identity:start(),\n identity:login(Svc, alice, web, read),\n case identity:member_status(Svc, alice) of\n {ok, St, _} -> St;\n {none} -> none\n end"))
|
||||
"none")
|
||||
|
||||
(define
|
||||
id-facade-test-summary
|
||||
(str "facade " id-facade-test-pass "/" id-facade-test-count))
|
||||
115
lib/identity/tests/federation.sx
Normal file
115
lib/identity/tests/federation.sx
Normal file
@@ -0,0 +1,115 @@
|
||||
;; identity/tests/federation.sx — federated identity: trust-gated,
|
||||
;; advisory peer assertions + cross-instance subject mapping.
|
||||
|
||||
(define id-fed-test-count 0)
|
||||
(define id-fed-test-pass 0)
|
||||
(define id-fed-test-fails (list))
|
||||
|
||||
(define
|
||||
id-fed-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(set! id-fed-test-count (+ id-fed-test-count 1))
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! id-fed-test-pass (+ id-fed-test-pass 1))
|
||||
(append! id-fed-test-fails {:name name :expected expected :actual actual}))))
|
||||
|
||||
(define idf-ev erlang-eval-ast)
|
||||
(define idfnm (fn (v) (get v :name)))
|
||||
|
||||
(identity-load-federation!)
|
||||
|
||||
;; ── trust gating ─────────────────────────────────────────────────
|
||||
|
||||
(id-fed-test
|
||||
"an assertion from an untrusted peer is rejected"
|
||||
(idfnm
|
||||
(idf-ev
|
||||
"F = identity_federation:start(),\n case identity_federation:assert_id(F, peer1, alice) of\n {ok, _} -> accepted;\n {error, Why} -> Why\n end"))
|
||||
"untrusted")
|
||||
|
||||
(id-fed-test
|
||||
"a trusted peer's assertion is accepted"
|
||||
(idfnm
|
||||
(idf-ev
|
||||
"F = identity_federation:start(),\n identity_federation:trust(F, peer1),\n case identity_federation:assert_id(F, peer1, alice) of\n {ok, _} -> accepted;\n {error, Why} -> Why\n end"))
|
||||
"accepted")
|
||||
|
||||
(id-fed-test
|
||||
"untrust closes the door to future assertions"
|
||||
(idfnm
|
||||
(idf-ev
|
||||
"F = identity_federation:start(),\n identity_federation:trust(F, peer1),\n identity_federation:untrust(F, peer1),\n case identity_federation:assert_id(F, peer1, alice) of\n {ok, _} -> accepted;\n {error, Why} -> Why\n end"))
|
||||
"untrusted")
|
||||
|
||||
(id-fed-test
|
||||
"trusted? is true for a trusted peer"
|
||||
(idfnm
|
||||
(idf-ev
|
||||
"F = identity_federation:start(),\n identity_federation:trust(F, peer1),\n case identity_federation:trusted(F, peer1) of\n true -> yes;\n false -> no\n end"))
|
||||
"yes")
|
||||
|
||||
(id-fed-test
|
||||
"trusted? is false for an unknown peer"
|
||||
(idfnm
|
||||
(idf-ev
|
||||
"F = identity_federation:start(),\n identity_federation:trust(F, peer1),\n case identity_federation:trusted(F, peer2) of\n true -> yes;\n false -> no\n end"))
|
||||
"no")
|
||||
|
||||
;; ── advisory provenance ──────────────────────────────────────────
|
||||
|
||||
(id-fed-test
|
||||
"an asserted identity is flagged peer_asserted with its origin"
|
||||
(idfnm
|
||||
(idf-ev
|
||||
"F = identity_federation:start(),\n identity_federation:trust(F, peer1),\n {ok, L} = identity_federation:assert_id(F, peer1, alice),\n case identity_federation:provenance(F, L) of\n {peer_asserted, P} -> P;\n {local} -> local\n end"))
|
||||
"peer1")
|
||||
|
||||
(id-fed-test
|
||||
"a non-federated subject has local provenance"
|
||||
(idfnm
|
||||
(idf-ev
|
||||
"F = identity_federation:start(),\n case identity_federation:provenance(F, alice) of\n {peer_asserted, _} -> peer_asserted;\n {local} -> local\n end"))
|
||||
"local")
|
||||
|
||||
;; ── cross-instance subject mapping ───────────────────────────────
|
||||
|
||||
(id-fed-test
|
||||
"remote subjects are namespaced by peer by default"
|
||||
(idfnm
|
||||
(idf-ev
|
||||
"F = identity_federation:start(),\n case identity_federation:resolve(F, peer1, alice) of\n {ok, {federated, _, Remote}} -> Remote;\n _ -> other\n end"))
|
||||
"alice")
|
||||
|
||||
(id-fed-test
|
||||
"the same remote name from two peers maps to distinct subjects"
|
||||
(idfnm
|
||||
(idf-ev
|
||||
"F = identity_federation:start(),\n {ok, L1} = identity_federation:resolve(F, peer1, alice),\n {ok, L2} = identity_federation:resolve(F, peer2, alice),\n case L1 =:= L2 of\n true -> collision;\n false -> distinct\n end"))
|
||||
"distinct")
|
||||
|
||||
(id-fed-test
|
||||
"an explicit map aliases a remote subject to a local one"
|
||||
(idfnm
|
||||
(idf-ev
|
||||
"F = identity_federation:start(),\n identity_federation:trust(F, peer1),\n identity_federation:map(F, peer1, alice, alice_local),\n case identity_federation:assert_id(F, peer1, alice) of\n {ok, alice_local} -> mapped;\n {ok, _} -> unmapped;\n {error, W} -> W\n end"))
|
||||
"mapped")
|
||||
|
||||
(id-fed-test
|
||||
"a mapped subject keeps peer_asserted provenance"
|
||||
(idfnm
|
||||
(idf-ev
|
||||
"F = identity_federation:start(),\n identity_federation:trust(F, peer1),\n identity_federation:map(F, peer1, alice, alice_local),\n identity_federation:assert_id(F, peer1, alice),\n case identity_federation:provenance(F, alice_local) of\n {peer_asserted, P} -> P;\n {local} -> local\n end"))
|
||||
"peer1")
|
||||
|
||||
(id-fed-test
|
||||
"two peers asserting same name keep separate provenance"
|
||||
(idfnm
|
||||
(idf-ev
|
||||
"F = identity_federation:start(),\n identity_federation:trust(F, peer1),\n identity_federation:trust(F, peer2),\n {ok, L1} = identity_federation:assert_id(F, peer1, alice),\n {ok, _L2} = identity_federation:assert_id(F, peer2, alice),\n case identity_federation:provenance(F, L1) of\n {peer_asserted, P} -> P;\n {local} -> local\n end"))
|
||||
"peer1")
|
||||
|
||||
(define
|
||||
id-fed-test-summary
|
||||
(str "federation " id-fed-test-pass "/" id-fed-test-count))
|
||||
96
lib/identity/tests/grants.sx
Normal file
96
lib/identity/tests/grants.sx
Normal file
@@ -0,0 +1,96 @@
|
||||
;; identity/tests/grants.sx — the client-credentials grant (RFC 6749
|
||||
;; §4.4): a confidential client authenticates and gets a token acting on
|
||||
;; its own behalf — no end-user, no refresh token (§4.4.3). Public clients
|
||||
;; cannot use it.
|
||||
|
||||
(define id-grants-test-count 0)
|
||||
(define id-grants-test-pass 0)
|
||||
(define id-grants-test-fails (list))
|
||||
|
||||
(define
|
||||
id-grants-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(set! id-grants-test-count (+ id-grants-test-count 1))
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! id-grants-test-pass (+ id-grants-test-pass 1))
|
||||
(append! id-grants-test-fails {:name name :expected expected :actual actual}))))
|
||||
|
||||
(define idg-ev erlang-eval-ast)
|
||||
(define idgnm (fn (v) (get v :name)))
|
||||
|
||||
(identity-load-oauth!)
|
||||
|
||||
;; ── confidential client-credentials happy path ───────────────────
|
||||
|
||||
(id-grants-test
|
||||
"a confidential client obtains a working token"
|
||||
(idgnm
|
||||
(idg-ev
|
||||
"O = identity_oauth:start(),\n identity_oauth:register_client(O, svc, confidential, sk, [uri1]),\n {ok, T} = identity_oauth:client_credentials(O, svc, sk, batch),\n case identity_oauth:introspect(O, T) of\n {active, _, _, _} -> active;\n {inactive} -> inactive\n end"))
|
||||
"active")
|
||||
|
||||
(id-grants-test
|
||||
"the client-credentials token's subject is the client itself"
|
||||
(idgnm
|
||||
(idg-ev
|
||||
"O = identity_oauth:start(),\n identity_oauth:register_client(O, svc, confidential, sk, [uri1]),\n {ok, T} = identity_oauth:client_credentials(O, svc, sk, batch),\n case identity_oauth:introspect(O, T) of\n {active, Subject, _, _} -> Subject\n end"))
|
||||
"svc")
|
||||
|
||||
(id-grants-test
|
||||
"the client-credentials token carries the requested scope"
|
||||
(idgnm
|
||||
(idg-ev
|
||||
"O = identity_oauth:start(),\n identity_oauth:register_client(O, svc, confidential, sk, [uri1]),\n {ok, T} = identity_oauth:client_credentials(O, svc, sk, reports),\n case identity_oauth:introspect(O, T) of\n {active, _, _, Scope} -> Scope\n end"))
|
||||
"reports")
|
||||
|
||||
(id-grants-test
|
||||
"client-credentials issues no refresh token (single value)"
|
||||
(idgnm
|
||||
(idg-ev
|
||||
"O = identity_oauth:start(),\n identity_oauth:register_client(O, svc, confidential, sk, [uri1]),\n case identity_oauth:client_credentials(O, svc, sk, batch) of\n {ok, _, _} -> pair;\n {ok, _} -> single;\n {error, W} -> W\n end"))
|
||||
"single")
|
||||
|
||||
;; ── authentication failures ──────────────────────────────────────
|
||||
|
||||
(id-grants-test
|
||||
"a wrong client secret is invalid_client"
|
||||
(idgnm
|
||||
(idg-ev
|
||||
"O = identity_oauth:start(),\n identity_oauth:register_client(O, svc, confidential, sk, [uri1]),\n case identity_oauth:client_credentials(O, svc, wrong, batch) of\n {ok, _} -> issued;\n {error, W} -> W\n end"))
|
||||
"invalid_client")
|
||||
|
||||
(id-grants-test
|
||||
"a public client cannot use client-credentials"
|
||||
(idgnm
|
||||
(idg-ev
|
||||
"O = identity_oauth:start(),\n identity_oauth:register_client(O, spa, public, none, [uri1]),\n case identity_oauth:client_credentials(O, spa, none, batch) of\n {ok, _} -> issued;\n {error, W} -> W\n end"))
|
||||
"unauthorized_client")
|
||||
|
||||
(id-grants-test
|
||||
"an unregistered client cannot use client-credentials"
|
||||
(idgnm
|
||||
(idg-ev
|
||||
"O = identity_oauth:start(),\n case identity_oauth:client_credentials(O, ghost, x, batch) of\n {ok, _} -> issued;\n {error, W} -> W\n end"))
|
||||
"invalid_client")
|
||||
|
||||
;; ── independence + real revocation for client tokens ─────────────
|
||||
|
||||
(id-grants-test
|
||||
"two confidential clients get independent tokens"
|
||||
(idgnm
|
||||
(idg-ev
|
||||
"O = identity_oauth:start(),\n identity_oauth:register_client(O, svc1, confidential, k1, [uri1]),\n identity_oauth:register_client(O, svc2, confidential, k2, [uri1]),\n {ok, _T1} = identity_oauth:client_credentials(O, svc1, k1, batch),\n {ok, T2} = identity_oauth:client_credentials(O, svc2, k2, batch),\n case identity_oauth:introspect(O, T2) of\n {active, Subject, _, _} -> Subject\n end"))
|
||||
"svc2")
|
||||
|
||||
(id-grants-test
|
||||
"a client-credentials token can be revoked"
|
||||
(idgnm
|
||||
(idg-ev
|
||||
"O = identity_oauth:start(),\n identity_oauth:register_client(O, svc, confidential, sk, [uri1]),\n {ok, T} = identity_oauth:client_credentials(O, svc, sk, batch),\n identity_oauth:revoke(O, T),\n case identity_oauth:introspect(O, T) of\n {active, _, _, _} -> still_valid;\n {inactive} -> inactive\n end"))
|
||||
"inactive")
|
||||
|
||||
(define
|
||||
id-grants-test-summary
|
||||
(str "grants " id-grants-test-pass "/" id-grants-test-count))
|
||||
93
lib/identity/tests/introspect.sx
Normal file
93
lib/identity/tests/introspect.sx
Normal file
@@ -0,0 +1,93 @@
|
||||
;; identity/tests/introspect.sx — RFC 7662 §2.2 full introspection metadata
|
||||
;; (sub, client_id, scope, exp, iat, token_type) alongside the live-lookup
|
||||
;; active/inactive semantics.
|
||||
|
||||
(define id-intr-test-count 0)
|
||||
(define id-intr-test-pass 0)
|
||||
(define id-intr-test-fails (list))
|
||||
|
||||
(define
|
||||
id-intr-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(set! id-intr-test-count (+ id-intr-test-count 1))
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! id-intr-test-pass (+ id-intr-test-pass 1))
|
||||
(append! id-intr-test-fails {:name name :expected expected :actual actual}))))
|
||||
|
||||
(define idi-ev erlang-eval-ast)
|
||||
(define idinm (fn (v) (get v :name)))
|
||||
|
||||
(identity-load-token!)
|
||||
|
||||
;; ── metadata fields ──────────────────────────────────────────────
|
||||
|
||||
(id-intr-test
|
||||
"introspect_full reports token_type bearer"
|
||||
(idinm
|
||||
(idi-ev
|
||||
"R = identity_tokens:start(),\n {ok, T} = identity_tokens:issue(R, alice, web, read, 100),\n case identity_tokens:introspect_full(R, T) of\n {active, _, _, _, _, _, Tt} -> Tt;\n {inactive} -> inactive\n end"))
|
||||
"bearer")
|
||||
|
||||
(id-intr-test
|
||||
"introspect_full reports the subject"
|
||||
(idinm
|
||||
(idi-ev
|
||||
"R = identity_tokens:start(),\n {ok, T} = identity_tokens:issue(R, alice, web, read, 100),\n case identity_tokens:introspect_full(R, T) of\n {active, Sub, _, _, _, _, _} -> Sub\n end"))
|
||||
"alice")
|
||||
|
||||
(id-intr-test
|
||||
"introspect_full reports the client_id"
|
||||
(idinm
|
||||
(idi-ev
|
||||
"R = identity_tokens:start(),\n {ok, T} = identity_tokens:issue(R, alice, mobile, read, 100),\n case identity_tokens:introspect_full(R, T) of\n {active, _, Cl, _, _, _, _} -> Cl\n end"))
|
||||
"mobile")
|
||||
|
||||
(id-intr-test
|
||||
"introspect_full reports the scope"
|
||||
(idinm
|
||||
(idi-ev
|
||||
"R = identity_tokens:start(),\n {ok, T} = identity_tokens:issue(R, alice, web, write, 100),\n case identity_tokens:introspect_full(R, T) of\n {active, _, _, Sc, _, _, _} -> Sc\n end"))
|
||||
"write")
|
||||
|
||||
;; ── exp / iat reflect the logical clock ──────────────────────────
|
||||
|
||||
(id-intr-test
|
||||
"iat is the clock value at issue"
|
||||
(idi-ev
|
||||
"R = identity_tokens:start(),\n identity_tokens:advance(R, 7),\n {ok, T} = identity_tokens:issue(R, alice, web, read, 100),\n case identity_tokens:introspect_full(R, T) of\n {active, _, _, _, _, Iat, _} -> Iat\n end")
|
||||
7)
|
||||
|
||||
(id-intr-test
|
||||
"exp is iat plus the ttl"
|
||||
(idi-ev
|
||||
"R = identity_tokens:start(),\n identity_tokens:advance(R, 7),\n {ok, T} = identity_tokens:issue(R, alice, web, read, 100),\n case identity_tokens:introspect_full(R, T) of\n {active, _, _, _, Exp, Iat, _} -> Exp - Iat\n end")
|
||||
100)
|
||||
|
||||
;; ── inactive / expired / revoked ─────────────────────────────────
|
||||
|
||||
(id-intr-test
|
||||
"an expired token introspects inactive in full mode too"
|
||||
(idinm
|
||||
(idi-ev
|
||||
"R = identity_tokens:start(),\n {ok, T} = identity_tokens:issue(R, alice, web, read, 100),\n identity_tokens:advance(R, 100),\n case identity_tokens:introspect_full(R, T) of\n {active, _, _, _, _, _, _} -> active;\n {inactive} -> inactive\n end"))
|
||||
"inactive")
|
||||
|
||||
(id-intr-test
|
||||
"a revoked token introspects inactive in full mode"
|
||||
(idinm
|
||||
(idi-ev
|
||||
"R = identity_tokens:start(),\n {ok, T} = identity_tokens:issue(R, alice, web, read),\n identity_tokens:revoke(R, T),\n case identity_tokens:introspect_full(R, T) of\n {active, _, _, _, _, _, _} -> active;\n {inactive} -> inactive\n end"))
|
||||
"inactive")
|
||||
|
||||
(id-intr-test
|
||||
"an unknown token introspects inactive in full mode"
|
||||
(idinm
|
||||
(idi-ev
|
||||
"R = identity_tokens:start(),\n Bogus = make_ref(),\n case identity_tokens:introspect_full(R, Bogus) of\n {active, _, _, _, _, _, _} -> active;\n {inactive} -> inactive\n end"))
|
||||
"inactive")
|
||||
|
||||
(define
|
||||
id-intr-test-summary
|
||||
(str "introspect " id-intr-test-pass "/" id-intr-test-count))
|
||||
155
lib/identity/tests/membership.sx
Normal file
155
lib/identity/tests/membership.sx
Normal file
@@ -0,0 +1,155 @@
|
||||
;; identity/tests/membership.sx — membership state machine + per-app
|
||||
;; grant projection. Valid transitions advance state; invalid ones are
|
||||
;; explicit errors. The projection renders one canonical state per app.
|
||||
|
||||
(define id-membership-test-count 0)
|
||||
(define id-membership-test-pass 0)
|
||||
(define id-membership-test-fails (list))
|
||||
|
||||
(define
|
||||
id-membership-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(set! id-membership-test-count (+ id-membership-test-count 1))
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! id-membership-test-pass (+ id-membership-test-pass 1))
|
||||
(append! id-membership-test-fails {:name name :expected expected :actual actual}))))
|
||||
|
||||
(define idm-ev erlang-eval-ast)
|
||||
(define idmnm (fn (v) (get v :name)))
|
||||
|
||||
(identity-load-membership!)
|
||||
|
||||
;; ── request → pending → approve → active ─────────────────────────
|
||||
|
||||
(id-membership-test
|
||||
"request leaves the subject pending"
|
||||
(idmnm
|
||||
(idm-ev
|
||||
"M = identity_membership:start(),\n identity_membership:request(M, alice, basic),\n case identity_membership:status(M, alice) of\n {ok, St, _} -> St;\n {none} -> none\n end"))
|
||||
"pending")
|
||||
|
||||
(id-membership-test
|
||||
"approve activates a pending membership"
|
||||
(idmnm
|
||||
(idm-ev
|
||||
"M = identity_membership:start(),\n identity_membership:request(M, alice, basic),\n identity_membership:approve(M, alice),\n case identity_membership:status(M, alice) of\n {ok, St, _} -> St;\n {none} -> none\n end"))
|
||||
"active")
|
||||
|
||||
(id-membership-test
|
||||
"status keeps the requested tier"
|
||||
(idmnm
|
||||
(idm-ev
|
||||
"M = identity_membership:start(),\n identity_membership:request(M, alice, supporter),\n identity_membership:approve(M, alice),\n case identity_membership:status(M, alice) of\n {ok, _, Tier} -> Tier\n end"))
|
||||
"supporter")
|
||||
|
||||
;; ── guarded transitions: invalid moves are explicit errors ───────
|
||||
|
||||
(id-membership-test
|
||||
"requesting twice is an error"
|
||||
(idmnm
|
||||
(idm-ev
|
||||
"M = identity_membership:start(),\n identity_membership:request(M, alice, basic),\n case identity_membership:request(M, alice, basic) of\n ok -> ok;\n {error, Why} -> Why\n end"))
|
||||
"exists")
|
||||
|
||||
(id-membership-test
|
||||
"approving an unknown subject is not_found"
|
||||
(idmnm
|
||||
(idm-ev
|
||||
"M = identity_membership:start(),\n case identity_membership:approve(M, ghost) of\n ok -> ok;\n {error, Why} -> Why\n end"))
|
||||
"not_found")
|
||||
|
||||
(id-membership-test
|
||||
"approving an already-active membership is an error"
|
||||
(idmnm
|
||||
(idm-ev
|
||||
"M = identity_membership:start(),\n identity_membership:request(M, alice, basic),\n identity_membership:approve(M, alice),\n case identity_membership:approve(M, alice) of\n ok -> ok;\n {error, Why} -> Why\n end"))
|
||||
"active")
|
||||
|
||||
;; ── lapse / reinstate ────────────────────────────────────────────
|
||||
|
||||
(id-membership-test
|
||||
"active member can lapse"
|
||||
(idmnm
|
||||
(idm-ev
|
||||
"M = identity_membership:start(),\n identity_membership:request(M, alice, basic),\n identity_membership:approve(M, alice),\n identity_membership:lapse(M, alice),\n case identity_membership:status(M, alice) of\n {ok, St, _} -> St\n end"))
|
||||
"lapsed")
|
||||
|
||||
(id-membership-test
|
||||
"lapsing a pending membership is an error"
|
||||
(idmnm
|
||||
(idm-ev
|
||||
"M = identity_membership:start(),\n identity_membership:request(M, alice, basic),\n case identity_membership:lapse(M, alice) of\n ok -> ok;\n {error, Why} -> Why\n end"))
|
||||
"pending")
|
||||
|
||||
(id-membership-test
|
||||
"lapsed member can reinstate to active"
|
||||
(idmnm
|
||||
(idm-ev
|
||||
"M = identity_membership:start(),\n identity_membership:request(M, alice, basic),\n identity_membership:approve(M, alice),\n identity_membership:lapse(M, alice),\n identity_membership:reinstate(M, alice),\n case identity_membership:status(M, alice) of\n {ok, St, _} -> St\n end"))
|
||||
"active")
|
||||
|
||||
;; ── revoke is terminal ───────────────────────────────────────────
|
||||
|
||||
(id-membership-test
|
||||
"any member can be revoked"
|
||||
(idmnm
|
||||
(idm-ev
|
||||
"M = identity_membership:start(),\n identity_membership:request(M, alice, basic),\n identity_membership:approve(M, alice),\n identity_membership:revoke(M, alice),\n case identity_membership:status(M, alice) of\n {ok, St, _} -> St\n end"))
|
||||
"revoked")
|
||||
|
||||
(id-membership-test
|
||||
"a revoked membership cannot be reinstated"
|
||||
(idmnm
|
||||
(idm-ev
|
||||
"M = identity_membership:start(),\n identity_membership:request(M, alice, basic),\n identity_membership:approve(M, alice),\n identity_membership:revoke(M, alice),\n case identity_membership:reinstate(M, alice) of\n ok -> ok;\n {error, Why} -> Why\n end"))
|
||||
"revoked")
|
||||
|
||||
;; ── per-app grant projection ─────────────────────────────────────
|
||||
|
||||
(id-membership-test
|
||||
"active member projects as member"
|
||||
(idmnm
|
||||
(idm-ev
|
||||
"M = identity_membership:start(),\n identity_membership:request(M, alice, basic),\n identity_membership:approve(M, alice),\n case identity_membership:project(M, alice, blog) of\n {member, _, _} -> member;\n {Tag, _} -> Tag\n end"))
|
||||
"member")
|
||||
|
||||
(id-membership-test
|
||||
"projection carries the requesting app"
|
||||
(idmnm
|
||||
(idm-ev
|
||||
"M = identity_membership:start(),\n identity_membership:request(M, alice, basic),\n identity_membership:approve(M, alice),\n case identity_membership:project(M, alice, market) of\n {member, _, App} -> App\n end"))
|
||||
"market")
|
||||
|
||||
(id-membership-test
|
||||
"the same subject projects consistently across apps"
|
||||
(idmnm
|
||||
(idm-ev
|
||||
"M = identity_membership:start(),\n identity_membership:request(M, alice, supporter),\n identity_membership:approve(M, alice),\n {member, T1, blog} = identity_membership:project(M, alice, blog),\n {member, T2, events} = identity_membership:project(M, alice, events),\n case T1 =:= T2 of\n true -> T1;\n false -> mismatch\n end"))
|
||||
"supporter")
|
||||
|
||||
(id-membership-test
|
||||
"unknown subject projects as non_member"
|
||||
(idmnm
|
||||
(idm-ev
|
||||
"M = identity_membership:start(),\n case identity_membership:project(M, ghost, blog) of\n {Tag, _} -> Tag;\n {Tag, _, _} -> Tag\n end"))
|
||||
"non_member")
|
||||
|
||||
(id-membership-test
|
||||
"lapsed member projects as lapsed"
|
||||
(idmnm
|
||||
(idm-ev
|
||||
"M = identity_membership:start(),\n identity_membership:request(M, alice, basic),\n identity_membership:approve(M, alice),\n identity_membership:lapse(M, alice),\n case identity_membership:project(M, alice, blog) of\n {Tag, _} -> Tag;\n {Tag, _, _} -> Tag\n end"))
|
||||
"lapsed")
|
||||
|
||||
(id-membership-test
|
||||
"revoked member projects as denied"
|
||||
(idmnm
|
||||
(idm-ev
|
||||
"M = identity_membership:start(),\n identity_membership:request(M, alice, basic),\n identity_membership:approve(M, alice),\n identity_membership:revoke(M, alice),\n case identity_membership:project(M, alice, blog) of\n {Tag, _} -> Tag;\n {Tag, _, _} -> Tag\n end"))
|
||||
"denied")
|
||||
|
||||
(define
|
||||
id-membership-test-summary
|
||||
(str "membership " id-membership-test-pass "/" id-membership-test-count))
|
||||
192
lib/identity/tests/oauth.sx
Normal file
192
lib/identity/tests/oauth.sx
Normal file
@@ -0,0 +1,192 @@
|
||||
;; identity/tests/oauth.sx — OAuth2 authorization-code flow (RFC 6749
|
||||
;; §4.1) + PKCE (RFC 7636) + refresh grant (§6). Covers the full happy
|
||||
;; path end-to-end (code exchange → access+refresh → refresh rotation) and
|
||||
;; every rejection: denied consent, single-use codes, client/redirect
|
||||
;; binding, PKCE mismatch, unknown code/request, refresh-token reuse, and
|
||||
;; revoke-then-use (which must fail).
|
||||
|
||||
(define id-oauth-test-count 0)
|
||||
(define id-oauth-test-pass 0)
|
||||
(define id-oauth-test-fails (list))
|
||||
|
||||
(define
|
||||
id-oauth-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(set! id-oauth-test-count (+ id-oauth-test-count 1))
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! id-oauth-test-pass (+ id-oauth-test-pass 1))
|
||||
(append! id-oauth-test-fails {:name name :expected expected :actual actual}))))
|
||||
|
||||
(define ido-ev erlang-eval-ast)
|
||||
(define idonm (fn (v) (get v :name)))
|
||||
|
||||
(identity-load-token!)
|
||||
(identity-load-oauth!)
|
||||
|
||||
;; Shared prelude: authorize + consent(allow) leaving Code bound.
|
||||
(define
|
||||
ido-granted
|
||||
"O = identity_oauth:start(),\n {consent_required, ReqId} =\n identity_oauth:authorize(O, webapp, uri1, read, alice, verif1),\n {code, Code} = identity_oauth:consent(O, ReqId, allow)")
|
||||
|
||||
;; ── full happy path ──────────────────────────────────────────────
|
||||
|
||||
(id-oauth-test
|
||||
"authorize asks for consent"
|
||||
(idonm
|
||||
(ido-ev
|
||||
"O = identity_oauth:start(),\n case identity_oauth:authorize(O, webapp, uri1, read, alice, verif1) of\n {consent_required, _} -> consent_required;\n Other -> Other\n end"))
|
||||
"consent_required")
|
||||
|
||||
(id-oauth-test
|
||||
"consent(allow) returns a code"
|
||||
(idonm (ido-ev (str ido-granted ", case Code of _ -> issued end")))
|
||||
"issued")
|
||||
|
||||
(id-oauth-test
|
||||
"exchanged access token introspects active"
|
||||
(idonm
|
||||
(ido-ev
|
||||
(str
|
||||
ido-granted
|
||||
", {ok, Tok, _R} = identity_oauth:exchange(O, Code, webapp, uri1, verif1),\n case identity_oauth:introspect(O, Tok) of\n {active, _, _, _} -> active;\n {inactive} -> inactive\n end")))
|
||||
"active")
|
||||
|
||||
(id-oauth-test
|
||||
"exchanged token carries the authorized subject"
|
||||
(idonm
|
||||
(ido-ev
|
||||
(str
|
||||
ido-granted
|
||||
", {ok, Tok, _R} = identity_oauth:exchange(O, Code, webapp, uri1, verif1),\n case identity_oauth:introspect(O, Tok) of\n {active, Subject, _, _} -> Subject\n end")))
|
||||
"alice")
|
||||
|
||||
(id-oauth-test
|
||||
"exchanged token carries the authorized scope"
|
||||
(idonm
|
||||
(ido-ev
|
||||
(str
|
||||
ido-granted
|
||||
", {ok, Tok, _R} = identity_oauth:exchange(O, Code, webapp, uri1, verif1),\n case identity_oauth:introspect(O, Tok) of\n {active, _, _, Scope} -> Scope\n end")))
|
||||
"read")
|
||||
|
||||
;; ── refresh grant (RFC 6749 §6) end-to-end ───────────────────────
|
||||
|
||||
(id-oauth-test
|
||||
"refresh after exchange yields a working access token"
|
||||
(idonm
|
||||
(ido-ev
|
||||
(str
|
||||
ido-granted
|
||||
", {ok, _A, R} = identity_oauth:exchange(O, Code, webapp, uri1, verif1),\n {ok, A2, _R2} = identity_oauth:refresh(O, R),\n case identity_oauth:introspect(O, A2) of\n {active, _, _, _} -> active;\n {inactive} -> inactive\n end")))
|
||||
"active")
|
||||
|
||||
(id-oauth-test
|
||||
"reusing a rotated refresh token is invalid_grant"
|
||||
(idonm
|
||||
(ido-ev
|
||||
(str
|
||||
ido-granted
|
||||
", {ok, _A, R} = identity_oauth:exchange(O, Code, webapp, uri1, verif1),\n {ok, _A2, _R2} = identity_oauth:refresh(O, R),\n case identity_oauth:refresh(O, R) of\n {ok, _, _} -> rotated;\n {error, Why} -> Why\n end")))
|
||||
"invalid_grant")
|
||||
|
||||
;; ── consent denied (§4.1.2.1) ────────────────────────────────────
|
||||
|
||||
(id-oauth-test
|
||||
"denied consent yields access_denied"
|
||||
(idonm
|
||||
(ido-ev
|
||||
"O = identity_oauth:start(),\n {consent_required, ReqId} =\n identity_oauth:authorize(O, webapp, uri1, read, alice, verif1),\n case identity_oauth:consent(O, ReqId, deny) of\n {error, Why} -> Why;\n {code, _} -> issued\n end"))
|
||||
"access_denied")
|
||||
|
||||
;; ── single-use codes (§10.5) ─────────────────────────────────────
|
||||
|
||||
(id-oauth-test
|
||||
"code cannot be exchanged twice"
|
||||
(idonm
|
||||
(ido-ev
|
||||
(str
|
||||
ido-granted
|
||||
", identity_oauth:exchange(O, Code, webapp, uri1, verif1),\n case identity_oauth:exchange(O, Code, webapp, uri1, verif1) of\n {ok, _, _} -> replayed;\n {error, Why} -> Why\n end")))
|
||||
"invalid_grant")
|
||||
|
||||
;; ── code binding to client + redirect_uri (§4.1.3) ───────────────
|
||||
|
||||
(id-oauth-test
|
||||
"exchange with wrong client is invalid_grant"
|
||||
(idonm
|
||||
(ido-ev
|
||||
(str
|
||||
ido-granted
|
||||
", case identity_oauth:exchange(O, Code, attacker, uri1, verif1) of\n {ok, _, _} -> ok;\n {error, Why} -> Why\n end")))
|
||||
"invalid_grant")
|
||||
|
||||
(id-oauth-test
|
||||
"exchange with wrong redirect_uri is invalid_grant"
|
||||
(idonm
|
||||
(ido-ev
|
||||
(str
|
||||
ido-granted
|
||||
", case identity_oauth:exchange(O, Code, webapp, evil_uri, verif1) of\n {ok, _, _} -> ok;\n {error, Why} -> Why\n end")))
|
||||
"invalid_grant")
|
||||
|
||||
;; ── PKCE verifier mismatch (RFC 7636) ────────────────────────────
|
||||
|
||||
(id-oauth-test
|
||||
"exchange with wrong PKCE verifier is invalid_grant"
|
||||
(idonm
|
||||
(ido-ev
|
||||
(str
|
||||
ido-granted
|
||||
", case identity_oauth:exchange(O, Code, webapp, uri1, badverif) of\n {ok, _, _} -> ok;\n {error, Why} -> Why\n end")))
|
||||
"invalid_grant")
|
||||
|
||||
;; ── unknown code / request ───────────────────────────────────────
|
||||
|
||||
(id-oauth-test
|
||||
"exchanging an unknown code is invalid_grant"
|
||||
(idonm
|
||||
(ido-ev
|
||||
"O = identity_oauth:start(),\n Bogus = make_ref(),\n case identity_oauth:exchange(O, Bogus, webapp, uri1, verif1) of\n {ok, _, _} -> ok;\n {error, Why} -> Why\n end"))
|
||||
"invalid_grant")
|
||||
|
||||
(id-oauth-test
|
||||
"consent on an unknown request is unknown_request"
|
||||
(idonm
|
||||
(ido-ev
|
||||
"O = identity_oauth:start(),\n Bogus = make_ref(),\n case identity_oauth:consent(O, Bogus, allow) of\n {code, _} -> issued;\n {error, Why} -> Why\n end"))
|
||||
"unknown_request")
|
||||
|
||||
;; ── revoke-then-use must fail (RFC 7009) ─────────────────────────
|
||||
|
||||
(id-oauth-test
|
||||
"revoked exchanged token introspects inactive"
|
||||
(idonm
|
||||
(ido-ev
|
||||
(str
|
||||
ido-granted
|
||||
", {ok, Tok, _R} = identity_oauth:exchange(O, Code, webapp, uri1, verif1),\n identity_oauth:revoke(O, Tok),\n case identity_oauth:introspect(O, Tok) of\n {active, _, _, _} -> still_valid;\n {inactive} -> inactive\n end")))
|
||||
"inactive")
|
||||
|
||||
(id-oauth-test
|
||||
"revoking the access token blocks a later refresh (cascade)"
|
||||
(idonm
|
||||
(ido-ev
|
||||
(str
|
||||
ido-granted
|
||||
", {ok, A, R} = identity_oauth:exchange(O, Code, webapp, uri1, verif1),\n identity_oauth:revoke(O, A),\n case identity_oauth:refresh(O, R) of\n {ok, _, _} -> refreshed;\n {error, Why} -> Why\n end")))
|
||||
"invalid_grant")
|
||||
|
||||
;; ── independence: two concurrent authorizations don't collide ────
|
||||
|
||||
(id-oauth-test
|
||||
"two authorizations issue independent grants"
|
||||
(idonm
|
||||
(ido-ev
|
||||
"O = identity_oauth:start(),\n {consent_required, R1} =\n identity_oauth:authorize(O, webapp, uri1, read, alice, va),\n {consent_required, R2} =\n identity_oauth:authorize(O, cli, uri2, write, bob, vb),\n {code, C1} = identity_oauth:consent(O, R1, allow),\n {code, C2} = identity_oauth:consent(O, R2, allow),\n {ok, _A1, _RR1} = identity_oauth:exchange(O, C1, webapp, uri1, va),\n {ok, A2, _RR2} = identity_oauth:exchange(O, C2, cli, uri2, vb),\n case identity_oauth:introspect(O, A2) of\n {active, Subject, _, _} -> Subject\n end"))
|
||||
"bob")
|
||||
|
||||
(define
|
||||
id-oauth-test-summary
|
||||
(str "oauth " id-oauth-test-pass "/" id-oauth-test-count))
|
||||
84
lib/identity/tests/par.sx
Normal file
84
lib/identity/tests/par.sx
Normal file
@@ -0,0 +1,84 @@
|
||||
;; identity/tests/par.sx — pushed authorization requests (PAR, RFC 9126):
|
||||
;; lodge the authorization params up front under a single-use request_uri,
|
||||
;; then redeem it into the normal consent flow. The binding (client,
|
||||
;; redirect, PKCE) carried by the pushed request is enforced at exchange.
|
||||
|
||||
(define id-par-test-count 0)
|
||||
(define id-par-test-pass 0)
|
||||
(define id-par-test-fails (list))
|
||||
|
||||
(define
|
||||
id-par-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(set! id-par-test-count (+ id-par-test-count 1))
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! id-par-test-pass (+ id-par-test-pass 1))
|
||||
(append! id-par-test-fails {:name name :expected expected :actual actual}))))
|
||||
|
||||
(define idp-ev erlang-eval-ast)
|
||||
(define idpnm (fn (v) (get v :name)))
|
||||
|
||||
(identity-load-oauth!)
|
||||
|
||||
;; ── pushed request redeems into consent ──────────────────────────
|
||||
|
||||
(id-par-test
|
||||
"authorize_pushed on a fresh request_uri asks for consent"
|
||||
(idpnm
|
||||
(idp-ev
|
||||
"O = identity_oauth:start(),\n {ok, Ru} = identity_oauth:push_authorization_request(O, web, uri1, read, alice, v),\n case identity_oauth:authorize_pushed(O, Ru) of\n {consent_required, _} -> consent_required;\n {error, W} -> W\n end"))
|
||||
"consent_required")
|
||||
|
||||
;; ── full PAR flow ────────────────────────────────────────────────
|
||||
|
||||
(id-par-test
|
||||
"the full PAR flow yields a working token"
|
||||
(idpnm
|
||||
(idp-ev
|
||||
"O = identity_oauth:start(),\n {ok, Ru} = identity_oauth:push_authorization_request(O, web, uri1, read, alice, v),\n {consent_required, Rq} = identity_oauth:authorize_pushed(O, Ru),\n {code, Cd} = identity_oauth:consent(O, Rq, allow),\n {ok, A, _R} = identity_oauth:exchange(O, Cd, web, uri1, v),\n case identity_oauth:introspect(O, A) of\n {active, _, _, _} -> active;\n {inactive} -> inactive\n end"))
|
||||
"active")
|
||||
|
||||
(id-par-test
|
||||
"the PAR token carries the pushed subject"
|
||||
(idpnm
|
||||
(idp-ev
|
||||
"O = identity_oauth:start(),\n {ok, Ru} = identity_oauth:push_authorization_request(O, web, uri1, read, alice, v),\n {consent_required, Rq} = identity_oauth:authorize_pushed(O, Ru),\n {code, Cd} = identity_oauth:consent(O, Rq, allow),\n {ok, A, _R} = identity_oauth:exchange(O, Cd, web, uri1, v),\n case identity_oauth:introspect(O, A) of\n {active, Subject, _, _} -> Subject\n end"))
|
||||
"alice")
|
||||
|
||||
;; ── request_uri is single-use ────────────────────────────────────
|
||||
|
||||
(id-par-test
|
||||
"a request_uri cannot be redeemed twice"
|
||||
(idpnm
|
||||
(idp-ev
|
||||
"O = identity_oauth:start(),\n {ok, Ru} = identity_oauth:push_authorization_request(O, web, uri1, read, alice, v),\n identity_oauth:authorize_pushed(O, Ru),\n case identity_oauth:authorize_pushed(O, Ru) of\n {consent_required, _} -> reused;\n {error, W} -> W\n end"))
|
||||
"invalid_request_uri")
|
||||
|
||||
(id-par-test
|
||||
"an unknown request_uri is rejected"
|
||||
(idpnm
|
||||
(idp-ev
|
||||
"O = identity_oauth:start(),\n Bogus = make_ref(),\n case identity_oauth:authorize_pushed(O, Bogus) of\n {consent_required, _} -> ok;\n {error, W} -> W\n end"))
|
||||
"invalid_request_uri")
|
||||
|
||||
;; ── the pushed binding is still enforced at exchange ─────────────
|
||||
|
||||
(id-par-test
|
||||
"a PAR-issued code still enforces PKCE"
|
||||
(idpnm
|
||||
(idp-ev
|
||||
"O = identity_oauth:start(),\n {ok, Ru} = identity_oauth:push_authorization_request(O, web, uri1, read, alice, v),\n {consent_required, Rq} = identity_oauth:authorize_pushed(O, Ru),\n {code, Cd} = identity_oauth:consent(O, Rq, allow),\n case identity_oauth:exchange(O, Cd, web, uri1, wrongverif) of\n {ok, _, _} -> ok;\n {error, W} -> W\n end"))
|
||||
"invalid_grant")
|
||||
|
||||
(id-par-test
|
||||
"a PAR-issued code still enforces client binding"
|
||||
(idpnm
|
||||
(idp-ev
|
||||
"O = identity_oauth:start(),\n {ok, Ru} = identity_oauth:push_authorization_request(O, web, uri1, read, alice, v),\n {consent_required, Rq} = identity_oauth:authorize_pushed(O, Ru),\n {code, Cd} = identity_oauth:consent(O, Rq, allow),\n case identity_oauth:exchange(O, Cd, attacker, uri1, v) of\n {ok, _, _} -> ok;\n {error, W} -> W\n end"))
|
||||
"invalid_grant")
|
||||
|
||||
(define
|
||||
id-par-test-summary
|
||||
(str "par " id-par-test-pass "/" id-par-test-count))
|
||||
99
lib/identity/tests/registry.sx
Normal file
99
lib/identity/tests/registry.sx
Normal file
@@ -0,0 +1,99 @@
|
||||
;; identity/tests/registry.sx — routing by id and by (subject, client),
|
||||
;; SSO fan-out (one subject, many clients), and integration with live
|
||||
;; session processes routed through the registry.
|
||||
|
||||
(define id-registry-test-count 0)
|
||||
(define id-registry-test-pass 0)
|
||||
(define id-registry-test-fails (list))
|
||||
|
||||
(define
|
||||
id-registry-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(set! id-registry-test-count (+ id-registry-test-count 1))
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! id-registry-test-pass (+ id-registry-test-pass 1))
|
||||
(append! id-registry-test-fails {:name name :expected expected :actual actual}))))
|
||||
|
||||
(define idr-ev erlang-eval-ast)
|
||||
(define idrnm (fn (v) (get v :name)))
|
||||
|
||||
(identity-load-session!)
|
||||
(identity-load-registry!)
|
||||
|
||||
;; ── whereis by session id ────────────────────────────────────────
|
||||
|
||||
(id-registry-test
|
||||
"registered session is found by id"
|
||||
(idrnm
|
||||
(idr-ev
|
||||
"Me = self(),\n Reg = identity_registry:start(),\n identity_registry:register(Reg, s1, alice, web, Me),\n case identity_registry:whereis_session(Reg, s1) of\n {ok, _} -> found;\n {error, _} -> missing\n end"))
|
||||
"found")
|
||||
|
||||
(id-registry-test
|
||||
"unknown session id is not_found, not a crash"
|
||||
(idrnm
|
||||
(idr-ev
|
||||
"Reg = identity_registry:start(),\n case identity_registry:whereis_session(Reg, nope) of\n {ok, _} -> found;\n {error, Why} -> Why\n end"))
|
||||
"not_found")
|
||||
|
||||
;; ── lookup by (subject, client) — the SSO probe ──────────────────
|
||||
|
||||
(id-registry-test
|
||||
"lookup finds a session for subject+client"
|
||||
(idrnm
|
||||
(idr-ev
|
||||
"Me = self(),\n Reg = identity_registry:start(),\n identity_registry:register(Reg, s1, alice, web, Me),\n case identity_registry:lookup(Reg, alice, web) of\n {ok, _} -> found;\n {error, _} -> missing\n end"))
|
||||
"found")
|
||||
|
||||
(id-registry-test
|
||||
"lookup is precise: right subject, wrong client misses"
|
||||
(idrnm
|
||||
(idr-ev
|
||||
"Me = self(),\n Reg = identity_registry:start(),\n identity_registry:register(Reg, s1, alice, web, Me),\n case identity_registry:lookup(Reg, alice, cli) of\n {ok, _} -> found;\n {error, _} -> missing\n end"))
|
||||
"missing")
|
||||
|
||||
;; ── SSO fan-out: one subject, many clients ───────────────────────
|
||||
|
||||
(id-registry-test
|
||||
"sessions_for returns all of a subject's sessions"
|
||||
(idr-ev
|
||||
"Me = self(),\n Reg = identity_registry:start(),\n identity_registry:register(Reg, s1, alice, web, Me),\n identity_registry:register(Reg, s2, alice, cli, Me),\n identity_registry:register(Reg, s3, bob, web, Me),\n case identity_registry:sessions_for(Reg, alice) of\n {ok, L} -> length(L)\n end")
|
||||
2)
|
||||
|
||||
(id-registry-test
|
||||
"sessions_for an unknown subject is empty"
|
||||
(idr-ev
|
||||
"Reg = identity_registry:start(),\n case identity_registry:sessions_for(Reg, ghost) of\n {ok, L} -> length(L)\n end")
|
||||
0)
|
||||
|
||||
;; ── re-register replaces the row for that id (no duplicates) ──────
|
||||
|
||||
(id-registry-test
|
||||
"re-registering an id does not duplicate it"
|
||||
(idr-ev
|
||||
"Me = self(),\n Reg = identity_registry:start(),\n identity_registry:register(Reg, s1, alice, web, Me),\n identity_registry:register(Reg, s1, alice, web, Me),\n case identity_registry:sessions_for(Reg, alice) of\n {ok, L} -> length(L)\n end")
|
||||
1)
|
||||
|
||||
;; ── deregister removes routing ───────────────────────────────────
|
||||
|
||||
(id-registry-test
|
||||
"deregistered session is no longer found"
|
||||
(idrnm
|
||||
(idr-ev
|
||||
"Me = self(),\n Reg = identity_registry:start(),\n identity_registry:register(Reg, s1, alice, web, Me),\n identity_registry:deregister(Reg, s1),\n case identity_registry:whereis_session(Reg, s1) of\n {ok, _} -> found;\n {error, _} -> missing\n end"))
|
||||
"missing")
|
||||
|
||||
;; ── integration: route to a live session and look it up ──────────
|
||||
|
||||
(id-registry-test
|
||||
"routed-to session answers lookup as active"
|
||||
(idrnm
|
||||
(idr-ev
|
||||
"Me = self(),\n Reg = identity_registry:start(),\n S = identity_session:start(s1, alice, web, Me, infinity),\n identity_registry:register(Reg, s1, alice, web, S),\n {ok, Pid} = identity_registry:lookup(Reg, alice, web),\n case identity_session:lookup(Pid) of\n {ok, {_,_,_,St}} -> St;\n {error, St} -> St\n end"))
|
||||
"active")
|
||||
|
||||
(define
|
||||
id-registry-test-summary
|
||||
(str "registry " id-registry-test-pass "/" id-registry-test-count))
|
||||
118
lib/identity/tests/session.sx
Normal file
118
lib/identity/tests/session.sx
Normal file
@@ -0,0 +1,118 @@
|
||||
;; identity/tests/session.sx — session-as-process: create, lookup,
|
||||
;; touch, explicit expire, revoke, and idle-timeout self-expiry.
|
||||
;; Negative paths are tested as first-class: a tombstoned session
|
||||
;; answers {error, Status}, it does not go silent.
|
||||
|
||||
(define id-session-test-count 0)
|
||||
(define id-session-test-pass 0)
|
||||
(define id-session-test-fails (list))
|
||||
|
||||
(define
|
||||
id-session-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(set! id-session-test-count (+ id-session-test-count 1))
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! id-session-test-pass (+ id-session-test-pass 1))
|
||||
(append! id-session-test-fails {:name name :expected expected :actual actual}))))
|
||||
|
||||
(define id-ev erlang-eval-ast)
|
||||
(define idnm (fn (v) (get v :name)))
|
||||
|
||||
(identity-load-session!)
|
||||
|
||||
;; ── create + lookup ──────────────────────────────────────────────
|
||||
|
||||
(id-session-test
|
||||
"lookup of live session is active"
|
||||
(idnm
|
||||
(id-ev
|
||||
"Me = self(),\n S = identity_session:start(s1, alice, web, Me, infinity),\n case identity_session:lookup(S) of {ok, {_,_,_,St}} -> St end"))
|
||||
"active")
|
||||
|
||||
(id-session-test
|
||||
"lookup preserves subject"
|
||||
(idnm
|
||||
(id-ev
|
||||
"Me = self(),\n S = identity_session:start(s1, alice, web, Me, infinity),\n case identity_session:lookup(S) of {ok, {_,Subject,_,_}} -> Subject end"))
|
||||
"alice")
|
||||
|
||||
(id-session-test
|
||||
"lookup preserves client"
|
||||
(idnm
|
||||
(id-ev
|
||||
"Me = self(),\n S = identity_session:start(s1, alice, web, Me, infinity),\n case identity_session:lookup(S) of {ok, {_,_,Client,_}} -> Client end"))
|
||||
"web")
|
||||
|
||||
;; ── touch keeps a live session ───────────────────────────────────
|
||||
|
||||
(id-session-test
|
||||
"touch on live session is ok"
|
||||
(idnm
|
||||
(id-ev
|
||||
"Me = self(),\n S = identity_session:start(s1, alice, web, Me, infinity),\n identity_session:touch(S)"))
|
||||
"ok")
|
||||
|
||||
;; ── explicit expire ──────────────────────────────────────────────
|
||||
|
||||
(id-session-test
|
||||
"expire then lookup is error expired"
|
||||
(idnm
|
||||
(id-ev
|
||||
"Me = self(),\n S = identity_session:start(s1, alice, web, Me, infinity),\n identity_session:expire(S),\n case identity_session:lookup(S) of {error, St} -> St end"))
|
||||
"expired")
|
||||
|
||||
(id-session-test
|
||||
"touch on expired session is error"
|
||||
(idnm
|
||||
(id-ev
|
||||
"Me = self(),\n S = identity_session:start(s1, alice, web, Me, infinity),\n identity_session:expire(S),\n case identity_session:touch(S) of {error, St} -> St end"))
|
||||
"expired")
|
||||
|
||||
;; ── revoke is immediate ──────────────────────────────────────────
|
||||
|
||||
(id-session-test
|
||||
"revoke then lookup is error revoked"
|
||||
(idnm
|
||||
(id-ev
|
||||
"Me = self(),\n S = identity_session:start(s1, alice, web, Me, infinity),\n identity_session:revoke(S),\n case identity_session:lookup(S) of {error, St} -> St end"))
|
||||
"revoked")
|
||||
|
||||
;; ── idle-timeout self-expiry ─────────────────────────────────────
|
||||
|
||||
(id-session-test
|
||||
"idle timeout notifies owner"
|
||||
(idnm
|
||||
(id-ev
|
||||
"Me = self(),\n S = identity_session:start(s1, alice, web, Me, 50),\n _ = identity_session:lookup(S),\n receive {session_expired, Sid} -> Sid end"))
|
||||
"s1")
|
||||
|
||||
(id-session-test
|
||||
"lookup after idle timeout is error expired"
|
||||
(idnm
|
||||
(id-ev
|
||||
"Me = self(),\n S = identity_session:start(s1, alice, web, Me, 50),\n _ = identity_session:lookup(S),\n receive {session_expired, _} -> ok end,\n case identity_session:lookup(S) of {error, St} -> St end"))
|
||||
"expired")
|
||||
|
||||
;; ── isolation: sessions are independent processes ────────────────
|
||||
|
||||
(id-session-test
|
||||
"expiring one session leaves the other active"
|
||||
(idnm
|
||||
(id-ev
|
||||
"Me = self(),\n A = identity_session:start(s1, alice, web, Me, infinity),\n B = identity_session:start(s2, bob, web, Me, infinity),\n identity_session:expire(A),\n case identity_session:lookup(B) of {ok, {_,_,_,St}} -> St end"))
|
||||
"active")
|
||||
|
||||
;; ── clean stop ───────────────────────────────────────────────────
|
||||
|
||||
(id-session-test
|
||||
"stop returns ok"
|
||||
(idnm
|
||||
(id-ev
|
||||
"Me = self(),\n S = identity_session:start(s1, alice, web, Me, infinity),\n identity_session:stop(S)"))
|
||||
"ok")
|
||||
|
||||
(define
|
||||
id-session-test-summary
|
||||
(str "session " id-session-test-pass "/" id-session-test-count))
|
||||
81
lib/identity/tests/session_mgmt.sx
Normal file
81
lib/identity/tests/session_mgmt.sx
Normal file
@@ -0,0 +1,81 @@
|
||||
;; identity/tests/session_mgmt.sx — subject-wide session management:
|
||||
;; enumerate a subject's sessions and \"log out everywhere\".
|
||||
|
||||
(define id-smgmt-test-count 0)
|
||||
(define id-smgmt-test-pass 0)
|
||||
(define id-smgmt-test-fails (list))
|
||||
|
||||
(define
|
||||
id-smgmt-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(set! id-smgmt-test-count (+ id-smgmt-test-count 1))
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! id-smgmt-test-pass (+ id-smgmt-test-pass 1))
|
||||
(append! id-smgmt-test-fails {:name name :expected expected :actual actual}))))
|
||||
|
||||
(define idsm-ev erlang-eval-ast)
|
||||
(define idsmnm (fn (v) (get v :name)))
|
||||
|
||||
(identity-load-all!)
|
||||
|
||||
;; ── enumerate a subject's sessions ───────────────────────────────
|
||||
|
||||
(id-smgmt-test
|
||||
"sessions lists all of a subject's sessions"
|
||||
(idsm-ev
|
||||
"Svc = identity:start(),\n identity:login(Svc, alice, web, read),\n identity:login(Svc, alice, cli, read),\n length(identity:sessions(Svc, alice))")
|
||||
2)
|
||||
|
||||
(id-smgmt-test
|
||||
"sessions is empty for a subject with none"
|
||||
(idsm-ev
|
||||
"Svc = identity:start(),\n length(identity:sessions(Svc, stranger))")
|
||||
0)
|
||||
|
||||
;; ── log out everywhere ───────────────────────────────────────────
|
||||
|
||||
(id-smgmt-test
|
||||
"logout_all ends every session of the subject"
|
||||
(idsmnm
|
||||
(idsm-ev
|
||||
"Svc = identity:start(),\n {ok, S1, _} = identity:login(Svc, alice, web, read),\n {ok, S2, _} = identity:login(Svc, alice, cli, read),\n identity:logout_all(Svc, alice),\n case {identity:session_status(Svc, S1), identity:session_status(Svc, S2)} of\n {gone, gone} -> both_gone;\n _ -> some_left\n end"))
|
||||
"both_gone")
|
||||
|
||||
(id-smgmt-test
|
||||
"after logout_all the subject has no sessions"
|
||||
(idsm-ev
|
||||
"Svc = identity:start(),\n identity:login(Svc, alice, web, read),\n identity:login(Svc, alice, cli, read),\n identity:logout_all(Svc, alice),\n length(identity:sessions(Svc, alice))")
|
||||
0)
|
||||
|
||||
(id-smgmt-test
|
||||
"logout_all leaves other subjects' sessions intact"
|
||||
(idsm-ev
|
||||
"Svc = identity:start(),\n identity:login(Svc, alice, web, read),\n identity:login(Svc, bob, web, read),\n identity:logout_all(Svc, alice),\n length(identity:sessions(Svc, bob))")
|
||||
1)
|
||||
|
||||
(id-smgmt-test
|
||||
"logout_all on an unknown subject is ok, not a crash"
|
||||
(idsmnm
|
||||
(idsm-ev "Svc = identity:start(),\n identity:logout_all(Svc, ghost)"))
|
||||
"ok")
|
||||
|
||||
;; ── logout_all is audited ────────────────────────────────────────
|
||||
|
||||
(id-smgmt-test
|
||||
"logout_all records a logout event"
|
||||
(idsmnm
|
||||
(idsm-ev
|
||||
"Svc = identity:start(),\n identity:login(Svc, alice, web, read),\n identity:logout_all(Svc, alice),\n case identity:history(Svc, alice) of\n [login, issue, logout] -> audited;\n Other -> Other\n end"))
|
||||
"audited")
|
||||
|
||||
(id-smgmt-test
|
||||
"logout_all audits each of several sessions"
|
||||
(idsm-ev
|
||||
"Svc = identity:start(),\n identity:login(Svc, alice, web, read),\n identity:login(Svc, alice, cli, read),\n identity:logout_all(Svc, alice),\n length(identity:history(Svc, alice))")
|
||||
6)
|
||||
|
||||
(define
|
||||
id-smgmt-test-summary
|
||||
(str "session-mgmt " id-smgmt-test-pass "/" id-smgmt-test-count))
|
||||
115
lib/identity/tests/sso.sx
Normal file
115
lib/identity/tests/sso.sx
Normal file
@@ -0,0 +1,115 @@
|
||||
;; identity/tests/sso.sx — silent SSO (prompt=none, OIDC §3.1.2.1) as a
|
||||
;; fast-path through the authorization-code machine. One subject session,
|
||||
;; many client apps; no session → login_required (a negative state, not a
|
||||
;; redirect). Silently-issued codes carry the same client/redirect/PKCE
|
||||
;; binding as consented codes.
|
||||
|
||||
(define id-sso-test-count 0)
|
||||
(define id-sso-test-pass 0)
|
||||
(define id-sso-test-fails (list))
|
||||
|
||||
(define
|
||||
id-sso-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(set! id-sso-test-count (+ id-sso-test-count 1))
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! id-sso-test-pass (+ id-sso-test-pass 1))
|
||||
(append! id-sso-test-fails {:name name :expected expected :actual actual}))))
|
||||
|
||||
(define ids-ev erlang-eval-ast)
|
||||
(define idsnm (fn (v) (get v :name)))
|
||||
|
||||
(identity-load-token!)
|
||||
(identity-load-session!)
|
||||
(identity-load-registry!)
|
||||
(identity-load-oauth!)
|
||||
|
||||
;; ── no session → login_required ──────────────────────────────────
|
||||
|
||||
(id-sso-test
|
||||
"silent authorize without a session is login_required"
|
||||
(idsnm
|
||||
(ids-ev
|
||||
"O = identity_oauth:start(),\n case identity_oauth:silent_authorize(O, dashboard, uri2, read, alice, vv) of\n {code, _} -> got_code;\n {error, Why} -> Why\n end"))
|
||||
"login_required")
|
||||
|
||||
;; ── established session → silent code ────────────────────────────
|
||||
|
||||
(id-sso-test
|
||||
"silent authorize for the same client returns a code"
|
||||
(idsnm
|
||||
(ids-ev
|
||||
"O = identity_oauth:start(),\n {ok, _Sid} = identity_oauth:establish(O, alice, web),\n case identity_oauth:silent_authorize(O, web, uri1, read, alice, vv) of\n {code, _} -> got_code;\n {error, Why} -> Why\n end"))
|
||||
"got_code")
|
||||
|
||||
;; ── one session, many clients ────────────────────────────────────
|
||||
|
||||
(id-sso-test
|
||||
"a different client gets a silent code off the same session"
|
||||
(idsnm
|
||||
(ids-ev
|
||||
"O = identity_oauth:start(),\n {ok, _Sid} = identity_oauth:establish(O, alice, web),\n case identity_oauth:silent_authorize(O, dashboard, uri2, read, alice, vv) of\n {code, _} -> got_code;\n {error, Why} -> Why\n end"))
|
||||
"got_code")
|
||||
|
||||
(id-sso-test
|
||||
"many clients all silently authorize off one session"
|
||||
(idsnm
|
||||
(ids-ev
|
||||
"O = identity_oauth:start(),\n {ok, _Sid} = identity_oauth:establish(O, alice, web),\n {code, _C1} = identity_oauth:silent_authorize(O, dashboard, uri2, read, alice, vv),\n {code, _C2} = identity_oauth:silent_authorize(O, mobile, uri3, read, alice, vv),\n case identity_oauth:silent_authorize(O, billing, uri4, read, alice, vv) of\n {code, _} -> got_code;\n {error, Why} -> Why\n end"))
|
||||
"got_code")
|
||||
|
||||
;; ── full SSO → token ─────────────────────────────────────────────
|
||||
|
||||
(id-sso-test
|
||||
"silent code exchanges to a working token"
|
||||
(idsnm
|
||||
(ids-ev
|
||||
"O = identity_oauth:start(),\n {ok, _Sid} = identity_oauth:establish(O, alice, web),\n {code, C} = identity_oauth:silent_authorize(O, dashboard, uri2, read, alice, vv),\n {ok, A, _R} = identity_oauth:exchange(O, C, dashboard, uri2, vv),\n case identity_oauth:introspect(O, A) of\n {active, _, _, _} -> active;\n {inactive} -> inactive\n end"))
|
||||
"active")
|
||||
|
||||
(id-sso-test
|
||||
"SSO token carries the subject"
|
||||
(idsnm
|
||||
(ids-ev
|
||||
"O = identity_oauth:start(),\n {ok, _Sid} = identity_oauth:establish(O, alice, web),\n {code, C} = identity_oauth:silent_authorize(O, dashboard, uri2, read, alice, vv),\n {ok, A, _R} = identity_oauth:exchange(O, C, dashboard, uri2, vv),\n case identity_oauth:introspect(O, A) of\n {active, Subject, _, _} -> Subject\n end"))
|
||||
"alice")
|
||||
|
||||
;; ── silent codes keep the full binding ───────────────────────────
|
||||
|
||||
(id-sso-test
|
||||
"silent code still enforces PKCE at exchange"
|
||||
(idsnm
|
||||
(ids-ev
|
||||
"O = identity_oauth:start(),\n {ok, _Sid} = identity_oauth:establish(O, alice, web),\n {code, C} = identity_oauth:silent_authorize(O, dashboard, uri2, read, alice, vv),\n case identity_oauth:exchange(O, C, dashboard, uri2, wrongverif) of\n {ok, _, _} -> ok;\n {error, Why} -> Why\n end"))
|
||||
"invalid_grant")
|
||||
|
||||
(id-sso-test
|
||||
"silent code still enforces client binding at exchange"
|
||||
(idsnm
|
||||
(ids-ev
|
||||
"O = identity_oauth:start(),\n {ok, _Sid} = identity_oauth:establish(O, alice, web),\n {code, C} = identity_oauth:silent_authorize(O, dashboard, uri2, read, alice, vv),\n case identity_oauth:exchange(O, C, attacker, uri2, vv) of\n {ok, _, _} -> ok;\n {error, Why} -> Why\n end"))
|
||||
"invalid_grant")
|
||||
|
||||
;; ── subject scoping: SSO is per subject ──────────────────────────
|
||||
|
||||
(id-sso-test
|
||||
"another subject is still login_required"
|
||||
(idsnm
|
||||
(ids-ev
|
||||
"O = identity_oauth:start(),\n {ok, _Sid} = identity_oauth:establish(O, alice, web),\n case identity_oauth:silent_authorize(O, dashboard, uri2, read, bob, vv) of\n {code, _} -> got_code;\n {error, Why} -> Why\n end"))
|
||||
"login_required")
|
||||
|
||||
;; ── ending the session closes the SSO fast-path ──────────────────
|
||||
|
||||
(id-sso-test
|
||||
"after end_session, silent authorize is login_required"
|
||||
(idsnm
|
||||
(ids-ev
|
||||
"O = identity_oauth:start(),\n {ok, Sid} = identity_oauth:establish(O, alice, web),\n identity_oauth:end_session(O, Sid),\n case identity_oauth:silent_authorize(O, dashboard, uri2, read, alice, vv) of\n {code, _} -> got_code;\n {error, Why} -> Why\n end"))
|
||||
"login_required")
|
||||
|
||||
(define
|
||||
id-sso-test-summary
|
||||
(str "sso " id-sso-test-pass "/" id-sso-test-count))
|
||||
215
lib/identity/tests/token.sx
Normal file
215
lib/identity/tests/token.sx
Normal file
@@ -0,0 +1,215 @@
|
||||
;; identity/tests/token.sx — opaque tokens, grant-backed lookup, real
|
||||
;; revocation, refresh-token rotation, cascading revocation, and scope
|
||||
;; narrowing on refresh. The revoke-then-introspect and refresh-reuse
|
||||
;; paths are the security centrepieces.
|
||||
|
||||
(define id-token-test-count 0)
|
||||
(define id-token-test-pass 0)
|
||||
(define id-token-test-fails (list))
|
||||
|
||||
(define
|
||||
id-token-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(set! id-token-test-count (+ id-token-test-count 1))
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! id-token-test-pass (+ id-token-test-pass 1))
|
||||
(append! id-token-test-fails {:name name :expected expected :actual actual}))))
|
||||
|
||||
(define idt-ev erlang-eval-ast)
|
||||
(define idtnm (fn (v) (get v :name)))
|
||||
|
||||
(identity-load-token!)
|
||||
|
||||
;; ── issue + introspect (happy path) ──────────────────────────────
|
||||
|
||||
(id-token-test
|
||||
"fresh token introspects active"
|
||||
(idtnm
|
||||
(idt-ev
|
||||
"Reg = identity_tokens:start(),\n {ok, Tok} = identity_tokens:issue(Reg, alice, web, read),\n case identity_tokens:introspect(Reg, Tok) of\n {active, _, _, _} -> active;\n {inactive} -> inactive\n end"))
|
||||
"active")
|
||||
|
||||
(id-token-test
|
||||
"introspect returns the granted subject"
|
||||
(idtnm
|
||||
(idt-ev
|
||||
"Reg = identity_tokens:start(),\n {ok, Tok} = identity_tokens:issue(Reg, alice, web, read),\n case identity_tokens:introspect(Reg, Tok) of\n {active, Subject, _, _} -> Subject\n end"))
|
||||
"alice")
|
||||
|
||||
(id-token-test
|
||||
"introspect returns the granted scope"
|
||||
(idtnm
|
||||
(idt-ev
|
||||
"Reg = identity_tokens:start(),\n {ok, Tok} = identity_tokens:issue(Reg, alice, web, write),\n case identity_tokens:introspect(Reg, Tok) of\n {active, _, _, Scope} -> Scope\n end"))
|
||||
"write")
|
||||
|
||||
;; ── opacity: distinct tokens, no cross-talk ──────────────────────
|
||||
|
||||
(id-token-test
|
||||
"two issues yield independent grants"
|
||||
(idtnm
|
||||
(idt-ev
|
||||
"Reg = identity_tokens:start(),\n {ok, A} = identity_tokens:issue(Reg, alice, web, read),\n {ok, B} = identity_tokens:issue(Reg, bob, cli, write),\n identity_tokens:revoke(Reg, A),\n case identity_tokens:introspect(Reg, B) of\n {active, Subject, _, _} -> Subject;\n {inactive} -> inactive\n end"))
|
||||
"bob")
|
||||
|
||||
;; ── revocation is real (RFC 7009) ────────────────────────────────
|
||||
|
||||
(id-token-test
|
||||
"revoked token introspects inactive immediately"
|
||||
(idtnm
|
||||
(idt-ev
|
||||
"Reg = identity_tokens:start(),\n {ok, Tok} = identity_tokens:issue(Reg, alice, web, read),\n active = case identity_tokens:introspect(Reg, Tok) of\n {active, _, _, _} -> active end,\n identity_tokens:revoke(Reg, Tok),\n case identity_tokens:introspect(Reg, Tok) of\n {active, _, _, _} -> still_valid;\n {inactive} -> inactive\n end"))
|
||||
"inactive")
|
||||
|
||||
(id-token-test
|
||||
"revoke is idempotent"
|
||||
(idtnm
|
||||
(idt-ev
|
||||
"Reg = identity_tokens:start(),\n {ok, Tok} = identity_tokens:issue(Reg, alice, web, read),\n identity_tokens:revoke(Reg, Tok),\n identity_tokens:revoke(Reg, Tok)"))
|
||||
"ok")
|
||||
|
||||
;; ── unknown tokens are inactive, never an error/crash ────────────
|
||||
|
||||
(id-token-test
|
||||
"introspecting an unknown token is inactive"
|
||||
(idtnm
|
||||
(idt-ev
|
||||
"Reg = identity_tokens:start(),\n Bogus = make_ref(),\n case identity_tokens:introspect(Reg, Bogus) of\n {active, _, _, _} -> active;\n {inactive} -> inactive\n end"))
|
||||
"inactive")
|
||||
|
||||
(id-token-test
|
||||
"revoking an unknown token is ok, not a crash"
|
||||
(idtnm
|
||||
(idt-ev
|
||||
"Reg = identity_tokens:start(),\n Bogus = make_ref(),\n identity_tokens:revoke(Reg, Bogus)"))
|
||||
"ok")
|
||||
|
||||
;; ── one revocation does not affect a sibling token ───────────────
|
||||
|
||||
(id-token-test
|
||||
"revoking one token leaves the other active"
|
||||
(idtnm
|
||||
(idt-ev
|
||||
"Reg = identity_tokens:start(),\n {ok, A} = identity_tokens:issue(Reg, alice, web, read),\n {ok, B} = identity_tokens:issue(Reg, alice, cli, read),\n identity_tokens:revoke(Reg, A),\n case identity_tokens:introspect(Reg, B) of\n {active, _, _, _} -> active;\n {inactive} -> inactive\n end"))
|
||||
"active")
|
||||
|
||||
;; ── issue_grant: access + refresh pair (RFC 6749 §4.1.4 / §5.1) ───
|
||||
|
||||
(id-token-test
|
||||
"issue_grant access token introspects active"
|
||||
(idtnm
|
||||
(idt-ev
|
||||
"Reg = identity_tokens:start(),\n {ok, A, _R} = identity_tokens:issue_grant(Reg, alice, web, read),\n case identity_tokens:introspect(Reg, A) of\n {active, _, _, _} -> active;\n {inactive} -> inactive\n end"))
|
||||
"active")
|
||||
|
||||
;; ── refresh rotation (RFC 6749 §6) ───────────────────────────────
|
||||
|
||||
(id-token-test
|
||||
"refresh mints a working new access token"
|
||||
(idtnm
|
||||
(idt-ev
|
||||
"Reg = identity_tokens:start(),\n {ok, _A, R} = identity_tokens:issue_grant(Reg, alice, web, read),\n {ok, A2, _R2} = identity_tokens:refresh(Reg, R),\n case identity_tokens:introspect(Reg, A2) of\n {active, _, _, _} -> active;\n {inactive} -> inactive\n end"))
|
||||
"active")
|
||||
|
||||
(id-token-test
|
||||
"rotated token keeps the grant's subject"
|
||||
(idtnm
|
||||
(idt-ev
|
||||
"Reg = identity_tokens:start(),\n {ok, _A, R} = identity_tokens:issue_grant(Reg, alice, web, read),\n {ok, A2, _R2} = identity_tokens:refresh(Reg, R),\n case identity_tokens:introspect(Reg, A2) of\n {active, Subject, _, _} -> Subject\n end"))
|
||||
"alice")
|
||||
|
||||
(id-token-test
|
||||
"refresh chains across rotations"
|
||||
(idtnm
|
||||
(idt-ev
|
||||
"Reg = identity_tokens:start(),\n {ok, _A, R} = identity_tokens:issue_grant(Reg, alice, web, read),\n {ok, _A2, R2} = identity_tokens:refresh(Reg, R),\n {ok, A3, _R3} = identity_tokens:refresh(Reg, R2),\n case identity_tokens:introspect(Reg, A3) of\n {active, _, _, _} -> active;\n {inactive} -> inactive\n end"))
|
||||
"active")
|
||||
|
||||
(id-token-test
|
||||
"refreshing an unknown token is invalid_grant"
|
||||
(idtnm
|
||||
(idt-ev
|
||||
"Reg = identity_tokens:start(),\n Bogus = make_ref(),\n case identity_tokens:refresh(Reg, Bogus) of\n {ok, _, _} -> rotated;\n {error, Why} -> Why\n end"))
|
||||
"invalid_grant")
|
||||
|
||||
;; ── refresh-token reuse = theft → revoke the family (RFC 6819) ────
|
||||
|
||||
(id-token-test
|
||||
"reusing a superseded refresh token is invalid_grant"
|
||||
(idtnm
|
||||
(idt-ev
|
||||
"Reg = identity_tokens:start(),\n {ok, _A, R} = identity_tokens:issue_grant(Reg, alice, web, read),\n {ok, _A2, _R2} = identity_tokens:refresh(Reg, R),\n case identity_tokens:refresh(Reg, R) of\n {ok, _, _} -> rotated;\n {error, Why} -> Why\n end"))
|
||||
"invalid_grant")
|
||||
|
||||
(id-token-test
|
||||
"refresh reuse revokes the live descendant too"
|
||||
(idtnm
|
||||
(idt-ev
|
||||
"Reg = identity_tokens:start(),\n {ok, _A, R} = identity_tokens:issue_grant(Reg, alice, web, read),\n {ok, A2, _R2} = identity_tokens:refresh(Reg, R),\n identity_tokens:refresh(Reg, R),\n case identity_tokens:introspect(Reg, A2) of\n {active, _, _, _} -> still_valid;\n {inactive} -> inactive\n end"))
|
||||
"inactive")
|
||||
|
||||
;; ── cascading revocation: revoke any token, the grant dies ───────
|
||||
|
||||
(id-token-test
|
||||
"revoking the access token blocks refresh"
|
||||
(idtnm
|
||||
(idt-ev
|
||||
"Reg = identity_tokens:start(),\n {ok, A, R} = identity_tokens:issue_grant(Reg, alice, web, read),\n identity_tokens:revoke(Reg, A),\n case identity_tokens:refresh(Reg, R) of\n {ok, _, _} -> refreshed;\n {error, Why} -> Why\n end"))
|
||||
"invalid_grant")
|
||||
|
||||
(id-token-test
|
||||
"revoking the refresh token deactivates the access token"
|
||||
(idtnm
|
||||
(idt-ev
|
||||
"Reg = identity_tokens:start(),\n {ok, A, R} = identity_tokens:issue_grant(Reg, alice, web, read),\n identity_tokens:revoke(Reg, R),\n case identity_tokens:introspect(Reg, A) of\n {active, _, _, _} -> active;\n {inactive} -> inactive\n end"))
|
||||
"inactive")
|
||||
|
||||
;; ── scope as a set + narrowing on refresh (RFC 6749 §6 / §3.3) ───
|
||||
|
||||
(id-token-test
|
||||
"a list scope round-trips through introspect"
|
||||
(idtnm
|
||||
(idt-ev
|
||||
"Reg = identity_tokens:start(),\n {ok, A, _R} = identity_tokens:issue_grant(Reg, alice, web, [read, write]),\n case identity_tokens:introspect(Reg, A) of\n {active, _, _, [read, write]} -> matched;\n {active, _, _, _} -> other;\n {inactive} -> inactive\n end"))
|
||||
"matched")
|
||||
|
||||
(id-token-test
|
||||
"refresh can narrow the scope to a subset"
|
||||
(idtnm
|
||||
(idt-ev
|
||||
"Reg = identity_tokens:start(),\n {ok, _A, R} = identity_tokens:issue_grant(Reg, alice, web, [read, write]),\n {ok, A2, _R2} = identity_tokens:refresh(Reg, R, [read]),\n case identity_tokens:introspect(Reg, A2) of\n {active, _, _, [read]} -> narrowed;\n {active, _, _, _} -> other;\n {inactive} -> inactive\n end"))
|
||||
"narrowed")
|
||||
|
||||
(id-token-test
|
||||
"refresh cannot widen scope beyond the grant"
|
||||
(idtnm
|
||||
(idt-ev
|
||||
"Reg = identity_tokens:start(),\n {ok, _A, R} = identity_tokens:issue_grant(Reg, alice, web, [read]),\n case identity_tokens:refresh(Reg, R, [read, write]) of\n {ok, _, _} -> widened;\n {error, Why} -> Why\n end"))
|
||||
"invalid_scope")
|
||||
|
||||
(id-token-test
|
||||
"an invalid_scope refresh does not consume the refresh token"
|
||||
(idtnm
|
||||
(idt-ev
|
||||
"Reg = identity_tokens:start(),\n {ok, _A, R} = identity_tokens:issue_grant(Reg, alice, web, [read, write]),\n identity_tokens:refresh(Reg, R, [admin]),\n case identity_tokens:refresh(Reg, R, [read]) of\n {ok, _, _} -> still_usable;\n {error, Why} -> Why\n end"))
|
||||
"still_usable")
|
||||
|
||||
(id-token-test
|
||||
"plain refresh keeps the full grant scope"
|
||||
(idtnm
|
||||
(idt-ev
|
||||
"Reg = identity_tokens:start(),\n {ok, _A, R} = identity_tokens:issue_grant(Reg, alice, web, [read, write]),\n {ok, A2, _R2} = identity_tokens:refresh(Reg, R),\n case identity_tokens:introspect(Reg, A2) of\n {active, _, _, [read, write]} -> full;\n {active, _, _, _} -> other;\n {inactive} -> inactive\n end"))
|
||||
"full")
|
||||
|
||||
(id-token-test
|
||||
"a narrowed token still cascades on revoke"
|
||||
(idtnm
|
||||
(idt-ev
|
||||
"Reg = identity_tokens:start(),\n {ok, _A, R} = identity_tokens:issue_grant(Reg, alice, web, [read, write]),\n {ok, A2, _R2} = identity_tokens:refresh(Reg, R, [read]),\n identity_tokens:revoke(Reg, A2),\n case identity_tokens:introspect(Reg, A2) of\n {active, _, _, _} -> still_valid;\n {inactive} -> inactive\n end"))
|
||||
"inactive")
|
||||
|
||||
(define
|
||||
id-token-test-summary
|
||||
(str "token " id-token-test-pass "/" id-token-test-count))
|
||||
40
lib/identity/token.sx
Normal file
40
lib/identity/token.sx
Normal file
File diff suppressed because one or more lines are too long
@@ -21,7 +21,7 @@ reconciliation — all auditable via the event log.
|
||||
|
||||
## Status (rolling)
|
||||
|
||||
`bash lib/commerce/conformance.sh` → **297/297** (18 suites; + integration) — **roadmap + Phase 5 backlog + e2e composition proof complete**
|
||||
`bash lib/commerce/conformance.sh` → **0/0** (not yet started)
|
||||
|
||||
## Ground rules
|
||||
|
||||
@@ -55,223 +55,28 @@ lib/commerce/api.sx ── (commerce/add) (commerce/total) (commerce/checkout)
|
||||
```
|
||||
|
||||
## Phase 1 — Catalog + cart + deterministic totals
|
||||
- [x] `catalog.sx` — product/variant/stock as facts
|
||||
- [x] `cart.sx` — line items, add/remove/qty
|
||||
- [x] `price.sx` — base pricing relation, subtotal; tax
|
||||
- [x] `api.sx` + tests + scoreboard + conformance.sh
|
||||
- [ ] `catalog.sx` — product/variant/stock as facts
|
||||
- [ ] `cart.sx` — line items, add/remove/qty
|
||||
- [ ] `price.sx` — base pricing relation, subtotal; tax
|
||||
- [ ] `api.sx` + tests + scoreboard + conformance.sh
|
||||
|
||||
## Phase 2 — Promotions (relational)
|
||||
- [x] promo rules: percentage, fixed, bundle, member rate
|
||||
- [x] explicit stacking precedence; "best price" backward query
|
||||
- [x] tests: stacking order, mutually-exclusive promos, member vs guest
|
||||
- [ ] promo rules: percentage, fixed, bundle, member rate
|
||||
- [ ] explicit stacking precedence; "best price" backward query
|
||||
- [ ] tests: stacking order, mutually-exclusive promos, member vs guest
|
||||
|
||||
## Phase 3 — Order lifecycle (flow + store)
|
||||
- [x] order flow: reserve stock → await payment → fulfil
|
||||
- [x] payment webhook resumes the suspended flow
|
||||
- [x] order ledger as a `persist` stream; idempotent reconciliation
|
||||
- [ ] order flow: reserve stock → await payment → fulfil
|
||||
- [ ] payment webhook resumes the suspended flow
|
||||
- [ ] order ledger as a `persist` stream; idempotent reconciliation
|
||||
|
||||
## Phase 4 — Reconciliation + federation
|
||||
- [x] mismatch detection (paid≠ordered) as queries over the ledger
|
||||
- [x] cross-instance catalog (federated marketplace) — out-of-scope stub
|
||||
- [x] tests: webhook replay, partial refund, double-charge guard
|
||||
|
||||
## Phase 5 — Extensions (backlog; base roadmap complete) — **ALL DONE (278/278)**
|
||||
Thesis-aligned deepenings of the relational/composition showcase. Pick the one
|
||||
that unlocks the most tests per effort each iteration.
|
||||
- [x] line-level discount attribution — "which line item triggered this discount?"
|
||||
as a backward miniKanren query (`attribution.sx`: `promo-toucheso` relation,
|
||||
`lines-for-code`/`codes-for-line` both directions, `order-level-codes` for fixed).
|
||||
- [x] time-windowed promotions — `window.sx`: windowed promo `(promo from until)`,
|
||||
`active-ruleset`/`active-codes`/`windowed-quote` gate by datetime; feeds the
|
||||
existing promo/stack/quote pipeline unchanged. Determinism preserved.
|
||||
- [x] discount-aware tax policy — `nettax.sx`: `cart-quote-net` taxes the net
|
||||
(post-discount) base; `allocate-discount` spreads the basket discount across
|
||||
lines by extended share with largest-remainder so per-line shares sum exactly.
|
||||
- [x] refund as a flow — `refund.sx`: refund lifecycle (request → approve →
|
||||
settle) as a second flow-on-sx flow with two suspension points; idempotent
|
||||
settle, reject path, ledger-recorded; reuses order.sx flow helpers.
|
||||
- [x] stock-constrained reservation — `stock.sx`: `can-reserve?`/`reserve-check`
|
||||
precondition (host gates order-begin! on it, keeping the flow pure);
|
||||
`reservation-shortfalls` detail; `effective-available` nets out concurrent
|
||||
reservations; `sufficient-stocko` relational availability query.
|
||||
- [x] provider-neutral payment-request envelope — `payment.sx`: `payment-request`
|
||||
materialises `{:order :amount :currency :return-url}` at the IO edge (amount from
|
||||
the ledger, currency/return-url host-supplied); `pending-payments` enumerates
|
||||
suspended orders with their envelopes (host poller seam). Engine stays vendor-
|
||||
agnostic; `order-settle!(ref, amount)` is the resume seam.
|
||||
- [ ] mismatch detection (paid≠ordered) as queries over the ledger
|
||||
- [ ] cross-instance catalog (federated marketplace) — out-of-scope stub
|
||||
- [ ] tests: webhook replay, partial refund, double-charge guard
|
||||
|
||||
## Progress log
|
||||
- 2026-06-07 — `tests/integration.sx` (hardening): end-to-end composition proof —
|
||||
one narrative across every module (catalog → stock check → quote[promo+stack+tax]
|
||||
→ attribution → order flow → payment envelope → settle → recon → refund flow →
|
||||
ledger mismatch) asserting the seams tie together with consistent numbers
|
||||
(subtotal 2400, discount 210, tax 320, total 2510; settle→:ok; refund 510→
|
||||
:underpaid; mismatch flagged). Proves the three-substrate composition. One env
|
||||
with both order+refund flows. integration suite 19/19; total 297/297 (18 suites).
|
||||
- 2026-06-07 — `refund.sx` (**Phase 5 backlog complete**): refund lifecycle as a
|
||||
second flow-on-sx flow `(lambda (oid) (begin (request 'approve oid) (request
|
||||
'settle oid)))` — two suspension points (approval = human/policy decision,
|
||||
settle = provider). `refund-begin!` records :refund-requested and suspends at
|
||||
approval; `refund-approve!` advances to settle; `refund-settle!` records
|
||||
:refunded (idempotent) and completes; `refund-reject!` records :refund-rejected
|
||||
and cancels the flow. Only :refunded moves the books, so requested/rejected
|
||||
refunds leave recon unchanged. Reuses order.sx flow helpers. refund suite
|
||||
20/20; total 278/278 (17 suites). NB: conformance now has two env-building
|
||||
suites (order, refund) — each builds the ~150s flow env in its own process.
|
||||
- 2026-06-07 — `stock.sx` (Phase 5 ext): stock-constrained reservation. Design
|
||||
choice: reservation is a precondition the host checks BEFORE order-begin!
|
||||
(validate → begin), keeping the order flow pure orchestration. `available-stock`
|
||||
reads the catalog stock facts; `can-reserve?`/`reserve-check`/
|
||||
`reservation-shortfalls` gate a cart; `effective-available`/`line-reservable-with?`
|
||||
net out concurrent reservations (no over-reserve); `sufficient-stocko` is the
|
||||
multidirectional availability query. Only refund-as-flow remains in the
|
||||
backlog. stock suite 19/19; total 258/258 (16 suites).
|
||||
- 2026-06-07 — `nettax.sx` (Phase 5 ext): discount-aware tax — the alternative to
|
||||
quote.sx's gross-tax default. `cart-quote-net` taxes the NET (post-discount)
|
||||
base. `allocate-discount` spreads the basket-level discount across lines in
|
||||
proportion to extended price with a deterministic largest-remainder pass so
|
||||
per-line shares sum EXACTLY to the discount; each line is then taxed on its net
|
||||
at its class rate. Both policies reproducible from inputs; pick per jurisdiction.
|
||||
nettax suite 11/11; total 239/239 (15 suites).
|
||||
- 2026-06-07 — `window.sx` (Phase 5 ext): time-windowed promotions. A validity
|
||||
window is kept SEPARATE from the promo tuple — windowed promo `(promo from
|
||||
until)` (inclusive int timestamps, nil = open bound). `active-ruleset` filters
|
||||
to the plain promos live at `at` and feeds the existing promo/stack/quote
|
||||
pipeline unchanged (promo.sx untouched); `active-promoo`/`active-codes` is the
|
||||
backward "which codes are live at T?" query; `windowed-quote` is the
|
||||
datetime-aware quote (deterministic in `at`). window suite 19/19; total 228/228.
|
||||
- 2026-06-07 — `payment.sx` (Phase 5 ext, the item the user asked about):
|
||||
provider-neutral payment-request envelope, materialised at the IO edge from the
|
||||
ledger amount + host-supplied currency/return-url — keeps lib/commerce vendor-
|
||||
agnostic (SumUp/Stripe adapters live in the orders service). `payment-request`
|
||||
builds the `{:order :amount :currency :return-url}` envelope; `pending-payments`
|
||||
is the host-poller seam listing suspended orders + their envelopes. Gotcha: a
|
||||
Scheme **string** carried as a flow payload round-trips back to SX wrapped as
|
||||
`{:scm-string "..."}` (numbers come back clean) — unwrap via `scm->string`
|
||||
before using it as the oid. payment suite 7/7 + 1 order-suite integration test;
|
||||
total 209/209 (13 suites).
|
||||
- 2026-06-07 — `attribution.sx` (Phase 5 ext): line-level discount attribution —
|
||||
the briefing's marquee "which line item triggered this discount?" query.
|
||||
`promo-lines` is the pure per-promo scope (percent/member → class lines, bundle
|
||||
→ sku lines, fixed → order-level/none); `promo-toucheso` relates (code, line)
|
||||
for applying promos, run forward (`lines-for-code`) and backward
|
||||
(`codes-for-line`). `order-level-codes` lists applying fixed promos; predicate
|
||||
`line-touched-by?`. Additive — promo.sx amounts unchanged. attribution suite
|
||||
16/16; total 201/201 (12 suites).
|
||||
- 2026-06-07 — `recon.sx` + `federation.sx` (**Phase 4 complete — roadmap done**).
|
||||
`recon.sx`: reconciliation as relational queries over the ledger. Per-order
|
||||
summary tuples (id total paid refunded net status); `recon-statuso`/`neto`/
|
||||
`mismatcho` are miniKanren relations, so "which orders are overpaid?",
|
||||
"settled to net N?" are backward `run*` queries. Helpers: overpaid/underpaid/
|
||||
settled/unpaid-orders, mismatched-orders, orders-with-net, ledger-discrepancy.
|
||||
Tests cover double-charge guard (two refs → :overpaid), partial refund (net <
|
||||
total → :underpaid), webhook replay (same ref twice → single :paid, :ok). 20/20.
|
||||
`federation.sx` (out-of-scope stub): a federated catalog is the UNION of each
|
||||
instance's product facts, so the SAME relations query cross-instance —
|
||||
`fed-producto`/`fed-priceo`, `instances-with-sku`, `sku-offers`, deterministic
|
||||
`cheapest-offer`. In-process mock, no real network/ActivityPub. 12/12.
|
||||
Total 185/185 across 11 suites.
|
||||
- 2026-06-07 — `order.sx` (**Phase 3 complete**, checkboxes 1-2): order lifecycle
|
||||
as a flow-on-sx flow `(lambda (oid) (begin (request 'reserve oid) (request
|
||||
'payment oid) (request 'fulfil oid)))` — pure orchestration carrying only the
|
||||
order-id; the SX driver services each request by appending to the persist
|
||||
ledger. `order-begin!` creates+reserves and leaves the flow SUSPENDED at
|
||||
payment; `order-settle!` (the webhook) resumes → fulfils, and is idempotent
|
||||
(only acts while waiting on payment, so a replayed webhook → :already-settled).
|
||||
`order-flow-restart!` simulates a process restart entirely Scheme-side
|
||||
(export→reset→reload→import) and the suspended order resumes correctly
|
||||
afterwards with the persist ledger intact. Composes all three substrates
|
||||
(minikanren pricing → flow lifecycle → persist ledger). order suite 21/21;
|
||||
total 153/153. Gotchas: flow ids start at 1; never return flow-make-env across
|
||||
the eval boundary (serializer hangs on the cyclic env); guest Scheme rejects
|
||||
`:ok` keyword as a value — use `#t`. Flow env build ~150s CPU; order suite runs
|
||||
single-process with timeout 560.
|
||||
- 2026-06-07 — `ledger.sx` (Phase 3 piece, checkbox 3): order ledger as a
|
||||
persist event stream "order/<id>". Status/total/paid/recon are projections
|
||||
(folds) over events — ledger is the single source of truth. `order-pay`/
|
||||
`order-refund` are idempotent via `persist/append-once` keyed on the payment
|
||||
ref, so a replayed SumUp webhook records once (no double-charge). `order-recon-of`
|
||||
classifies :unpaid/:ok/:underpaid/:overpaid on net (paid−refunded) vs total;
|
||||
`ledger-mismatches` finds genuine paid≠ordered across all streams. Verified
|
||||
minikanren+scheme/flow+persist all coexist in one sx_server process. ledger
|
||||
suite 20/20; total 132/132. Next: order flow (reserve→pay→fulfil) as a Scheme
|
||||
flow-on-sx flow with webhook resume (checkboxes 1-2) — needs SX↔Scheme quote
|
||||
marshalling.
|
||||
- 2026-06-07 — `quote.sx` (pricing capstone, bridges Phase 2→3): `cart-quote`
|
||||
composes price+promo+stacking into the deterministic priced quote
|
||||
`{:subtotal :discount :tax :total :codes}` with `total = subtotal - discount
|
||||
+ tax`. Explicit tax policy: tax on GROSS per-line amounts (discount reduces
|
||||
payable, not tax base) — documented for the determinism contract. This quote
|
||||
is the value the Phase-3 order flow will carry. quote suite 13/13; total
|
||||
112/112.
|
||||
- 2026-06-07 — `stack.sx` (**Phase 2 complete**): stacking precedence as a
|
||||
separate selection layer (precedence NOT in the rules, per the miniKanren
|
||||
design rule). Exclusivity = unordered code pairs; `valid-stackings` enumerates
|
||||
every legal subset of applicable promos (powerset ∖ excluded combos);
|
||||
`best-stacking` is the deterministic max-total-discount selection (stable on
|
||||
ties). `stacking-by-totalo` is the best-price backward query ("which legal
|
||||
stacking yields total D?"). Member vs guest falls out of applicable-promos.
|
||||
stack suite 16/16; total 99/99.
|
||||
- 2026-06-07 — `promo.sx` (Phase 2 piece 1): four promo types as tagged tuples
|
||||
`(:percent code class bps)`/`(:fixed code threshold amount)`/`(:bundle code sku
|
||||
n)`/`(:member code class bps)`. Per-promo discount is pure integer arithmetic;
|
||||
`promo-discounto`/`promo-applieso` enumerate (code, amount) relationally —
|
||||
forward ("which apply?") and backward ("which code yields 2000?" → run* over
|
||||
applieso). `applicable-promos`/`promo-amount-for` deterministic helpers. promo
|
||||
amounts via `project` to ground the membero-bound promo. promo suite 17/17;
|
||||
total 83/83. Next: stacking precedence + best-price (stack.sx).
|
||||
- 2026-06-06 — `api.sx` (**Phase 1 complete**): session facade
|
||||
`{:ctx :cart}` with `commerce-add`/`-remove`/`-set-qty`/`-total`/`-count`/
|
||||
`-lines`, `commerce-can-add?` catalog validation, `commerce-explain` per-line
|
||||
audit breakdown ({:sku :variant :qty :unit :extended :tax}), and a
|
||||
`commerce-checkout` Phase-3 stub. api suite 12/12; total 66/66.
|
||||
- 2026-06-06 — `price.sx`: deterministic `cart-subtotal` (Σ unit×qty, variant
|
||||
delta defaults 0) + jurisdiction-relational tax. `taxo` facts indexed by
|
||||
(jurisdiction, product-class, customer-class)→bps, queried multidirectionally;
|
||||
`apply-bps` rounds half-up with integer arithmetic only. `cart-total` returns
|
||||
`{:subtotal :discounts :tax :total}` (discounts 0 until Phase 2), reproducible
|
||||
from (context, cart). `=` does structural dict equality (order-independent), so
|
||||
total dicts compare directly. price suite 20/20; total 54/54.
|
||||
- 2026-06-06 — `cart.sx`: cart as an ordered list of (sku variant qty) lines.
|
||||
Pure ops `cart-add` (merges same line / appends), `cart-set-qty` (0 removes),
|
||||
`cart-remove`, plus `cart-qty`/`cart-count`/`cart-skus`/`cart-empty?`.
|
||||
`cart-lineo` is the relational view (membero over the cart) — forward and
|
||||
backward. cart suite 18/18; total 34/34.
|
||||
- 2026-06-06 — `catalog.sx`: catalog snapshot (products/variants/stock as fact
|
||||
tuples) + multidirectional accessor relations (`producto`/`varianto`/`stocko`,
|
||||
derived `priceo`/`classo`/`unit-priceo`) + deterministic `catalog-price`/
|
||||
`-class`/`-has?` helpers. `conformance.sh` harness + scoreboard. catalog suite
|
||||
16/16. Gotcha: minikanren `run-n` macro binds `s` internally — query vars must
|
||||
avoid `s`; tests compare reified results with `=` (not `equal?`, which fails on
|
||||
reified lists). Money = integer minor units throughout.
|
||||
|
||||
## Phase 3 flow-integration notes (for the next iteration)
|
||||
|
||||
Order flow = checkboxes 1-2 (reserve→pay→fulfil as a flow-on-sx flow + webhook
|
||||
resume). Design is settled; the remaining work is mechanical but slow to iterate.
|
||||
|
||||
- **flow is the Scheme-on-SX guest layer**, not the SX/minikanren host. Load
|
||||
order: `lib/guest/{lex,reflective/env,reflective/quoting}` + `lib/scheme/{parser,
|
||||
eval,runtime}` + `lib/flow/{spec,store,remote,host,api}`. Confirmed it coexists
|
||||
with the minikanren + persist stacks in one sx_server process.
|
||||
- **Driver API (SX side):** `(flow-make-env)` builds the env once; `(flow-run-in
|
||||
env "<scheme-src>")` evaluates a Scheme program string. Flows/driving are all
|
||||
Scheme: `(flow/start flow input)`, `(flow/resume id val)`, `(flow/pending)`,
|
||||
`(flow/status id)`, `(flow/result id)`. Host ABI (host.sx): `(request kind
|
||||
payload)` suspends with a typed envelope; `(flow-host-requests)` lists pending.
|
||||
- **Settled design:** the Scheme flow carries ONLY the order-id (a string) and is
|
||||
pure orchestration: `(defflow ordf (lambda (oid) (begin (request 'reserve oid)
|
||||
(request 'payment oid) (request 'fulfil oid))))`. All IO/ledger work stays in
|
||||
SX — the SX driver services each request by appending to the persist ledger
|
||||
(ledger.sx) and resuming with a marker. Payment stays suspended until the
|
||||
webhook calls flow/resume. Marshalling is trivial (just strings).
|
||||
- **GOTCHA (cost me a turn):** `flow-make-env` returns a large/likely-cyclic env
|
||||
object; returning it from `(eval "...")` makes the harness serializer hang (got
|
||||
exit 0 with NO epoch-2 output). NEVER return the env — wrap as `(begin (define
|
||||
env (flow-make-env)) :ok)`. Structure the flow suite like `lib/flow/conformance.sh`:
|
||||
load once, build env once, run all assertions in ONE process returning small
|
||||
count values. Budget a long timeout (flow's own suite uses 540s); env build is
|
||||
~150s CPU and balloons under sibling-agent CPU contention.
|
||||
(loop fills this in)
|
||||
|
||||
## Blockers
|
||||
(none)
|
||||
(loop fills this in)
|
||||
|
||||
@@ -19,7 +19,7 @@ through the event log, all authorization questions delegated to `acl-on-sx`.
|
||||
|
||||
## Status (rolling)
|
||||
|
||||
`bash lib/identity/conformance.sh` → **0/0** (not yet started)
|
||||
`bash lib/identity/conformance.sh` → **233/233** (4 phases + 15 ext) — slow (~10min, run in background; internal timeout 1200)
|
||||
|
||||
## Ground rules
|
||||
|
||||
@@ -57,28 +57,237 @@ lib/identity/api.sx ── (identity/login) (identity/grant?) (identity/revoke)
|
||||
```
|
||||
|
||||
## Phase 1 — Sessions + tokens
|
||||
- [ ] `session.sx` — session process, create/lookup/expire
|
||||
- [ ] `token.sx` — issue/introspect/revoke (opaque, grant-backed)
|
||||
- [ ] `registry.sx` — route by subject/client
|
||||
- [ ] `api.sx` + tests + scoreboard + conformance.sh
|
||||
- [x] `session.sx` — session process, create/lookup/expire
|
||||
- [x] `token.sx` — issue/introspect/revoke (opaque, grant-backed)
|
||||
- [x] `registry.sx` — route by subject/client
|
||||
- [x] `api.sx` + tests + scoreboard + conformance.sh
|
||||
|
||||
## Phase 2 — OAuth2 flows
|
||||
- [ ] authorization-code flow as a message protocol
|
||||
- [ ] refresh + rotation; revocation cascades to issued tokens
|
||||
- [ ] tests: full code exchange, refresh, revoke-then-use (must fail)
|
||||
- [x] authorization-code flow as a message protocol
|
||||
- [x] refresh + rotation; revocation cascades to issued tokens
|
||||
- [x] tests: full code exchange, refresh, revoke-then-use (must fail)
|
||||
|
||||
## Phase 3 — Silent SSO + membership
|
||||
- [ ] `prompt=none` cross-app login (one session, many clients)
|
||||
- [ ] membership state + per-app grant projection
|
||||
- [ ] grant verification delegated cache (mirror Redis-cache pattern)
|
||||
- [x] `prompt=none` cross-app login (one session, many clients)
|
||||
- [x] membership state + per-app grant projection
|
||||
- [x] grant verification delegated cache (mirror Redis-cache pattern)
|
||||
|
||||
## Phase 4 — Audit + federation
|
||||
- [ ] every issue/refresh/revoke is a `persist` event; `(identity/audit subject)`
|
||||
- [ ] federated identity (peer-asserted subject) — advisory, trust-gated stub
|
||||
- [ ] tests: audit completeness, cross-instance subject mapping
|
||||
- [x] every issue/refresh/revoke is a `persist` event; `(identity/audit subject)`
|
||||
- [x] federated identity (peer-asserted subject) — advisory, trust-gated stub
|
||||
- [x] tests: audit completeness, cross-instance subject mapping
|
||||
|
||||
## Extensions (base roadmap complete; deepen the engine)
|
||||
- [~] PKCE S256 method (RFC 7636 §4.2) — BLOCKED on erlang substrate (see Blockers)
|
||||
- [x] access-token TTL / `expires_in` — logical-clock expiry, introspect honours it
|
||||
- [x] scope as a set + scope narrowing on refresh (RFC 6749 §6)
|
||||
- [x] client registry: public vs confidential clients, client authentication (RFC 6749 §2)
|
||||
- [x] client-credentials grant (RFC 6749 §4.4) + device grant (RFC 8628)
|
||||
- [x] acl-on-sx delegation: identity-gates-before-acl boundary (401 vs 403), stub decider (live Datalog bridge is cross-substrate)
|
||||
- [~] OAuth `state`/OIDC `nonce` — low value in this server-centric model (client-side echo); skipped
|
||||
- [x] pushed authorization requests (PAR, RFC 9126): single-use request_uri → consent
|
||||
- [x] dynamic client registration (RFC 7591): server-generated client_id + secret
|
||||
- [x] "apps with access": `grants_for(Subject)` / `identity:grants` (per-subject active grants)
|
||||
- [x] "disconnect app": `revoke_app(Subject, Client)` — revoke all of a subject's grants for a client
|
||||
- [x] unify `api.sx` over membership + audit (one facade, audited login/logout)
|
||||
- [x] subject-wide session management: `sessions(Subject)` + `logout_all` (log out everywhere)
|
||||
- [x] token exchange (RFC 8693): downscope a token into a new independent token
|
||||
- [x] RFC 7662 full introspection metadata (`introspect_full`: sub/client_id/scope/exp/iat/token_type)
|
||||
|
||||
## Progress log
|
||||
(loop fills this in)
|
||||
- 2026-06-07 — "disconnect app" (ext): `identity_tokens:revoke_app(Subject,
|
||||
Client)` revokes every grant a subject holds for one client at once (audited
|
||||
one revoke per grant), exposed at the facade as `identity:revoke_app`. The
|
||||
action counterpart to the `grants` view — completes the account-security
|
||||
view+action pairs: sessions/logout_all, grants/revoke_app, history. Other
|
||||
subjects' same-client grants are untouched. +4 → account 11, 233/233.
|
||||
- 2026-06-07 — "apps with access" (ext): `identity_tokens:grants_for(Subject)`
|
||||
lists a subject's ACTIVE grants as `[{Client, Scope}]` (revoked excluded),
|
||||
exposed through the facade as `identity:grants(Subject)`. Completes the
|
||||
per-subject account-security trio: sessions (where), grants (which apps),
|
||||
history (what happened). New tests/account.sx (7). 222→229. NOTE: conformance
|
||||
is now slow (~10 min, 22 suites); run it in the background — internal
|
||||
sx_server timeout raised to 1200s. The suite is at its monolithic-runtime
|
||||
ceiling; further test growth should consider splitting the harness.
|
||||
- 2026-06-07 — dynamic client registration (ext, RFC 7591): `register_dynamic`
|
||||
generates a client_id + secret server-side (make_ref each) and registers the
|
||||
client, returning {ok, ClientId, Secret} — self-service onboarding distinct
|
||||
from the manual register_client. A dynamic confidential client can then use
|
||||
client_credentials; a dynamic public client stays unauthorized_client. New
|
||||
tests/dynreg.sx (5). 217→222.
|
||||
- 2026-06-07 — PAR (ext, RFC 9126): `push_authorization_request` lodges the
|
||||
authorization params under a single-use `request_uri`; `authorize_pushed`
|
||||
redeems it into the normal consent flow. Pushed requests reuse the pending
|
||||
store (`{pushed, Rec}` keyed by the request_uri ref — distinct from consent
|
||||
req_ids, no collision), so no new loop state. The pushed binding (client +
|
||||
redirect + PKCE) is enforced at exchange. New tests/par.sx (7). 210→217.
|
||||
- 2026-06-07 — full introspection (ext, RFC 7662 §2.2): `introspect_full`
|
||||
returns {active, Subject, Client, Scope, Exp, Iat, bearer} for live tokens,
|
||||
{inactive} otherwise — deepening the opaque-token/live-lookup model the
|
||||
whole design rests on. Access tokens now carry `Iat` (clock-at-issue);
|
||||
exp = iat + ttl. Simple `introspect` unchanged. New tests/introspect.sx (9).
|
||||
201→210. NOTE: conformance now needs an explicit long timeout (>120s, 19
|
||||
suites) — run with `timeout 580`.
|
||||
- 2026-06-07 — token exchange (ext, RFC 8693 §2.1): `oauth.sx` gains
|
||||
`token_exchange(SubjectToken, RequestedScope)` — a valid access token is
|
||||
downscoped into a NEW independent grant for the same subject (subset only,
|
||||
else invalid_scope; inactive subject token → invalid_grant). The new token's
|
||||
lifecycle is independent (revoking either leaves the other active);
|
||||
exchanges chain. Least-privilege handoff to downstream services. New
|
||||
tests/exchange.sx (8). 193→201.
|
||||
- 2026-06-07 — subject-wide session management (ext): `api.sx` gains
|
||||
`sessions(Subject)` (enumerate) and `logout_all(Subject)` ("log out
|
||||
everywhere") — revokes + deregisters every session a subject holds,
|
||||
auditing a logout per session, leaving other subjects untouched. Builds on
|
||||
registry.sessions_for. New tests/session_mgmt.sx (8). 185→193.
|
||||
- 2026-06-07 — `delegation.sx` (ext): the identity→acl boundary made concrete.
|
||||
`check` introspects the token first: inactive → `{error, unauthenticated}`
|
||||
(401, acl never consulted); active → constructs {Subject, Scope, Action,
|
||||
Resource} and hands off to acl, which returns permit/deny (`forbidden` =
|
||||
403). 401 strictly precedes 403 (a revoked token with no scope is still
|
||||
unauthenticated). acl-on-sx (Datalog) is a different SX guest language —
|
||||
wired at the integration layer — so the decider here is a labelled stub
|
||||
(permits when Action ∈ Scope); swap the pid, boundary unchanged. New
|
||||
tests/delegation.sx (8). 177→185. **Extensions backlog clear.**
|
||||
- 2026-06-07 — unified facade (ext): `api.sx` coordinator now owns an audit
|
||||
ledger + a membership registry alongside its token table (started with the
|
||||
ledger) and session registry. login/logout are audited; new ops
|
||||
`history`/`enroll`/`member_status`/`member_project` expose the audit +
|
||||
membership axes through the one `identity` door. identity proves who +
|
||||
reports membership; acl still decides permission. Existing api behaviour
|
||||
unchanged (10/10). New tests/facade.sx (9). 168→177.
|
||||
- 2026-06-07 — `device.sx` (ext, RFC 8628): device authorization grant for
|
||||
input-constrained devices. authorize → {device_code, user_code}; the human
|
||||
approve/deny out-of-band by user_code; the device polls by device_code
|
||||
through the §3.5 status machine (authorization_pending → access_denied /
|
||||
{ok,Token}). Device code is single-use once a token issues; guarded
|
||||
transitions (approve-after-deny rejected). Tokens grant-backed. Device-code
|
||||
expiry + slow_down deferred (no wall clock). New tests/device.sx (10). 158→168.
|
||||
- 2026-06-07 — client-credentials grant (ext, RFC 6749 §4.4): `oauth.sx` now
|
||||
owns a client registry (loop/6); `register_client` + `client_credentials`.
|
||||
A confidential client authenticates and gets a token acting on its own
|
||||
behalf (subject = the client), no refresh token (§4.4.3). A public client is
|
||||
`unauthorized_client`; any auth failure (unknown client OR wrong secret) is
|
||||
`invalid_client` — no client-existence oracle (§5.2). `identity-load-oauth!`
|
||||
now pulls its deps (token/session/registry/clients). New tests/grants.sx (9).
|
||||
149→158.
|
||||
- 2026-06-07 — `clients.sx` (ext): OAuth client registry (RFC 6749 §2). public
|
||||
vs confidential clients; confidential clients MUST present the right secret
|
||||
(wrong → invalid_client), public clients are identified but not
|
||||
authenticated; redirect_uris are allow-listed with exact-match
|
||||
`valid_redirect` (§3.1.2.2 + Security BCP). Standalone module (no oauth
|
||||
wiring yet — that's a follow-up). New tests/clients.sx (11). 138→149.
|
||||
- 2026-06-07 — access-token expiry (ext): logical clock in the token registry
|
||||
(`advance`/`now`; no wall clock in substrate). Grants carry a Ttl; each
|
||||
access token carries an Expires (Now-at-issue + Ttl, or infinity); introspect
|
||||
returns inactive once `Now` reaches it. Refresh mints a fresh short-lived
|
||||
access token (new Expires) — short access tokens, long refresh tokens. issue/4
|
||||
+ issue_grant/4 default to infinity, so all prior tests unchanged. New
|
||||
tests/expiry.sx (8). token loop/6. 130→138.
|
||||
- 2026-06-07 — scope narrowing (ext): each access token now carries its own
|
||||
EFFECTIVE scope (<= the grant's max). `refresh/3` requests a narrower scope;
|
||||
the request must be a subset of the grant scope (RFC 6749 §6) else
|
||||
`{error, invalid_scope}` and the refresh token is NOT consumed (client may
|
||||
retry, §5.2). `refresh/2` keeps full scope; scope stays opaque (atom or list)
|
||||
for issue, so all prior atom-scope tests pass unchanged. token 18→24, 130/130.
|
||||
Also filed Blocker: PKCE S256 needs SHA256+binary compare, both broken in the
|
||||
erlang substrate (binary `=:=` always true; crypto:hash ignores binary
|
||||
content) — deferred, plain method stays.
|
||||
- 2026-06-07 — `federation.sx`: trust-gated, advisory federated identity.
|
||||
A peer assertion is accepted only from an explicitly trusted peer
|
||||
(else `{error, untrusted}`) and is flagged `{peer_asserted, Peer}`, never
|
||||
promoted to local authority — acl decides what it may do. Cross-instance
|
||||
subject mapping namespaces remote subjects by peer (`{federated, Peer,
|
||||
Remote}`) so two peers' "alice" never collide, with optional explicit
|
||||
aliasing. Added an audit-completeness test (mixed transition stream → no
|
||||
event dropped). New tests/federation.sx (12). **Phase 4 complete — all four
|
||||
phases done.** +13 → 124/124.
|
||||
- 2026-06-07 — `audit.sx`: append-only grant audit ledger (an Erlang
|
||||
process). `token.sx` gains `start/1(Audit)` and emits issue/refresh/revoke
|
||||
events (incl. reuse-triggered revoke); `start/0` stays unaudited (no
|
||||
regression — token.sx has no compile-time dep on the audit module, just
|
||||
sends to a pid). Ledger queryable per subject — `audit`/`actions`/`count`/
|
||||
`all`, chronological. In-memory event stream (persist-backing is a future
|
||||
Erlang↔persist bridge, out of scope per loop allowance). New
|
||||
tests/audit.sx (10). +10 → 111/111.
|
||||
- 2026-06-07 — `cache.sx`: delegated grant-verification cache (Redis-cache
|
||||
pattern) wrapping the token registry. introspect memoised; generation
|
||||
invalidation keeps revocation real — any revoke/refresh bumps a generation
|
||||
counter so every cached positive instantly becomes a miss and re-validates
|
||||
against the live registry. A revoked token never reads valid from cache.
|
||||
stats() exposes hits/misses. New tests/cache.sx (9). **Phase 3 complete.**
|
||||
+9 → 101/101.
|
||||
- 2026-06-07 — `membership.sx`: coop membership as a guarded state machine
|
||||
(none→pending→active→lapsed⇄active, any→revoked terminal); invalid
|
||||
transitions are explicit `{error, CurrentStatus}`. `project(Subject, App)`
|
||||
renders the one canonical state into a per-app claim
|
||||
({member,Tier,App}/{pending,App}/{lapsed,App}/{denied,App}/{non_member,App})
|
||||
— identity reports what; acl decides whether. New tests/membership.sx (17).
|
||||
+17 → 92/92.
|
||||
- 2026-06-07 — silent SSO (`prompt=none`, OIDC §3.1.2.1): `oauth.sx` now owns
|
||||
a session registry; `establish` creates a subject session, `silent_authorize`
|
||||
asks "does this subject have a live session?" → mints a code (skipping
|
||||
consent) bound to client+redirect+PKCE, else `login_required`. Same machine,
|
||||
fast-path — one session, many clients; `end_session` closes the path.
|
||||
New `tests/sso.sx` (10). +10 → 75/75.
|
||||
- 2026-06-07 — `oauth.sx` refresh wiring + e2e: exchange now issues an
|
||||
access+refresh pair (RFC 6749 §4.1.4/§5.1) via token.sx issue_grant; added
|
||||
the refresh grant (§6) delegating to token rotation. End-to-end tests:
|
||||
code-exchange→refresh→introspect, refresh-reuse rejected, and
|
||||
revoke-then-refresh blocked by cascade. **Phase 2 complete.** +3 → oauth 17,
|
||||
65/65.
|
||||
- 2026-06-07 — `token.sx` grant-centric rewrite: refresh-token rotation
|
||||
(RFC 6749 §6) + cascading revocation. The grant {Subject,Client,Scope,
|
||||
Status} is the cascade unit; access + refresh tokens reference it.
|
||||
`issue_grant` → {ok, Access, Refresh}; `refresh` supersedes the old
|
||||
refresh + mints a new pair; reusing a superseded refresh token revokes
|
||||
the whole family (RFC 6819 §5.2.2.3), killing the live descendant.
|
||||
`revoke` of ANY token (access or refresh) cascades to the grant. All
|
||||
prior issue/introspect/revoke behaviour preserved. +9 → token 18, 62/62.
|
||||
- 2026-06-07 — `oauth.sx`: OAuth2 authorization-code flow as a message
|
||||
protocol (RFC 6749 §4.1) + PKCE (RFC 7636, plain). State machine on one
|
||||
authz-server process: authorize → {consent_required} → consent →
|
||||
{code} → exchange → {ok, Token}. Exchange enforces single-use codes
|
||||
(§10.5; removed on first attempt, replay → invalid_grant), client_id +
|
||||
redirect_uri binding (§4.1.3), and PKCE verifier match. Issued tokens are
|
||||
grant-backed so revocation stays real. +14 → 53/53.
|
||||
- 2026-06-06 — `api.sx`: service facade. `identity:start()` spawns one
|
||||
coordinator owning the token table + session registry; exposes
|
||||
login/verify/revoke/logout/session_status. Coordinator is the sessions'
|
||||
owner, so an expired session deregisters itself (timeout-driven, no
|
||||
sweep). `verify` answers IDENTITY only ({active, Subject, Client, Scope});
|
||||
permission is acl's job — explicit delegation boundary. **Phase 1 complete.**
|
||||
+10 → 39/39.
|
||||
- 2026-06-06 — `registry.sx`: directory process routing sessions by id and
|
||||
by (subject, client). Answers the SSO probe `lookup(Subject, Client)` and
|
||||
the fan-out `sessions_for(Subject)` (one subject, many clients). Routes
|
||||
only — holds no grant state. Integration-tested end-to-end: register a live
|
||||
session, route to it, confirm it answers active. +9 → 29/29.
|
||||
- 2026-06-06 — `token.sx`: opaque grant-backed tokens. Token = `make_ref`
|
||||
(carries no info); the token table is a process; `introspect` is a live
|
||||
lookup every time so revocation is real (RFC 7009) — a revoked token reads
|
||||
`{inactive}` on the next introspection, no validity window. Reply shapes
|
||||
follow RFC 7662 §2.2 (`{active,...}` / `{inactive}`, never says why). +9 → 20/20.
|
||||
- 2026-06-06 — `session.sx`: session-as-Erlang-process. create/lookup/touch/
|
||||
explicit-expire/revoke as messages; idle-timeout self-expiry via
|
||||
`receive ... after Ttl` notifying the owner then tombstoning. Tombstones
|
||||
answer lookups with `{error, expired|revoked}` — never a silent dead
|
||||
mailbox. Established the conformance harness (`conformance.sh`, scoreboard,
|
||||
`tests/session.sx`). 11/11.
|
||||
|
||||
## Blockers
|
||||
(loop fills this in)
|
||||
- 2026-06-07 — **PKCE S256 blocked: erlang binary bugs.** Two substrate bugs
|
||||
in `lib/erlang` make a correct/secure S256 impossible (S256 needs
|
||||
`BASE64URL(SHA256(verifier))` compared against the stored challenge):
|
||||
1. **Binary `=:=` always true.** `<<"v1">> =:= <<"v2">>` → `true`;
|
||||
`<<"abc">> =:= <<"abd">>` → `true`. So a hash comparison can't reject a
|
||||
wrong verifier.
|
||||
2. **`crypto:hash` ignores binary-literal content.**
|
||||
`crypto:hash(sha256, <<"v1">>)` and `crypto:hash(sha256, <<"v2">>)` return
|
||||
the *identical* 32-byte digest (`6e 34 0b 9c …`), which is also ≠ the
|
||||
correct SX-level `(crypto-sha256 "abc")` (`ba 78 16 bf …`). The binary
|
||||
payload isn't reaching the hash. (Atom input → badarg→nil, separate issue.)
|
||||
Minimal repro (epoch protocol, after loading lib/erlang/runtime.sx):
|
||||
`(erlang-eval-ast "case <<\"a\">> =:= <<\"b\">> of true -> bug; false -> ok end")`
|
||||
→ `bug`. Not in scope to fix (lib/erlang is a substrate). PKCE `plain`
|
||||
remains correct and in use; S256 deferred until the binary path is fixed.
|
||||
|
||||
Reference in New Issue
Block a user