Merge loops/commerce into architecture: commerce-on-sx revenue vertical
Pricing/promotions/reconciliation as miniKanren relations, order lifecycle as a flow-on-sx durable flow, order ledger as a persist event stream. Base roadmap (Phases 1-4) + Phase 5 extensions (line-level attribution, provider-neutral payment envelope, time-windowed promos, discount-aware tax, stock-constrained reservation, refund-as-flow) + end-to-end composition proof. 297/297 across 18 suites (bash lib/commerce/conformance.sh).
This commit is contained in:
56
lib/commerce/api.sx
Normal file
56
lib/commerce/api.sx
Normal file
@@ -0,0 +1,56 @@
|
||||
;; 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}))
|
||||
100
lib/commerce/attribution.sx
Normal file
100
lib/commerce/attribution.sx
Normal file
@@ -0,0 +1,100 @@
|
||||
;; 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))))))
|
||||
86
lib/commerce/cart.sx
Normal file
86
lib/commerce/cart.sx
Normal file
@@ -0,0 +1,86 @@
|
||||
;; 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)))
|
||||
83
lib/commerce/catalog.sx
Normal file
83
lib/commerce/catalog.sx
Normal file
@@ -0,0 +1,83 @@
|
||||
;; 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)))))
|
||||
153
lib/commerce/conformance.sh
Executable file
153
lib/commerce/conformance.sh
Executable file
@@ -0,0 +1,153 @@
|
||||
#!/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 ]
|
||||
86
lib/commerce/federation.sx
Normal file
86
lib/commerce/federation.sx
Normal file
@@ -0,0 +1,86 @@
|
||||
;; 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)))))
|
||||
176
lib/commerce/ledger.sx
Normal file
176
lib/commerce/ledger.sx
Normal file
@@ -0,0 +1,176 @@
|
||||
;; 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))))
|
||||
80
lib/commerce/nettax.sx
Normal file
80
lib/commerce/nettax.sx
Normal file
@@ -0,0 +1,80 @@
|
||||
;; 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})))))
|
||||
119
lib/commerce/order.sx
Normal file
119
lib/commerce/order.sx
Normal file
@@ -0,0 +1,119 @@
|
||||
;; 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)"))))
|
||||
41
lib/commerce/payment.sx
Normal file
41
lib/commerce/payment.sx
Normal file
@@ -0,0 +1,41 @@
|
||||
;; 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)))))
|
||||
110
lib/commerce/price.sx
Normal file
110
lib/commerce/price.sx
Normal file
@@ -0,0 +1,110 @@
|
||||
;; 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}))))
|
||||
153
lib/commerce/promo.sx
Normal file
153
lib/commerce/promo.sx
Normal file
@@ -0,0 +1,153 @@
|
||||
;; 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)))))
|
||||
36
lib/commerce/quote.sx
Normal file
36
lib/commerce/quote.sx
Normal file
@@ -0,0 +1,36 @@
|
||||
;; 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)))
|
||||
100
lib/commerce/recon.sx
Normal file
100
lib/commerce/recon.sx
Normal file
@@ -0,0 +1,100 @@
|
||||
;; 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))))
|
||||
97
lib/commerce/refund.sx
Normal file
97
lib/commerce/refund.sx
Normal file
@@ -0,0 +1,97 @@
|
||||
;; 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)))
|
||||
25
lib/commerce/scoreboard.json
Normal file
25
lib/commerce/scoreboard.json
Normal file
@@ -0,0 +1,25 @@
|
||||
{
|
||||
"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
|
||||
}
|
||||
25
lib/commerce/scoreboard.md
Normal file
25
lib/commerce/scoreboard.md
Normal file
@@ -0,0 +1,25 @@
|
||||
# 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** |
|
||||
121
lib/commerce/stack.sx
Normal file
121
lib/commerce/stack.sx
Normal file
@@ -0,0 +1,121 @@
|
||||
;; 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))))
|
||||
106
lib/commerce/stock.sx
Normal file
106
lib/commerce/stock.sx
Normal file
@@ -0,0 +1,106 @@
|
||||
;; 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))))
|
||||
73
lib/commerce/tests/api.sx
Normal file
73
lib/commerce/tests/api.sx
Normal file
@@ -0,0 +1,73 @@
|
||||
;; 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)
|
||||
124
lib/commerce/tests/attribution.sx
Normal file
124
lib/commerce/tests/attribution.sx
Normal file
@@ -0,0 +1,124 @@
|
||||
;; 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"))
|
||||
103
lib/commerce/tests/cart.sx
Normal file
103
lib/commerce/tests/cart.sx
Normal file
@@ -0,0 +1,103 @@
|
||||
;; 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"))
|
||||
93
lib/commerce/tests/catalog.sx
Normal file
93
lib/commerce/tests/catalog.sx
Normal file
@@ -0,0 +1,93 @@
|
||||
;; 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)
|
||||
88
lib/commerce/tests/federation.sx
Normal file
88
lib/commerce/tests/federation.sx
Normal file
@@ -0,0 +1,88 @@
|
||||
;; 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)
|
||||
104
lib/commerce/tests/integration.sx
Normal file
104
lib/commerce/tests/integration.sx
Normal file
@@ -0,0 +1,104 @@
|
||||
;; 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)
|
||||
80
lib/commerce/tests/ledger.sx
Normal file
80
lib/commerce/tests/ledger.sx
Normal file
@@ -0,0 +1,80 @@
|
||||
;; 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"))))
|
||||
92
lib/commerce/tests/nettax.sx
Normal file
92
lib/commerce/tests/nettax.sx
Normal file
@@ -0,0 +1,92 @@
|
||||
;; 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})
|
||||
74
lib/commerce/tests/order.sx
Normal file
74
lib/commerce/tests/order.sx
Normal file
@@ -0,0 +1,74 @@
|
||||
;; 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}}))
|
||||
43
lib/commerce/tests/payment.sx
Normal file
43
lib/commerce/tests/payment.sx
Normal file
@@ -0,0 +1,43 @@
|
||||
;; 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)
|
||||
100
lib/commerce/tests/price.sx
Normal file
100
lib/commerce/tests/price.sx
Normal file
@@ -0,0 +1,100 @@
|
||||
;; 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})
|
||||
142
lib/commerce/tests/promo.sx
Normal file
142
lib/commerce/tests/promo.sx
Normal file
@@ -0,0 +1,142 @@
|
||||
;; 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)
|
||||
108
lib/commerce/tests/quote.sx
Normal file
108
lib/commerce/tests/quote.sx
Normal file
@@ -0,0 +1,108 @@
|
||||
;; 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)
|
||||
109
lib/commerce/tests/recon.sx
Normal file
109
lib/commerce/tests/recon.sx
Normal file
@@ -0,0 +1,109 @@
|
||||
;; 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)
|
||||
78
lib/commerce/tests/refund.sx
Normal file
78
lib/commerce/tests/refund.sx
Normal file
@@ -0,0 +1,78 @@
|
||||
;; 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)
|
||||
127
lib/commerce/tests/stack.sx
Normal file
127
lib/commerce/tests/stack.sx
Normal file
@@ -0,0 +1,127 @@
|
||||
;; 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)
|
||||
122
lib/commerce/tests/stock.sx
Normal file
122
lib/commerce/tests/stock.sx
Normal file
@@ -0,0 +1,122 @@
|
||||
;; 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))
|
||||
112
lib/commerce/tests/window.sx
Normal file
112
lib/commerce/tests/window.sx
Normal file
@@ -0,0 +1,112 @@
|
||||
;; 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)
|
||||
55
lib/commerce/window.sx
Normal file
55
lib/commerce/window.sx
Normal file
@@ -0,0 +1,55 @@
|
||||
;; 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)))
|
||||
@@ -21,7 +21,7 @@ reconciliation — all auditable via the event log.
|
||||
|
||||
## Status (rolling)
|
||||
|
||||
`bash lib/commerce/conformance.sh` → **0/0** (not yet started)
|
||||
`bash lib/commerce/conformance.sh` → **297/297** (18 suites; + integration) — **roadmap + Phase 5 backlog + e2e composition proof complete**
|
||||
|
||||
## Ground rules
|
||||
|
||||
@@ -55,28 +55,223 @@ lib/commerce/api.sx ── (commerce/add) (commerce/total) (commerce/checkout)
|
||||
```
|
||||
|
||||
## Phase 1 — Catalog + cart + deterministic totals
|
||||
- [ ] `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
|
||||
- [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
|
||||
|
||||
## Phase 2 — Promotions (relational)
|
||||
- [ ] promo rules: percentage, fixed, bundle, member rate
|
||||
- [ ] explicit stacking precedence; "best price" backward query
|
||||
- [ ] tests: stacking order, mutually-exclusive promos, member vs guest
|
||||
- [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
|
||||
|
||||
## Phase 3 — Order lifecycle (flow + store)
|
||||
- [ ] order flow: reserve stock → await payment → fulfil
|
||||
- [ ] payment webhook resumes the suspended flow
|
||||
- [ ] order ledger as a `persist` stream; idempotent reconciliation
|
||||
- [x] order flow: reserve stock → await payment → fulfil
|
||||
- [x] payment webhook resumes the suspended flow
|
||||
- [x] order ledger as a `persist` stream; idempotent reconciliation
|
||||
|
||||
## Phase 4 — Reconciliation + federation
|
||||
- [ ] 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
|
||||
- [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.
|
||||
|
||||
## Progress log
|
||||
(loop fills this in)
|
||||
- 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.
|
||||
|
||||
## Blockers
|
||||
(loop fills this in)
|
||||
(none)
|
||||
|
||||
Reference in New Issue
Block a user