Compare commits
6 Commits
architectu
...
loops/cont
| Author | SHA1 | Date | |
|---|---|---|---|
| f68591456e | |||
| 160d0f2dd0 | |||
| e9316b37c2 | |||
| 29954689bc | |||
| f31c7a4002 | |||
| c5d9e1480d |
@@ -1 +1 @@
|
|||||||
{"sessionId":"c4d97db1-361c-4a04-a99b-c838f9385469","pid":2426590,"procStart":"349789073","acquiredAt":1780789990975}
|
{"sessionId":"bf20a443-9df8-4cb9-932e-8c6f4c4625c2","pid":1303602,"procStart":"253831081","acquiredAt":1779865895644}
|
||||||
@@ -571,12 +571,9 @@ and cek_run_with_io state =
|
|||||||
Hashtbl.replace d "descent" (Number desc);
|
Hashtbl.replace d "descent" (Number desc);
|
||||||
Dict d
|
Dict d
|
||||||
| _ ->
|
| _ ->
|
||||||
let argsv = Sx_runtime.get_val request (String "args") in
|
let args = let a = Sx_runtime.get_val request (String "args") in
|
||||||
(match Sx_persist_store.handle_op op argsv with
|
(match a with List l -> l | _ -> [a]) in
|
||||||
| Some resp -> resp
|
io_request op args
|
||||||
| None ->
|
|
||||||
let args = (match argsv with List l -> l | _ -> [argsv]) in
|
|
||||||
io_request op args)
|
|
||||||
in
|
in
|
||||||
s := Sx_ref.cek_resume !s response;
|
s := Sx_ref.cek_resume !s response;
|
||||||
loop ()
|
loop ()
|
||||||
@@ -858,164 +855,6 @@ let setup_evaluator_bridge env =
|
|||||||
done;
|
done;
|
||||||
Nil
|
Nil
|
||||||
| _ -> raise (Eval_error "http-listen: (port handler)"));
|
| _ -> raise (Eval_error "http-listen: (port handler)"));
|
||||||
|
|
||||||
(* fed-sx Milestone 1 client direction (Phase J). NATIVE ONLY —
|
|
||||||
Unix sockets + DNS; absent from the WASM kernel. HTTP/1.1
|
|
||||||
request: TCP connect, write request line + headers + body,
|
|
||||||
read status + headers + body, return {:status :headers :body}.
|
|
||||||
URL must be http://...; HTTPS is a later phase (needs TLS).
|
|
||||||
Body read: Content-Length first, else read to EOF (we send
|
|
||||||
Connection: close). Transfer-Encoding: chunked is rejected —
|
|
||||||
fed-sx Phase 8 wires this for inter-server POSTs which will
|
|
||||||
all carry Content-Length. *)
|
|
||||||
Sx_primitives.register "http-request" (fun args ->
|
|
||||||
let strip_cr s =
|
|
||||||
let n = String.length s in
|
|
||||||
if n > 0 && s.[n - 1] = '\r' then String.sub s 0 (n - 1) else s
|
|
||||||
in
|
|
||||||
match args with
|
|
||||||
| [String meth; String url; headers_v; body_v] ->
|
|
||||||
let body = match body_v with
|
|
||||||
| String s -> s
|
|
||||||
| Nil -> ""
|
|
||||||
| v -> Sx_types.value_to_string v in
|
|
||||||
let prefix = "http://" in
|
|
||||||
let plen = String.length prefix in
|
|
||||||
let ulen = String.length url in
|
|
||||||
if ulen < plen || String.sub url 0 plen <> prefix
|
|
||||||
then raise (Eval_error "http-request: URL must start with http://");
|
|
||||||
let rest = String.sub url plen (ulen - plen) in
|
|
||||||
let host_port, path =
|
|
||||||
match String.index_opt rest '/' with
|
|
||||||
| Some i ->
|
|
||||||
String.sub rest 0 i,
|
|
||||||
String.sub rest i (String.length rest - i)
|
|
||||||
| None -> rest, "/" in
|
|
||||||
if host_port = "" then
|
|
||||||
raise (Eval_error "http-request: missing host");
|
|
||||||
let host, port =
|
|
||||||
match String.index_opt host_port ':' with
|
|
||||||
| Some i ->
|
|
||||||
let h = String.sub host_port 0 i in
|
|
||||||
let ps = String.sub host_port (i + 1)
|
|
||||||
(String.length host_port - i - 1) in
|
|
||||||
(h,
|
|
||||||
(try int_of_string ps with _ ->
|
|
||||||
raise (Eval_error "http-request: bad port")))
|
|
||||||
| None -> host_port, 80 in
|
|
||||||
let addr =
|
|
||||||
(try (Unix.gethostbyname host).h_addr_list.(0)
|
|
||||||
with Not_found ->
|
|
||||||
raise (Eval_error ("http-request: dns: " ^ host))) in
|
|
||||||
let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
|
|
||||||
let cleanup () = try Unix.close sock with _ -> () in
|
|
||||||
let result =
|
|
||||||
(try
|
|
||||||
(try Unix.connect sock (Unix.ADDR_INET (addr, port))
|
|
||||||
with Unix.Unix_error (e, _, _) ->
|
|
||||||
raise (Eval_error
|
|
||||||
("http-request: connect: " ^ Unix.error_message e)));
|
|
||||||
let oc = Unix.out_channel_of_descr sock in
|
|
||||||
let ic = Unix.in_channel_of_descr sock in
|
|
||||||
let buf = Buffer.create 256 in
|
|
||||||
Buffer.add_string buf
|
|
||||||
(Printf.sprintf "%s %s HTTP/1.1\r\n" meth path);
|
|
||||||
let host_hdr_sent = ref false in
|
|
||||||
let clen_sent = ref false in
|
|
||||||
let conn_sent = ref false in
|
|
||||||
(match headers_v with
|
|
||||||
| Dict h ->
|
|
||||||
Hashtbl.iter (fun k v ->
|
|
||||||
let kl = String.lowercase_ascii k in
|
|
||||||
if kl = "host" then host_hdr_sent := true;
|
|
||||||
if kl = "content-length" then clen_sent := true;
|
|
||||||
if kl = "connection" then conn_sent := true;
|
|
||||||
let vs = match v with
|
|
||||||
| String s -> s
|
|
||||||
| x -> Sx_types.value_to_string x in
|
|
||||||
Buffer.add_string buf
|
|
||||||
(Printf.sprintf "%s: %s\r\n" k vs)) h
|
|
||||||
| Nil -> ()
|
|
||||||
| _ -> raise (Eval_error "http-request: headers must be dict"));
|
|
||||||
if not !host_hdr_sent then
|
|
||||||
Buffer.add_string buf
|
|
||||||
(Printf.sprintf "Host: %s\r\n" host_port);
|
|
||||||
if not !clen_sent then
|
|
||||||
Buffer.add_string buf
|
|
||||||
(Printf.sprintf "Content-Length: %d\r\n"
|
|
||||||
(String.length body));
|
|
||||||
if not !conn_sent then
|
|
||||||
Buffer.add_string buf "Connection: close\r\n";
|
|
||||||
Buffer.add_string buf "\r\n";
|
|
||||||
Buffer.add_string buf body;
|
|
||||||
output_string oc (Buffer.contents buf);
|
|
||||||
flush oc;
|
|
||||||
let sl =
|
|
||||||
(try strip_cr (input_line ic)
|
|
||||||
with End_of_file ->
|
|
||||||
raise (Eval_error
|
|
||||||
"http-request: connection closed before status")) in
|
|
||||||
let status =
|
|
||||||
match String.split_on_char ' ' sl with
|
|
||||||
| _ver :: code :: _ ->
|
|
||||||
(try int_of_string code with _ ->
|
|
||||||
raise (Eval_error "http-request: bad status code"))
|
|
||||||
| _ -> raise (Eval_error "http-request: bad status line") in
|
|
||||||
let rhdrs = Sx_types.make_dict () in
|
|
||||||
let clen = ref (-1) in
|
|
||||||
let chunked = ref false in
|
|
||||||
let rec rdh () =
|
|
||||||
let h =
|
|
||||||
(try strip_cr (input_line ic)
|
|
||||||
with End_of_file -> "") in
|
|
||||||
if h = "" then ()
|
|
||||||
else begin
|
|
||||||
(match String.index_opt h ':' with
|
|
||||||
| Some i ->
|
|
||||||
let name =
|
|
||||||
String.lowercase_ascii
|
|
||||||
(String.trim (String.sub h 0 i)) in
|
|
||||||
let value =
|
|
||||||
String.trim
|
|
||||||
(String.sub h (i + 1)
|
|
||||||
(String.length h - i - 1)) in
|
|
||||||
Hashtbl.replace rhdrs name (String value);
|
|
||||||
if name = "content-length" then
|
|
||||||
(try clen := int_of_string value with _ -> ())
|
|
||||||
else if name = "transfer-encoding" &&
|
|
||||||
String.lowercase_ascii value = "chunked"
|
|
||||||
then chunked := true
|
|
||||||
| None -> ());
|
|
||||||
rdh ()
|
|
||||||
end in
|
|
||||||
rdh ();
|
|
||||||
if !chunked then
|
|
||||||
raise (Eval_error
|
|
||||||
"http-request: chunked transfer-encoding not supported");
|
|
||||||
let rbody =
|
|
||||||
if !clen >= 0 then begin
|
|
||||||
let b = Bytes.create !clen in
|
|
||||||
really_input ic b 0 !clen;
|
|
||||||
Bytes.unsafe_to_string b
|
|
||||||
end else begin
|
|
||||||
let b = Buffer.create 256 in
|
|
||||||
(try
|
|
||||||
while true do
|
|
||||||
Buffer.add_channel b ic 4096
|
|
||||||
done; assert false
|
|
||||||
with End_of_file -> ());
|
|
||||||
Buffer.contents b
|
|
||||||
end in
|
|
||||||
let resp = Sx_types.make_dict () in
|
|
||||||
Hashtbl.replace resp "status" (Integer status);
|
|
||||||
Hashtbl.replace resp "headers" (Dict rhdrs);
|
|
||||||
Hashtbl.replace resp "body" (String rbody);
|
|
||||||
Dict resp
|
|
||||||
with e -> cleanup (); raise e) in
|
|
||||||
cleanup ();
|
|
||||||
result
|
|
||||||
| _ -> raise (Eval_error "http-request: (method url headers body)"));
|
|
||||||
|
|
||||||
bind "trampoline" (fun args ->
|
bind "trampoline" (fun args ->
|
||||||
match args with
|
match args with
|
||||||
| [v] ->
|
| [v] ->
|
||||||
@@ -1701,12 +1540,7 @@ let rec dispatch env cmd =
|
|||||||
| Some path -> load_library_file path | None -> ());
|
| Some path -> load_library_file path | None -> ());
|
||||||
Nil
|
Nil
|
||||||
end
|
end
|
||||||
end else
|
end else Nil (* non-import IO: resume with nil *) in
|
||||||
(* durable-storage ops: service against on-disk store *)
|
|
||||||
let args = Sx_runtime.get_val request (String "args") in
|
|
||||||
(match Sx_persist_store.handle_op op args with
|
|
||||||
| Some resp -> resp
|
|
||||||
| None -> Nil (* non-import IO: resume with nil *)) in
|
|
||||||
s := Sx_ref.cek_resume !s response
|
s := Sx_ref.cek_resume !s response
|
||||||
done;
|
done;
|
||||||
Sx_ref.cek_value !s
|
Sx_ref.cek_value !s
|
||||||
@@ -4059,10 +3893,7 @@ let http_mode port =
|
|||||||
Dict d
|
Dict d
|
||||||
| "io-sleep" | "sleep" -> Nil
|
| "io-sleep" | "sleep" -> Nil
|
||||||
| "import" -> Nil
|
| "import" -> Nil
|
||||||
| _ ->
|
| _ -> Nil);
|
||||||
(match Sx_persist_store.handle_op op args with
|
|
||||||
| Some resp -> resp
|
|
||||||
| None -> Nil));
|
|
||||||
(* Response cache — path → full HTTP response string.
|
(* Response cache — path → full HTTP response string.
|
||||||
Populated during pre-warm, serves cached responses in <0.1ms.
|
Populated during pre-warm, serves cached responses in <0.1ms.
|
||||||
Thread-safe: reads are lock-free (Hashtbl.find_opt is atomic for
|
Thread-safe: reads are lock-free (Hashtbl.find_opt is atomic for
|
||||||
|
|||||||
@@ -1,80 +0,0 @@
|
|||||||
#!/usr/bin/env bash
|
|
||||||
# Phase J test — native-only http-request client primitive.
|
|
||||||
# Reuses Phase H's http-listen to spin up an echo server, then drives
|
|
||||||
# a separate sx_server via the epoch protocol to issue http-request
|
|
||||||
# calls and assert response shape + headers + body.
|
|
||||||
set -u
|
|
||||||
cd "$(dirname "$0")/.."
|
|
||||||
|
|
||||||
SRV=_build/default/bin/sx_server.exe
|
|
||||||
PORT=${HTTP_CLIENT_TEST_PORT:-8921}
|
|
||||||
PASS=0
|
|
||||||
FAIL=0
|
|
||||||
ok() { echo " PASS: $1"; PASS=$((PASS+1)); }
|
|
||||||
bad() { echo " FAIL: $1 — $2"; FAIL=$((FAIL+1)); }
|
|
||||||
|
|
||||||
if [ ! -x "$SRV" ]; then
|
|
||||||
echo "build sx_server.exe first (dune build bin/sx_server.exe)"; exit 1
|
|
||||||
fi
|
|
||||||
|
|
||||||
# /echo echoes method/path/query/body and reflects request X-Custom
|
|
||||||
# back as response X-Got; /missing-test → 404.
|
|
||||||
H='(begin (define (h req) (if (= (get req "path") "/echo") {:status 200 :headers {"X-Echo" (get req "method") "X-Got" (get (get req "headers") "x-custom")} :body (str "M=" (get req "method") " P=" (get req "path") " Q=" (get req "query") " B=" (get req "body"))} (if (= (get req "path") "/missing-test") {:status 404 :body "nope"} {:status 500 :body "err"}))) (http-listen '"$PORT"' h))'
|
|
||||||
ESC=${H//\"/\\\"}
|
|
||||||
|
|
||||||
{ printf '(epoch 1)\n(eval "%s")\n' "$ESC"; sleep 60; } | "$SRV" >/tmp/test_http_client_srv.out 2>&1 &
|
|
||||||
SVPID=$!
|
|
||||||
trap 'kill $SVPID 2>/dev/null; wait 2>/dev/null' EXIT
|
|
||||||
|
|
||||||
up=0
|
|
||||||
for _ in $(seq 1 50); do
|
|
||||||
curl -s -o /dev/null "http://127.0.0.1:$PORT/echo" 2>/dev/null && { up=1; break; }
|
|
||||||
sleep 0.2
|
|
||||||
done
|
|
||||||
[ "$up" = 1 ] || { echo " FAIL: server did not start"; cat /tmp/test_http_client_srv.out; exit 1; }
|
|
||||||
|
|
||||||
emit() {
|
|
||||||
# $1 = epoch num, $2 = raw SX form. Wraps in (eval "...") with quotes escaped.
|
|
||||||
local esc=${2//\"/\\\"}
|
|
||||||
printf '(epoch %s)\n(eval "%s")\n' "$1" "$esc"
|
|
||||||
}
|
|
||||||
|
|
||||||
DRV_OUT=/tmp/test_http_client_drv.out
|
|
||||||
{
|
|
||||||
emit 1 '(let ((r (http-request "GET" "http://127.0.0.1:'"$PORT"'/echo?x=1" {} ""))) (str "S=" (get r "status") " E=" (get (get r "headers") "x-echo") " B=" (get r "body")))'
|
|
||||||
emit 2 '(let ((r (http-request "POST" "http://127.0.0.1:'"$PORT"'/echo" {} "hello"))) (str "S=" (get r "status") " B=" (get r "body")))'
|
|
||||||
emit 3 '(let ((r (http-request "GET" "http://127.0.0.1:'"$PORT"'/missing-test" {} ""))) (str "S=" (get r "status") " B=" (get r "body")))'
|
|
||||||
emit 4 '(let ((r (http-request "GET" "http://127.0.0.1:'"$PORT"'/echo" {"X-Custom" "myval"} ""))) (get (get r "headers") "x-got"))'
|
|
||||||
emit 5 '(http-request "GET" "ftp://nope" {} "")'
|
|
||||||
emit 6 '(let ((r (http-request "GET" "http://127.0.0.1:'"$PORT"'/echo" {} ""))) (get r "status"))'
|
|
||||||
} | "$SRV" >"$DRV_OUT" 2>&1
|
|
||||||
|
|
||||||
# eval results come back as (ok-len N L)\n<body>\n — grep the body content.
|
|
||||||
grep -q '^"S=200 E=GET B=M=GET P=/echo Q=x=1 B="$' "$DRV_OUT" \
|
|
||||||
&& ok "GET status + echo header + body" \
|
|
||||||
|| bad "GET" "$(grep -A1 '^(ok-len 1 ' "$DRV_OUT" | tail -1)"
|
|
||||||
|
|
||||||
grep -q '^"S=200 B=M=POST P=/echo Q= B=hello"$' "$DRV_OUT" \
|
|
||||||
&& ok "POST body roundtrip" \
|
|
||||||
|| bad "POST" "$(grep -A1 '^(ok-len 2 ' "$DRV_OUT" | tail -1)"
|
|
||||||
|
|
||||||
grep -q '^"S=404 B=nope"$' "$DRV_OUT" \
|
|
||||||
&& ok "404 status + body" \
|
|
||||||
|| bad "404" "$(grep -A1 '^(ok-len 3 ' "$DRV_OUT" | tail -1)"
|
|
||||||
|
|
||||||
grep -q '^"myval"$' "$DRV_OUT" \
|
|
||||||
&& ok "custom request header reaches server" \
|
|
||||||
|| bad "custom-header" "$(grep -A1 '^(ok-len 4 ' "$DRV_OUT" | tail -1)"
|
|
||||||
|
|
||||||
R5=$(grep '^(error 5 ' "$DRV_OUT" | head -1)
|
|
||||||
echo "$R5" | grep -q 'URL must start with http' \
|
|
||||||
&& ok "non-http scheme rejected" \
|
|
||||||
|| bad "bad-url" "$R5"
|
|
||||||
|
|
||||||
# Status is an Integer (200), serialized bare without quotes.
|
|
||||||
grep -q '^200$' "$DRV_OUT" \
|
|
||||||
&& ok "response status is integer 200" \
|
|
||||||
|| bad "status-integer" "$(grep -A1 '^(ok-len 6 ' "$DRV_OUT" | tail -1)"
|
|
||||||
|
|
||||||
echo "Results: $PASS passed, $FAIL failed"
|
|
||||||
[ "$FAIL" = 0 ]
|
|
||||||
@@ -1,293 +0,0 @@
|
|||||||
(* sx_persist_store — host durable-storage adapter for lib/persist.
|
|
||||||
Production twin of `persist/serve` (lib/persist/durable.sx): it answers the
|
|
||||||
same `persist/...` IO ops, but backs them with real on-disk storage so writes
|
|
||||||
survive a process restart. Stateless-on-disk: every op reads/writes the
|
|
||||||
filesystem directly, so a fresh process recovers state with no warm-up — the
|
|
||||||
log on disk IS the state.
|
|
||||||
|
|
||||||
On-disk layout under the root dir (default ./persist-data, or $SX_PERSIST_DIR):
|
|
||||||
streams/<hex(stream)>.log append-only, one SX-serialized event per line
|
|
||||||
streams/<hex(stream)>.seq per-stream monotonic high-water counter (int)
|
|
||||||
kv/<hex(key)> one SX-serialized value per key
|
|
||||||
|
|
||||||
Invariants honoured (see plans/persist-on-sx.md Blocker spec):
|
|
||||||
1. last-seq is a per-stream monotonic counter stored in .seq, SEPARATE from
|
|
||||||
the rows — it keeps climbing across truncate, so a compacted stream never
|
|
||||||
reassigns a seq.
|
|
||||||
2. append never renumbers — the event already carries its :seq (log.sx does
|
|
||||||
last-seq+1); the host only bumps the high-water mark to max(hw, seq).
|
|
||||||
3. read returns surviving events in append order with :seq intact.
|
|
||||||
4. streams is the set of streams that ever had an append — keyed off the .seq
|
|
||||||
file, which truncate never deletes, so it survives full compaction.
|
|
||||||
5. values round-trip structurally via the SX serializer/parser. *)
|
|
||||||
|
|
||||||
open Sx_types
|
|
||||||
|
|
||||||
(* ---- root dir ---------------------------------------------------------- *)
|
|
||||||
|
|
||||||
let _root : string option ref = ref None
|
|
||||||
|
|
||||||
let set_root dir = _root := Some dir
|
|
||||||
|
|
||||||
let root_dir () =
|
|
||||||
match !_root with
|
|
||||||
| Some d -> d
|
|
||||||
| None -> (try Sys.getenv "SX_PERSIST_DIR" with Not_found -> "persist-data")
|
|
||||||
|
|
||||||
(* ---- filesystem helpers ------------------------------------------------ *)
|
|
||||||
|
|
||||||
let rec ensure_dir dir =
|
|
||||||
if dir = "" || dir = "." || dir = "/" || Sys.file_exists dir then ()
|
|
||||||
else begin
|
|
||||||
ensure_dir (Filename.dirname dir);
|
|
||||||
(try Unix.mkdir dir 0o755 with Unix.Unix_error (Unix.EEXIST, _, _) -> ())
|
|
||||||
end
|
|
||||||
|
|
||||||
let streams_dir () = Filename.concat (root_dir ()) "streams"
|
|
||||||
let kv_dir () = Filename.concat (root_dir ()) "kv"
|
|
||||||
let blobs_dir () = Filename.concat (root_dir ()) "blobs"
|
|
||||||
|
|
||||||
let read_file path =
|
|
||||||
let ic = open_in_bin path in
|
|
||||||
let n = in_channel_length ic in
|
|
||||||
let s = really_input_string ic n in
|
|
||||||
close_in ic;
|
|
||||||
s
|
|
||||||
|
|
||||||
(* Atomic write: temp file in the same dir then rename over the target. *)
|
|
||||||
let write_file_atomic path contents =
|
|
||||||
ensure_dir (Filename.dirname path);
|
|
||||||
let tmp = path ^ ".tmp" in
|
|
||||||
let oc = open_out_bin tmp in
|
|
||||||
output_string oc contents;
|
|
||||||
flush oc;
|
|
||||||
close_out oc;
|
|
||||||
Sys.rename tmp path
|
|
||||||
|
|
||||||
let append_line path line =
|
|
||||||
ensure_dir (Filename.dirname path);
|
|
||||||
let oc = open_out_gen [Open_append; Open_creat; Open_wronly] 0o644 path in
|
|
||||||
output_string oc line;
|
|
||||||
output_char oc '\n';
|
|
||||||
close_out oc
|
|
||||||
|
|
||||||
(* ---- name <-> filename (hex, reversible, fs-safe) ---------------------- *)
|
|
||||||
|
|
||||||
let hex_encode s =
|
|
||||||
let b = Buffer.create (String.length s * 2) in
|
|
||||||
String.iter (fun c -> Buffer.add_string b (Printf.sprintf "%02x" (Char.code c))) s;
|
|
||||||
Buffer.contents b
|
|
||||||
|
|
||||||
let hex_decode s =
|
|
||||||
let n = String.length s / 2 in
|
|
||||||
String.init n (fun i -> Char.chr (int_of_string ("0x" ^ String.sub s (i * 2) 2)))
|
|
||||||
|
|
||||||
let stream_log stream = Filename.concat (streams_dir ()) (hex_encode stream ^ ".log")
|
|
||||||
let stream_seq stream = Filename.concat (streams_dir ()) (hex_encode stream ^ ".seq")
|
|
||||||
let kv_path key = Filename.concat (kv_dir ()) (hex_encode key)
|
|
||||||
|
|
||||||
(* ---- value <-> SX text (round-trips through Sx_parser) ----------------- *)
|
|
||||||
|
|
||||||
let escape_str s =
|
|
||||||
let len = String.length s in
|
|
||||||
let buf = Buffer.create (len + 16) in
|
|
||||||
for i = 0 to len - 1 do
|
|
||||||
match s.[i] with
|
|
||||||
| '"' -> Buffer.add_string buf "\\\""
|
|
||||||
| '\\' -> Buffer.add_string buf "\\\\"
|
|
||||||
| '\n' -> Buffer.add_string buf "\\n"
|
|
||||||
| '\r' -> Buffer.add_string buf "\\r"
|
|
||||||
| '\t' -> Buffer.add_string buf "\\t"
|
|
||||||
| c -> Buffer.add_char buf c
|
|
||||||
done;
|
|
||||||
Buffer.contents buf
|
|
||||||
|
|
||||||
let rec serialize = function
|
|
||||||
| Nil -> "nil"
|
|
||||||
| Bool true -> "true"
|
|
||||||
| Bool false -> "false"
|
|
||||||
| Integer n -> string_of_int n
|
|
||||||
| Number n -> format_number n
|
|
||||||
| String s -> "\"" ^ escape_str s ^ "\""
|
|
||||||
| Symbol s -> "(quote " ^ s ^ ")"
|
|
||||||
| Keyword k -> ":" ^ k
|
|
||||||
| List items | ListRef { contents = items } ->
|
|
||||||
"(list" ^ (List.fold_left (fun acc v -> acc ^ " " ^ serialize v) "" items) ^ ")"
|
|
||||||
| Dict d ->
|
|
||||||
let pairs = Hashtbl.fold (fun k v acc ->
|
|
||||||
(Printf.sprintf ":%s %s" k (serialize v)) :: acc) d [] in
|
|
||||||
"{" ^ String.concat " " (List.sort String.compare pairs) ^ "}"
|
|
||||||
| _ -> "nil"
|
|
||||||
|
|
||||||
(* Parse one serialized value back. Empty / blank -> Nil. *)
|
|
||||||
let rec deserialize line =
|
|
||||||
let line = String.trim line in
|
|
||||||
if line = "" then Nil
|
|
||||||
else match Sx_parser.parse_all line with
|
|
||||||
| v :: _ -> eval_quote_lists v
|
|
||||||
| [] -> Nil
|
|
||||||
|
|
||||||
(* serialize emits lists as `(list ...)` and symbols as `(quote s)` so the
|
|
||||||
parser yields data, not a call — but the parser leaves those as AST. Walk
|
|
||||||
the parsed AST and collapse `(list ...)`/`(quote s)` back to values. *)
|
|
||||||
and eval_quote_lists v =
|
|
||||||
match v with
|
|
||||||
| List (Symbol "quote" :: x :: []) -> x
|
|
||||||
| List (Symbol "list" :: rest) -> List (List.map eval_quote_lists rest)
|
|
||||||
| List items -> List (List.map eval_quote_lists items)
|
|
||||||
| ListRef { contents = items } -> List (List.map eval_quote_lists items)
|
|
||||||
| Dict d ->
|
|
||||||
let d' = Hashtbl.create (Hashtbl.length d) in
|
|
||||||
Hashtbl.iter (fun k v -> Hashtbl.replace d' k (eval_quote_lists v)) d;
|
|
||||||
Dict d'
|
|
||||||
| other -> other
|
|
||||||
|
|
||||||
(* ---- seq counter ------------------------------------------------------- *)
|
|
||||||
|
|
||||||
let read_seq stream =
|
|
||||||
let p = stream_seq stream in
|
|
||||||
if Sys.file_exists p then (try int_of_string (String.trim (read_file p)) with _ -> 0)
|
|
||||||
else 0
|
|
||||||
|
|
||||||
let write_seq stream n = write_file_atomic (stream_seq stream) (string_of_int n)
|
|
||||||
|
|
||||||
let value_to_int = function
|
|
||||||
| Integer n -> n
|
|
||||||
| Number n -> int_of_float n
|
|
||||||
| _ -> 0
|
|
||||||
|
|
||||||
let event_seq ev =
|
|
||||||
match ev with
|
|
||||||
| Dict d -> (match Hashtbl.find_opt d "seq" with Some v -> value_to_int v | None -> 0)
|
|
||||||
| _ -> 0
|
|
||||||
|
|
||||||
(* ---- ops --------------------------------------------------------------- *)
|
|
||||||
|
|
||||||
let do_append stream ev =
|
|
||||||
ensure_dir (streams_dir ());
|
|
||||||
(* bump the monotonic high-water mark; create .seq on first append so the
|
|
||||||
stream shows up in `streams` and survives later truncation. *)
|
|
||||||
let hw = read_seq stream in
|
|
||||||
let s = event_seq ev in
|
|
||||||
write_seq stream (max hw s);
|
|
||||||
append_line (stream_log stream) (serialize ev)
|
|
||||||
|
|
||||||
let do_read stream =
|
|
||||||
let p = stream_log stream in
|
|
||||||
if not (Sys.file_exists p) then List []
|
|
||||||
else begin
|
|
||||||
let content = read_file p in
|
|
||||||
let lines = String.split_on_char '\n' content in
|
|
||||||
let evs = List.filter_map (fun l ->
|
|
||||||
if String.trim l = "" then None else Some (deserialize l)) lines in
|
|
||||||
List evs
|
|
||||||
end
|
|
||||||
|
|
||||||
let do_last_seq stream = Number (float_of_int (read_seq stream))
|
|
||||||
|
|
||||||
let list_dir_suffix dir suffix =
|
|
||||||
if not (Sys.file_exists dir) then []
|
|
||||||
else
|
|
||||||
Array.to_list (Sys.readdir dir)
|
|
||||||
|> List.filter (fun f -> Filename.check_suffix f suffix)
|
|
||||||
|> List.map (fun f -> hex_decode (Filename.chop_suffix f suffix))
|
|
||||||
|> List.sort String.compare
|
|
||||||
|
|
||||||
let do_streams () = List (List.map (fun s -> String s) (list_dir_suffix (streams_dir ()) ".seq"))
|
|
||||||
|
|
||||||
(* drop events with seq <= n; the .seq high-water counter is untouched. *)
|
|
||||||
let do_truncate stream n =
|
|
||||||
let p = stream_log stream in
|
|
||||||
if Sys.file_exists p then begin
|
|
||||||
let evs = match do_read stream with List l -> l | _ -> [] in
|
|
||||||
let kept = List.filter (fun ev -> event_seq ev > n) evs in
|
|
||||||
let body = String.concat "" (List.map (fun ev -> serialize ev ^ "\n") kept) in
|
|
||||||
write_file_atomic p body
|
|
||||||
end
|
|
||||||
|
|
||||||
let do_kv_get key =
|
|
||||||
let p = kv_path key in
|
|
||||||
if Sys.file_exists p then deserialize (read_file p) else Nil
|
|
||||||
|
|
||||||
let do_kv_put key v =
|
|
||||||
ensure_dir (kv_dir ());
|
|
||||||
write_file_atomic (kv_path key) (serialize v)
|
|
||||||
|
|
||||||
let do_kv_delete key =
|
|
||||||
let p = kv_path key in
|
|
||||||
if Sys.file_exists p then (try Sys.remove p with _ -> ())
|
|
||||||
|
|
||||||
let do_kv_has key = Bool (Sys.file_exists (kv_path key))
|
|
||||||
|
|
||||||
let do_kv_keys () =
|
|
||||||
if not (Sys.file_exists (kv_dir ())) then List []
|
|
||||||
else
|
|
||||||
List (
|
|
||||||
Array.to_list (Sys.readdir (kv_dir ()))
|
|
||||||
|> List.map hex_decode
|
|
||||||
|> List.sort String.compare
|
|
||||||
|> List.map (fun s -> String s))
|
|
||||||
|
|
||||||
(* ---- blob store (content-addressed) ------------------------------------ *)
|
|
||||||
(* Same pattern as the persist ops, but a SEPARATE adapter: large objects live
|
|
||||||
in a content-addressed directory keyed by a CIDv1 (raw codec, sha2-256).
|
|
||||||
persist only ever stores the returned ref ({:cid :size :mime}), never bytes.
|
|
||||||
blob/put is idempotent — identical bytes hash to the same cid + same file. *)
|
|
||||||
|
|
||||||
let codec_raw = 0x55
|
|
||||||
|
|
||||||
let blob_cid bytes =
|
|
||||||
let digest = Sx_cid.unhex (Sx_sha2.sha256_hex bytes) in
|
|
||||||
Sx_cid.cidv1 codec_raw (Sx_cid.multihash Sx_cid.mh_sha2_256 digest)
|
|
||||||
|
|
||||||
let blob_path cid = Filename.concat (blobs_dir ()) cid
|
|
||||||
|
|
||||||
let do_blob_put bytes =
|
|
||||||
let cid = blob_cid bytes in
|
|
||||||
let p = blob_path cid in
|
|
||||||
if not (Sys.file_exists p) then write_file_atomic p bytes;
|
|
||||||
String cid
|
|
||||||
|
|
||||||
let do_blob_get cid =
|
|
||||||
let p = blob_path cid in
|
|
||||||
if Sys.file_exists p then String (read_file p) else Nil
|
|
||||||
|
|
||||||
let do_blob_has cid = Bool (Sys.file_exists (blob_path cid))
|
|
||||||
|
|
||||||
(* ---- dispatch ---------------------------------------------------------- *)
|
|
||||||
|
|
||||||
let arglist = function
|
|
||||||
| List l | ListRef { contents = l } -> l
|
|
||||||
| Nil -> []
|
|
||||||
| v -> [v]
|
|
||||||
|
|
||||||
(* Returns Some response if op is a persist op this store owns, None otherwise. *)
|
|
||||||
let handle_op op args =
|
|
||||||
let a = arglist args in
|
|
||||||
let str = function String s -> s | v -> value_to_string v in
|
|
||||||
match op with
|
|
||||||
| "persist/append" ->
|
|
||||||
(match a with stream :: ev :: _ -> do_append (str stream) ev | _ -> ()); Some Nil
|
|
||||||
| "persist/read" ->
|
|
||||||
(match a with stream :: _ -> Some (do_read (str stream)) | _ -> Some (List []))
|
|
||||||
| "persist/last-seq" ->
|
|
||||||
(match a with stream :: _ -> Some (do_last_seq (str stream)) | _ -> Some (Number 0.0))
|
|
||||||
| "persist/streams" -> Some (do_streams ())
|
|
||||||
| "persist/truncate" ->
|
|
||||||
(match a with stream :: n :: _ -> do_truncate (str stream) (value_to_int n) | _ -> ()); Some Nil
|
|
||||||
| "persist/kv-get" ->
|
|
||||||
(match a with key :: _ -> Some (do_kv_get (str key)) | _ -> Some Nil)
|
|
||||||
| "persist/kv-put" ->
|
|
||||||
(match a with key :: v :: _ -> do_kv_put (str key) v | _ -> ()); Some Nil
|
|
||||||
| "persist/kv-delete" ->
|
|
||||||
(match a with key :: _ -> do_kv_delete (str key) | _ -> ()); Some Nil
|
|
||||||
| "persist/kv-has?" ->
|
|
||||||
(match a with key :: _ -> Some (do_kv_has (str key)) | _ -> Some (Bool false))
|
|
||||||
| "persist/kv-keys" -> Some (do_kv_keys ())
|
|
||||||
| "blob/put" ->
|
|
||||||
(match a with bytes :: _ -> Some (do_blob_put (str bytes)) | _ -> Some Nil)
|
|
||||||
| "blob/get" ->
|
|
||||||
(match a with cid :: _ -> Some (do_blob_get (str cid)) | _ -> Some Nil)
|
|
||||||
| "blob/has?" ->
|
|
||||||
(match a with cid :: _ -> Some (do_blob_has (str cid)) | _ -> Some (Bool false))
|
|
||||||
| _ -> None
|
|
||||||
@@ -1,144 +0,0 @@
|
|||||||
#!/usr/bin/env bash
|
|
||||||
# hosts/ocaml/test/persist_durable_test.sh
|
|
||||||
# Acceptance test for the host durable-storage adapter (Sx_persist_store).
|
|
||||||
#
|
|
||||||
# Exercises `persist/durable-backend` (REAL `perform`, not the mock) under the
|
|
||||||
# WORKTREE-built sx_server.exe, and asserts:
|
|
||||||
# 1. durable: writes land on disk and read back (the silent-data-loss repro
|
|
||||||
# from plans/persist-on-sx.md now returns correct values).
|
|
||||||
# 2. last-seq is monotonic across truncate (compaction never reassigns a seq).
|
|
||||||
# 3. kv ops round-trip and delete.
|
|
||||||
# 4. recovery: a REAL process restart (write, exit, fresh process, replay)
|
|
||||||
# recovers state from disk.
|
|
||||||
#
|
|
||||||
# Run from repo root or anywhere; locates the worktree binary relative to itself.
|
|
||||||
set -uo pipefail
|
|
||||||
|
|
||||||
HERE="$(cd "$(dirname "${BASH_SOURCE[0]}")" && pwd)"
|
|
||||||
ROOT="$(cd "$HERE/../../.." && pwd)" # repo/worktree root
|
|
||||||
cd "$ROOT"
|
|
||||||
|
|
||||||
SX="hosts/ocaml/_build/default/bin/sx_server.exe"
|
|
||||||
if [ ! -x "$SX" ]; then
|
|
||||||
echo "ERROR: worktree binary not found at $SX — build it first:" >&2
|
|
||||||
echo " (cd hosts/ocaml && dune build bin/sx_server.exe)" >&2
|
|
||||||
exit 1
|
|
||||||
fi
|
|
||||||
|
|
||||||
DATADIR="$(mktemp -d)"
|
|
||||||
trap 'rm -rf "$DATADIR"' EXIT
|
|
||||||
|
|
||||||
PASS=0
|
|
||||||
FAIL=0
|
|
||||||
check() { # check <label> <got> <expected>
|
|
||||||
if [ "$2" = "$3" ]; then
|
|
||||||
PASS=$((PASS + 1)); printf ' ok %-40s => %s\n' "$1" "$2"
|
|
||||||
else
|
|
||||||
FAIL=$((FAIL + 1)); printf ' FAIL %-40s got [%s] want [%s]\n' "$1" "$2" "$3"
|
|
||||||
fi
|
|
||||||
}
|
|
||||||
|
|
||||||
PRELUDE='(epoch 1)
|
|
||||||
(load "spec/stdlib.sx")
|
|
||||||
(load "lib/r7rs.sx")
|
|
||||||
(load "lib/persist/event.sx")
|
|
||||||
(load "lib/persist/backend.sx")
|
|
||||||
(load "lib/persist/log.sx")
|
|
||||||
(load "lib/persist/kv.sx")
|
|
||||||
(load "lib/persist/durable.sx")
|
|
||||||
(load "lib/persist/blob.sx")
|
|
||||||
(epoch 2)'
|
|
||||||
|
|
||||||
# run_eval <sx-expr-string>: prints the final (ok-len 2 ...) payload line.
|
|
||||||
run_eval() {
|
|
||||||
local expr="$1"
|
|
||||||
printf '%s\n(eval %s)\n' "$PRELUDE" "$expr" \
|
|
||||||
| SX_PERSIST_DIR="$DATADIR" timeout 60 "$SX" 2>/dev/null \
|
|
||||||
| awk '/^\(ok-len 2 / {getline; print; exit}'
|
|
||||||
}
|
|
||||||
|
|
||||||
# escape an SX program into a single-line double-quoted SX string literal for
|
|
||||||
# (eval "..."). The REPL reads one command per physical line, so newlines in the
|
|
||||||
# program are collapsed to spaces.
|
|
||||||
q() { printf '"%s"' "$(printf '%s' "$1" | tr '\n' ' ' | sed 's/\\/\\\\/g; s/"/\\"/g')"; }
|
|
||||||
|
|
||||||
echo "== durable: append/read/last-seq round-trip on disk =="
|
|
||||||
GOT=$(run_eval "$(q '(let ((b (persist/durable-backend)))
|
|
||||||
(begin
|
|
||||||
(persist/append b "s" "x" 0 {:v 1})
|
|
||||||
(persist/append b "s" "x" 0 {:v 2})
|
|
||||||
(list (persist/event-seq (persist/append b "s" "x" 0 {:v 3}))
|
|
||||||
(persist/count b "s")
|
|
||||||
(len (persist/read b "s")))))')")
|
|
||||||
check "append/count/read" "$GOT" "(3 3 3)"
|
|
||||||
|
|
||||||
echo "== last-seq monotonic across truncate =="
|
|
||||||
GOT=$(run_eval "$(q '(let ((b (persist/durable-backend)))
|
|
||||||
(begin
|
|
||||||
(persist/append b "t" "x" 0 {})
|
|
||||||
(persist/append b "t" "x" 0 {})
|
|
||||||
(persist/append b "t" "x" 0 {})
|
|
||||||
(persist/truncate b "t" 2)
|
|
||||||
(list (persist/last-seq b "t") (persist/count b "t"))))')")
|
|
||||||
check "last-seq survives truncate" "$GOT" "(3 1)"
|
|
||||||
|
|
||||||
echo "== streams set survives compaction =="
|
|
||||||
GOT=$(run_eval "$(q '(let ((b (persist/durable-backend)))
|
|
||||||
(sort ((get b "streams"))))')")
|
|
||||||
check "streams" "$GOT" '("s" "t")'
|
|
||||||
|
|
||||||
echo "== kv round-trip + delete =="
|
|
||||||
GOT=$(run_eval "$(q '(let ((b (persist/durable-backend)))
|
|
||||||
(begin
|
|
||||||
(persist/kv-put b "k" {:a 1 :b "two"})
|
|
||||||
(persist/kv-put b "gone" 9)
|
|
||||||
(persist/kv-delete b "gone")
|
|
||||||
(list (get (persist/kv-get b "k") :b)
|
|
||||||
(persist/kv-has? b "k")
|
|
||||||
(persist/kv-has? b "gone"))))')")
|
|
||||||
check "kv get/has/delete" "$GOT" '("two" true false)'
|
|
||||||
|
|
||||||
echo "== recovery: state survives a REAL process restart =="
|
|
||||||
# write in process A then let it exit; the next run is a brand-new process.
|
|
||||||
run_eval "$(q '(let ((b (persist/durable-backend)))
|
|
||||||
(begin
|
|
||||||
(persist/append b "r" "ev" 0 {:n 1})
|
|
||||||
(persist/append b "r" "ev" 0 {:n 2})
|
|
||||||
(persist/kv-put b "survive" "yes")
|
|
||||||
(persist/count b "r")))')" >/dev/null
|
|
||||||
# fresh process, same SX_PERSIST_DIR — must replay from disk.
|
|
||||||
GOT=$(run_eval "$(q '(let ((b (persist/durable-backend)))
|
|
||||||
(list (persist/count b "r")
|
|
||||||
(persist/last-seq b "r")
|
|
||||||
(get (get (nth (persist/read b "r") 1) :data) :n)
|
|
||||||
(persist/kv-get b "survive")))')")
|
|
||||||
check "recovered after restart" "$GOT" '(2 2 2 "yes")'
|
|
||||||
|
|
||||||
echo "== blob: content-addressed put/get/has? round-trip =="
|
|
||||||
GOT=$(run_eval "$(q '(let ((bs (persist/blob-store-backend)))
|
|
||||||
(let ((r (persist/blob-store bs "hello world" "text/plain")))
|
|
||||||
(list (persist/blob-size r)
|
|
||||||
(persist/blob-mime r)
|
|
||||||
(persist/blob-fetch bs r)
|
|
||||||
(persist/blob-exists? bs r))))')")
|
|
||||||
check "blob size/mime/fetch/exists" "$GOT" '(11 "text/plain" "hello world" true)'
|
|
||||||
|
|
||||||
echo "== blob: put is content-addressed (idempotent cid) =="
|
|
||||||
GOT=$(run_eval "$(q '(let ((bs (persist/blob-store-backend)))
|
|
||||||
(equal? (persist/blob-cid (persist/blob-store bs "same bytes" "x"))
|
|
||||||
(persist/blob-cid (persist/blob-store bs "same bytes" "x"))))')")
|
|
||||||
check "same bytes -> same cid" "$GOT" "true"
|
|
||||||
|
|
||||||
echo "== blob: bytes + ref-in-kv survive a REAL restart =="
|
|
||||||
# process A: store a blob, keep only its ref in the durable kv.
|
|
||||||
run_eval "$(q '(let ((b (persist/durable-backend)) (bs (persist/blob-store-backend)))
|
|
||||||
(begin (persist/kv-put b "logo" (persist/blob-store bs "PNGDATA" "image/png")) nil))')" >/dev/null
|
|
||||||
# fresh process: read the ref from kv, fetch the bytes from the blob store.
|
|
||||||
GOT=$(run_eval "$(q '(let ((b (persist/durable-backend)) (bs (persist/blob-store-backend)))
|
|
||||||
(let ((r (persist/kv-get b "logo")))
|
|
||||||
(list (persist/blob-fetch bs r) (persist/blob-exists? bs r) (persist/blob-mime r))))')")
|
|
||||||
check "blob recovered via ref after restart" "$GOT" '("PNGDATA" true "image/png")'
|
|
||||||
|
|
||||||
echo
|
|
||||||
echo "durable adapter: $PASS passed, $FAIL failed"
|
|
||||||
[ "$FAIL" -eq 0 ]
|
|
||||||
@@ -1,88 +0,0 @@
|
|||||||
; lib/artdag/analyze.sx — Phase 2: Analyze on Datalog.
|
|
||||||
; Project the DAG's edges into a Datalog db and answer dependency questions
|
|
||||||
; (deps, dependents, transitive reachability) plus dirty-closure propagation
|
|
||||||
; as recursive Datalog — the acl/relations reachability shape. Depends on
|
|
||||||
; lib/artdag/dag.sx and the lib/datalog/ public API.
|
|
||||||
|
|
||||||
; edge(input-id, node-id): data flows input -> node (input is a dependency).
|
|
||||||
(define
|
|
||||||
artdag/edge-facts
|
|
||||||
(fn
|
|
||||||
(dag)
|
|
||||||
(reduce
|
|
||||||
(fn
|
|
||||||
(acc id)
|
|
||||||
(concat
|
|
||||||
acc
|
|
||||||
(map
|
|
||||||
(fn (in) (list (quote edge) in id))
|
|
||||||
(artdag/node-inputs (artdag/dag-get dag id)))))
|
|
||||||
(list)
|
|
||||||
(keys (artdag/dag-nodes dag)))))
|
|
||||||
|
|
||||||
; reachable(X,Y): Y is a transitive dependent of X (forward, downstream).
|
|
||||||
(define
|
|
||||||
artdag/reach-rules
|
|
||||||
(quote
|
|
||||||
((reachable X Y <- (edge X Y))
|
|
||||||
(reachable X Z <- (edge X Y) (reachable Y Z)))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
artdag/analyze
|
|
||||||
(fn (dag) (dl-program-data (artdag/edge-facts dag) artdag/reach-rules)))
|
|
||||||
|
|
||||||
; pull a single variable's bindings out of a subst list, sorted for determinism.
|
|
||||||
(define
|
|
||||||
artdag/-bindings
|
|
||||||
(fn
|
|
||||||
(substs var)
|
|
||||||
(artdag/sort-strings (map (fn (s) (get s var)) substs))))
|
|
||||||
|
|
||||||
; direct dependencies (inputs) of a node.
|
|
||||||
(define
|
|
||||||
artdag/deps-of
|
|
||||||
(fn
|
|
||||||
(db id)
|
|
||||||
(artdag/-bindings (dl-query db (list (quote edge) (quote X) id)) :X)))
|
|
||||||
|
|
||||||
; direct dependents of a node.
|
|
||||||
(define
|
|
||||||
artdag/dependents-of
|
|
||||||
(fn
|
|
||||||
(db id)
|
|
||||||
(artdag/-bindings (dl-query db (list (quote edge) id (quote Y))) :Y)))
|
|
||||||
|
|
||||||
; transitive dependents (everything downstream of a node).
|
|
||||||
(define
|
|
||||||
artdag/reachable-from
|
|
||||||
(fn
|
|
||||||
(db id)
|
|
||||||
(artdag/-bindings
|
|
||||||
(dl-query db (list (quote reachable) id (quote Y)))
|
|
||||||
:Y)))
|
|
||||||
|
|
||||||
; transitive dependencies (everything upstream of a node).
|
|
||||||
(define
|
|
||||||
artdag/ancestors-of
|
|
||||||
(fn
|
|
||||||
(db id)
|
|
||||||
(artdag/-bindings
|
|
||||||
(dl-query db (list (quote reachable) (quote X) id))
|
|
||||||
:X)))
|
|
||||||
|
|
||||||
; dirty propagation: dirty(Y) :- edge(X,Y), dirty(X). Seeds are changed nodes.
|
|
||||||
(define artdag/dirty-rules (quote ((dirty Y <- (edge X Y) (dirty X)))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
artdag/dirty-seeds
|
|
||||||
(fn (changed) (map (fn (c) (list (quote dirty) c)) changed)))
|
|
||||||
|
|
||||||
; transitive dirty closure of a set of changed node-ids: the changed nodes plus
|
|
||||||
; every transitive dependent that must recompute. Sorted, deduplicated.
|
|
||||||
(define
|
|
||||||
artdag/dirty-closure
|
|
||||||
(fn
|
|
||||||
(dag changed)
|
|
||||||
(let
|
|
||||||
((db (dl-program-data (concat (artdag/edge-facts dag) (artdag/dirty-seeds changed)) artdag/dirty-rules)))
|
|
||||||
(artdag/-bindings (dl-query db (list (quote dirty) (quote X))) :X))))
|
|
||||||
@@ -1,91 +0,0 @@
|
|||||||
; lib/artdag/api.sx — public API index for the artdag content-addressed dataflow
|
|
||||||
; DAG engine. Reference-only: `load` is an epoch-protocol command, not an SX
|
|
||||||
; function, so this file cannot reload the modules from inside another `.sx`. To
|
|
||||||
; set up a session, issue these loads in order (after spec/stdlib.sx + lib/r7rs.sx,
|
|
||||||
; the lib/datalog/* modules, and the lib/persist/* modules):
|
|
||||||
;
|
|
||||||
; (load "lib/artdag/dag.sx")
|
|
||||||
; (load "lib/artdag/analyze.sx") ; requires lib/datalog/*
|
|
||||||
; (load "lib/artdag/plan.sx")
|
|
||||||
; (load "lib/artdag/execute.sx") ; requires lib/persist/*
|
|
||||||
; (load "lib/artdag/optimize.sx")
|
|
||||||
; (load "lib/artdag/federation.sx")
|
|
||||||
; (load "lib/artdag/cost.sx")
|
|
||||||
; (load "lib/artdag/serialize.sx")
|
|
||||||
; (load "lib/artdag/stats.sx")
|
|
||||||
; (load "lib/artdag/fault.sx")
|
|
||||||
;
|
|
||||||
; (lib/artdag/conformance.sh runs this load list automatically.)
|
|
||||||
;
|
|
||||||
; ── Public API surface ─────────────────────────────────────────────
|
|
||||||
;
|
|
||||||
; Model / content addressing (dag.sx):
|
|
||||||
; (artdag/node op inputs params) node spec (non-commutative)
|
|
||||||
; (artdag/cnode op inputs params) commutative node spec
|
|
||||||
; (artdag/content-id node) structural digest "node:..."
|
|
||||||
; (artdag/build entries) {:ok :nodes :names :order} | {:ok false :error}
|
|
||||||
; entry = (name op (input-names...) params [commutative?])
|
|
||||||
; (artdag/dag-id dag name) local name -> content-id
|
|
||||||
; (artdag/dag-get dag id) content-id -> node
|
|
||||||
; (artdag/dag-node-by-name dag name) name -> node
|
|
||||||
; (artdag/dag-order dag) topo-ordered content-ids
|
|
||||||
; (artdag/node-count dag) distinct node count
|
|
||||||
;
|
|
||||||
; Analyze on Datalog (analyze.sx):
|
|
||||||
; (artdag/analyze dag) -> datalog db
|
|
||||||
; (artdag/deps-of db id) direct dependencies
|
|
||||||
; (artdag/dependents-of db id) direct dependents
|
|
||||||
; (artdag/reachable-from db id) transitive dependents
|
|
||||||
; (artdag/ancestors-of db id) transitive dependencies
|
|
||||||
; (artdag/dirty-closure dag changed) changed nodes + all dependents
|
|
||||||
;
|
|
||||||
; Plan (plan.sx):
|
|
||||||
; (artdag/plan dag cap) topo batches under width cap (0 = unlimited)
|
|
||||||
; (artdag/plan-dirty dag changed cap) incremental plan over the dirty closure
|
|
||||||
; (artdag/plan-batches/-width/-size/-flatten plan)
|
|
||||||
;
|
|
||||||
; Execute (execute.sx):
|
|
||||||
; (artdag/op-table-runner table) runner from op-name -> (fn (params inputs))
|
|
||||||
; (artdag/run dag runner cache) full memoized run
|
|
||||||
; (artdag/run-dirty dag changed runner cache)
|
|
||||||
; (artdag/execute dag plan runner cache) -> {:results :recomputed :hits}
|
|
||||||
; (artdag/result-of/recompute-count/hit-count/recomputed exec)
|
|
||||||
; cache = a lib/persist kv backend (persist/open)
|
|
||||||
;
|
|
||||||
; Optimize (optimize.sx):
|
|
||||||
; (artdag/dce dag outputs) drop nodes not feeding the outputs
|
|
||||||
; (artdag/cse entries) == build (sharing is free from content ids)
|
|
||||||
; (artdag/fuse entries fusible?) collapse fusible unary chains -> pipeline nodes
|
|
||||||
; (artdag/fusing-runner base-runner) runner that replays pipeline stages
|
|
||||||
; (artdag/optimize entries outputs fusible?) fuse then dce
|
|
||||||
;
|
|
||||||
; Federation (federation.sx):
|
|
||||||
; (artdag/fed-open) {:cache :prov}
|
|
||||||
; (artdag/fed-run fed dag runner) run against the instance cache
|
|
||||||
; (artdag/fed-export fed peer-id) bundle of {:cid :result :peer}
|
|
||||||
; (artdag/fed-import fed bundle trusted?) trust-gated import + provenance
|
|
||||||
; (artdag/fed-pull fed fetch-fn peer-id trusted?) pull via injected transport
|
|
||||||
; (artdag/fed-invalidate fed peer-id) drop a peer's results (peer-scoped)
|
|
||||||
;
|
|
||||||
; Cost / scheduling (cost.sx):
|
|
||||||
; (artdag/const-cost) (artdag/op-cost table) cost-fn (op params) -> number
|
|
||||||
; (artdag/critical-path dag cost-fn) longest weighted path
|
|
||||||
; (artdag/makespan dag plan cost-fn) estimated wall-clock under a plan
|
|
||||||
; (artdag/total-work dag cost-fn) (artdag/speedup dag plan cost-fn)
|
|
||||||
;
|
|
||||||
; Serialize (serialize.sx):
|
|
||||||
; (artdag/dag->wire dag) (artdag/wire->dag records) portable record form
|
|
||||||
; (artdag/wire-verify records) content-id integrity check
|
|
||||||
; (artdag/dag->string dag) (artdag/string->dag s) text transport
|
|
||||||
;
|
|
||||||
; Stats (stats.sx):
|
|
||||||
; (artdag/hit-ratio exec)
|
|
||||||
; (artdag/work-recomputed/work-saved exec dag cost-fn)
|
|
||||||
; (artdag/savings-ratio exec dag cost-fn) (artdag/exec-summary exec dag cost-fn)
|
|
||||||
;
|
|
||||||
; Fault tolerance (fault.sx):
|
|
||||||
; (artdag/fail reason) (artdag/failed? v)
|
|
||||||
; (artdag/run-safe dag runner cache) -> {:results :recomputed :hits :failed}
|
|
||||||
; (artdag/failed-nodes/failure-count/all-ok? exec)
|
|
||||||
|
|
||||||
(define artdag/version "1.0")
|
|
||||||
@@ -1,131 +0,0 @@
|
|||||||
#!/usr/bin/env bash
|
|
||||||
# lib/artdag/conformance.sh — run artdag test suites, emit scoreboard.json + scoreboard.md.
|
|
||||||
|
|
||||||
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=(dag analyze plan execute optimize fed cost serialize stats fault)
|
|
||||||
|
|
||||||
OUT_JSON="lib/artdag/scoreboard.json"
|
|
||||||
OUT_MD="lib/artdag/scoreboard.md"
|
|
||||||
|
|
||||||
run_suite() {
|
|
||||||
local suite=$1
|
|
||||||
local file="lib/artdag/tests/${suite}.sx"
|
|
||||||
local TMP
|
|
||||||
TMP=$(mktemp)
|
|
||||||
cat > "$TMP" << EPOCHS
|
|
||||||
(epoch 1)
|
|
||||||
(load "spec/stdlib.sx")
|
|
||||||
(load "lib/r7rs.sx")
|
|
||||||
(load "lib/datalog/tokenizer.sx")
|
|
||||||
(load "lib/datalog/parser.sx")
|
|
||||||
(load "lib/datalog/unify.sx")
|
|
||||||
(load "lib/datalog/db.sx")
|
|
||||||
(load "lib/datalog/builtins.sx")
|
|
||||||
(load "lib/datalog/aggregates.sx")
|
|
||||||
(load "lib/datalog/strata.sx")
|
|
||||||
(load "lib/datalog/eval.sx")
|
|
||||||
(load "lib/datalog/api.sx")
|
|
||||||
(load "lib/persist/event.sx")
|
|
||||||
(load "lib/persist/backend.sx")
|
|
||||||
(load "lib/persist/log.sx")
|
|
||||||
(load "lib/persist/kv.sx")
|
|
||||||
(load "lib/persist/api.sx")
|
|
||||||
(load "lib/artdag/dag.sx")
|
|
||||||
(load "lib/artdag/analyze.sx")
|
|
||||||
(load "lib/artdag/plan.sx")
|
|
||||||
(load "lib/artdag/execute.sx")
|
|
||||||
(load "lib/artdag/optimize.sx")
|
|
||||||
(load "lib/artdag/federation.sx")
|
|
||||||
(load "lib/artdag/cost.sx")
|
|
||||||
(load "lib/artdag/serialize.sx")
|
|
||||||
(load "lib/artdag/stats.sx")
|
|
||||||
(load "lib/artdag/fault.sx")
|
|
||||||
(load "lib/artdag/api.sx")
|
|
||||||
(epoch 2)
|
|
||||||
(eval "(define artdag-test-pass 0)")
|
|
||||||
(eval "(define artdag-test-fail 0)")
|
|
||||||
(eval "(define artdag-test (fn (name got expected) (if (= got expected) (set! artdag-test-pass (+ artdag-test-pass 1)) (set! artdag-test-fail (+ artdag-test-fail 1)))))")
|
|
||||||
(epoch 3)
|
|
||||||
(load "${file}")
|
|
||||||
(epoch 4)
|
|
||||||
(eval "(list artdag-test-pass artdag-test-fail)")
|
|
||||||
EPOCHS
|
|
||||||
|
|
||||||
local OUTPUT
|
|
||||||
OUTPUT=$(timeout 300 "$SX_SERVER" < "$TMP" 2>/dev/null)
|
|
||||||
rm -f "$TMP"
|
|
||||||
|
|
||||||
local LINE
|
|
||||||
LINE=$(echo "$OUTPUT" | awk '/^\(ok-len 4 / {getline; print; exit}')
|
|
||||||
if [ -z "$LINE" ]; then
|
|
||||||
LINE=$(echo "$OUTPUT" | grep -E '^\(ok 4 \([0-9]+ [0-9]+\)\)' | tail -1 \
|
|
||||||
| sed -E 's/^\(ok 4 //; s/\)$//')
|
|
||||||
fi
|
|
||||||
|
|
||||||
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 artdag 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 '# artdag Conformance Scoreboard\n\n'
|
|
||||||
printf '_Generated by `lib/artdag/conformance.sh`_\n\n'
|
|
||||||
printf '| Suite | Pass | Fail | Total |\n'
|
|
||||||
printf '|-------|-----:|-----:|------:|\n'
|
|
||||||
for s in "${SUITES[@]}"; do
|
|
||||||
p=${SUITE_PASS[$s]}
|
|
||||||
f=${SUITE_FAIL[$s]}
|
|
||||||
printf '| %s | %d | %d | %d |\n' "$s" "$p" "$f" "$((p+f))"
|
|
||||||
done
|
|
||||||
printf '| **Total** | **%d** | **%d** | **%d** |\n' "$TOTAL_PASS" "$TOTAL_FAIL" "$((TOTAL_PASS + TOTAL_FAIL))"
|
|
||||||
} > "$OUT_MD"
|
|
||||||
|
|
||||||
echo "Wrote $OUT_JSON and $OUT_MD" >&2
|
|
||||||
echo "Total: $TOTAL_PASS pass, $TOTAL_FAIL fail" >&2
|
|
||||||
|
|
||||||
[ "$TOTAL_FAIL" -eq 0 ]
|
|
||||||
@@ -1,66 +0,0 @@
|
|||||||
; lib/artdag/cost.sx — cost model for the scheduler: per-node weights, critical
|
|
||||||
; path (min makespan with unlimited parallelism), plan makespan under batching/cap,
|
|
||||||
; total serial work, and the resulting speedup. Costs come from an injected
|
|
||||||
; cost-fn (op params) -> number so media-op costs stay opaque. Depends on dag.sx.
|
|
||||||
|
|
||||||
(define artdag/const-cost (fn (op params) 1))
|
|
||||||
|
|
||||||
(define
|
|
||||||
artdag/op-cost
|
|
||||||
(fn
|
|
||||||
(table)
|
|
||||||
(fn (op params) (if (has-key? table op) (get table op) 1))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
artdag/-node-cost
|
|
||||||
(fn
|
|
||||||
(dag cost-fn id)
|
|
||||||
(let
|
|
||||||
((n (artdag/dag-get dag id)))
|
|
||||||
(cost-fn (artdag/node-op n) (artdag/node-params n)))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
artdag/-max
|
|
||||||
(fn (xs) (reduce (fn (mx x) (if (> x mx) x mx)) 0 xs)))
|
|
||||||
|
|
||||||
; longest weighted path through the dag = makespan with unlimited workers.
|
|
||||||
(define
|
|
||||||
artdag/critical-path
|
|
||||||
(fn
|
|
||||||
(dag cost-fn)
|
|
||||||
(let
|
|
||||||
((ft (reduce (fn (m id) (let ((maxdep (artdag/-max (map (fn (d) (get m d)) (artdag/node-inputs (artdag/dag-get dag id)))))) (assoc m id (+ (artdag/-node-cost dag cost-fn id) maxdep)))) {} (artdag/dag-order dag))))
|
|
||||||
(artdag/-max (map (fn (id) (get ft id)) (keys ft))))))
|
|
||||||
|
|
||||||
; estimated wall-clock for a plan: each batch runs in parallel (costs its
|
|
||||||
; slowest node), batches run in sequence.
|
|
||||||
(define
|
|
||||||
artdag/makespan
|
|
||||||
(fn
|
|
||||||
(dag plan cost-fn)
|
|
||||||
(reduce
|
|
||||||
(fn
|
|
||||||
(total batch)
|
|
||||||
(+
|
|
||||||
total
|
|
||||||
(artdag/-max
|
|
||||||
(map (fn (id) (artdag/-node-cost dag cost-fn id)) batch))))
|
|
||||||
0
|
|
||||||
plan)))
|
|
||||||
|
|
||||||
; total serial work = sum of all node costs.
|
|
||||||
(define
|
|
||||||
artdag/total-work
|
|
||||||
(fn
|
|
||||||
(dag cost-fn)
|
|
||||||
(reduce
|
|
||||||
(fn (s id) (+ s (artdag/-node-cost dag cost-fn id)))
|
|
||||||
0
|
|
||||||
(keys (artdag/dag-nodes dag)))))
|
|
||||||
|
|
||||||
; speedup of a plan vs running everything serially.
|
|
||||||
(define
|
|
||||||
artdag/speedup
|
|
||||||
(fn
|
|
||||||
(dag plan cost-fn)
|
|
||||||
(/ (artdag/total-work dag cost-fn) (artdag/makespan dag plan cost-fn))))
|
|
||||||
@@ -1,226 +0,0 @@
|
|||||||
; lib/artdag/dag.sx — DAG model + structural content addressing.
|
|
||||||
; A node = {:op :inputs :params :commutative}. inputs are content-ids of upstream
|
|
||||||
; nodes. The content-id is a deterministic structural digest so identical
|
|
||||||
; subgraphs collapse to one id (and one cache slot). No clock, no randomness.
|
|
||||||
|
|
||||||
; ---- string ordering (no host sort/string<?) ----
|
|
||||||
|
|
||||||
(define
|
|
||||||
artdag/str<?-at
|
|
||||||
(fn
|
|
||||||
(a b i la lb)
|
|
||||||
(cond
|
|
||||||
((and (>= i la) (>= i lb)) false)
|
|
||||||
((>= i la) true)
|
|
||||||
((>= i lb) false)
|
|
||||||
(else
|
|
||||||
(let
|
|
||||||
((ca (char-code (substring a i (+ i 1))))
|
|
||||||
(cb (char-code (substring b i (+ i 1)))))
|
|
||||||
(cond
|
|
||||||
((< ca cb) true)
|
|
||||||
((> ca cb) false)
|
|
||||||
(else (artdag/str<?-at a b (+ i 1) la lb))))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
artdag/str<?
|
|
||||||
(fn
|
|
||||||
(a b)
|
|
||||||
(artdag/str<?-at a b 0 (string-length a) (string-length b))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
artdag/insert-string
|
|
||||||
(fn
|
|
||||||
(sorted x)
|
|
||||||
(cond
|
|
||||||
((empty? sorted) (list x))
|
|
||||||
((artdag/str<? x (first sorted)) (cons x sorted))
|
|
||||||
(else (cons (first sorted) (artdag/insert-string (rest sorted) x))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
artdag/sort-strings
|
|
||||||
(fn (xs) (reduce (fn (acc x) (artdag/insert-string acc x)) (list) xs)))
|
|
||||||
|
|
||||||
; ---- canonical serialization ----
|
|
||||||
|
|
||||||
(define
|
|
||||||
artdag/canon-list
|
|
||||||
(fn
|
|
||||||
(xs)
|
|
||||||
(if
|
|
||||||
(empty? xs)
|
|
||||||
""
|
|
||||||
(reduce
|
|
||||||
(fn (acc x) (str acc " " (artdag/canon x)))
|
|
||||||
(artdag/canon (first xs))
|
|
||||||
(rest xs)))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
artdag/canon-dict
|
|
||||||
(fn
|
|
||||||
(d)
|
|
||||||
(str
|
|
||||||
"{"
|
|
||||||
(reduce
|
|
||||||
(fn (acc k) (str acc " " k "=" (artdag/canon (get d k))))
|
|
||||||
""
|
|
||||||
(artdag/sort-strings (keys d)))
|
|
||||||
"}")))
|
|
||||||
|
|
||||||
(define
|
|
||||||
artdag/canon
|
|
||||||
(fn
|
|
||||||
(v)
|
|
||||||
(let
|
|
||||||
((t (type-of v)))
|
|
||||||
(cond
|
|
||||||
((equal? t "nil") "nil")
|
|
||||||
((equal? t "boolean") (if v "#t" "#f"))
|
|
||||||
((equal? t "number") (number->string v))
|
|
||||||
((equal? t "string") (str "\"" v "\""))
|
|
||||||
((equal? t "keyword") (str ":" (keyword-name v)))
|
|
||||||
((equal? t "symbol") (str "'" (write-to-string v)))
|
|
||||||
((equal? t "list") (str "(" (artdag/canon-list v) ")"))
|
|
||||||
((equal? t "dict") (artdag/canon-dict v))
|
|
||||||
(else (str "<" t ">" (write-to-string v)))))))
|
|
||||||
|
|
||||||
; ---- node + content id ----
|
|
||||||
|
|
||||||
(define artdag/node (fn (op inputs params) {:inputs inputs :commutative false :op op :params params}))
|
|
||||||
|
|
||||||
(define artdag/cnode (fn (op inputs params) {:inputs inputs :commutative true :op op :params params}))
|
|
||||||
|
|
||||||
(define artdag/node-op (fn (n) (get n :op)))
|
|
||||||
(define artdag/node-inputs (fn (n) (get n :inputs)))
|
|
||||||
(define artdag/node-params (fn (n) (get n :params)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
artdag/content-id
|
|
||||||
(fn
|
|
||||||
(node)
|
|
||||||
(let
|
|
||||||
((ins (if (get node :commutative) (artdag/sort-strings (get node :inputs)) (get node :inputs))))
|
|
||||||
(str
|
|
||||||
"node:"
|
|
||||||
(artdag/canon (list (get node :op) ins (get node :params)))))))
|
|
||||||
|
|
||||||
(define artdag/id-of artdag/content-id)
|
|
||||||
|
|
||||||
; ---- list helpers ----
|
|
||||||
|
|
||||||
(define artdag/member? (fn (x xs) (some (fn (y) (equal? y x)) xs)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
artdag/all-in?
|
|
||||||
(fn (xs placed) (every? (fn (x) (artdag/member? x placed)) xs)))
|
|
||||||
|
|
||||||
; ---- build: entries -> validated, content-addressed dag ----
|
|
||||||
; entry = (local-name op (input-local-names...) params [commutative?])
|
|
||||||
|
|
||||||
(define artdag/entry-name (fn (e) (nth e 0)))
|
|
||||||
(define artdag/entry-op (fn (e) (nth e 1)))
|
|
||||||
(define artdag/entry-inputs (fn (e) (nth e 2)))
|
|
||||||
(define artdag/entry-params (fn (e) (nth e 3)))
|
|
||||||
(define
|
|
||||||
artdag/entry-commutative
|
|
||||||
(fn (e) (if (> (len e) 4) (nth e 4) false)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
artdag/entries->map
|
|
||||||
(fn
|
|
||||||
(entries)
|
|
||||||
(reduce
|
|
||||||
(fn (m e) (assoc m (artdag/entry-name e) {:inputs (artdag/entry-inputs e) :commutative (artdag/entry-commutative e) :op (artdag/entry-op e) :params (artdag/entry-params e)}))
|
|
||||||
{}
|
|
||||||
entries)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
artdag/dangling
|
|
||||||
(fn
|
|
||||||
(spec-map)
|
|
||||||
(reduce
|
|
||||||
(fn
|
|
||||||
(acc name)
|
|
||||||
(reduce
|
|
||||||
(fn (a in) (if (has-key? spec-map in) a (cons in a)))
|
|
||||||
acc
|
|
||||||
(get (get spec-map name) :inputs)))
|
|
||||||
(list)
|
|
||||||
(keys spec-map))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
artdag/ready-names
|
|
||||||
(fn
|
|
||||||
(spec-map placed)
|
|
||||||
(filter
|
|
||||||
(fn
|
|
||||||
(name)
|
|
||||||
(and
|
|
||||||
(not (artdag/member? name placed))
|
|
||||||
(artdag/all-in? (get (get spec-map name) :inputs) placed)))
|
|
||||||
(artdag/sort-strings (keys spec-map)))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
artdag/topo-loop
|
|
||||||
(fn
|
|
||||||
(spec-map placed)
|
|
||||||
(if
|
|
||||||
(= (len placed) (len (keys spec-map)))
|
|
||||||
{:order placed :ok true}
|
|
||||||
(let
|
|
||||||
((ready (artdag/ready-names spec-map placed)))
|
|
||||||
(if
|
|
||||||
(empty? ready)
|
|
||||||
{:error "cycle" :ok false}
|
|
||||||
(artdag/topo-loop spec-map (concat placed ready)))))))
|
|
||||||
|
|
||||||
(define artdag/topo (fn (spec-map) (artdag/topo-loop spec-map (list))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
artdag/resolve-ids
|
|
||||||
(fn
|
|
||||||
(spec-map order)
|
|
||||||
(reduce
|
|
||||||
(fn
|
|
||||||
(dag name)
|
|
||||||
(let
|
|
||||||
((spec (get spec-map name)))
|
|
||||||
(let
|
|
||||||
((resolved (map (fn (in) (get (get dag :names) in)) (get spec :inputs))))
|
|
||||||
(let
|
|
||||||
((node {:inputs resolved :commutative (get spec :commutative) :op (get spec :op) :params (get spec :params)}))
|
|
||||||
(let ((id (artdag/content-id node))) {:names (assoc (get dag :names) name id) :order (if (artdag/member? id (get dag :order)) (get dag :order) (concat (get dag :order) (list id))) :nodes (assoc (get dag :nodes) id node)})))))
|
|
||||||
{:names {} :order (list) :nodes {}}
|
|
||||||
order)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
artdag/build
|
|
||||||
(fn
|
|
||||||
(entries)
|
|
||||||
(let
|
|
||||||
((spec-map (artdag/entries->map entries)))
|
|
||||||
(let
|
|
||||||
((dang (artdag/dangling spec-map)))
|
|
||||||
(if
|
|
||||||
(not (empty? dang))
|
|
||||||
{:refs dang :error "dangling" :ok false}
|
|
||||||
(let
|
|
||||||
((topo (artdag/topo spec-map)))
|
|
||||||
(if
|
|
||||||
(not (get topo :ok))
|
|
||||||
{:error (get topo :error) :ok false}
|
|
||||||
(assoc
|
|
||||||
(artdag/resolve-ids spec-map (get topo :order))
|
|
||||||
:ok true))))))))
|
|
||||||
|
|
||||||
; ---- dag accessors ----
|
|
||||||
|
|
||||||
(define artdag/dag-nodes (fn (dag) (get dag :nodes)))
|
|
||||||
(define artdag/dag-names (fn (dag) (get dag :names)))
|
|
||||||
(define artdag/dag-order (fn (dag) (get dag :order)))
|
|
||||||
(define artdag/dag-id (fn (dag name) (get (get dag :names) name)))
|
|
||||||
(define artdag/dag-get (fn (dag id) (get (get dag :nodes) id)))
|
|
||||||
(define
|
|
||||||
artdag/dag-node-by-name
|
|
||||||
(fn (dag name) (artdag/dag-get dag (artdag/dag-id dag name))))
|
|
||||||
(define artdag/node-count (fn (dag) (len (keys (get dag :nodes)))))
|
|
||||||
@@ -1,82 +0,0 @@
|
|||||||
; lib/artdag/execute.sx — Phase 4: interpret a plan with a content-addressed
|
|
||||||
; memo cache. A node's result is keyed by its content-id, so a node whose id is
|
|
||||||
; already in the cache is skipped (cache hit). Because changing a leaf changes
|
|
||||||
; the content-ids of its whole dirty closure, re-running recomputes exactly those
|
|
||||||
; nodes and cache-hits the rest — incremental recompute falls out of content
|
|
||||||
; addressing. Depends on dag.sx and plan.sx; the cache is a lib/persist/ backend.
|
|
||||||
|
|
||||||
; runner: (fn (op params input-results) -> result). The injected effect interface.
|
|
||||||
; In production this performs the op (perform -> JAX/IPFS adapter); in tests it
|
|
||||||
; dispatches a pure SX op over its already-computed input results.
|
|
||||||
|
|
||||||
; build a runner from a dict of op-name -> (fn (params inputs) -> result).
|
|
||||||
(define
|
|
||||||
artdag/op-table-runner
|
|
||||||
(fn (table) (fn (op params inputs) ((get table op) params inputs))))
|
|
||||||
|
|
||||||
; resolve an input id's result: this run's results first, then the warm cache.
|
|
||||||
(define
|
|
||||||
artdag/-input-result
|
|
||||||
(fn
|
|
||||||
(results cache in)
|
|
||||||
(if (has-key? results in) (get results in) (persist/kv-get cache in))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
artdag/-exec-node
|
|
||||||
(fn
|
|
||||||
(dag runner cache acc id)
|
|
||||||
(let
|
|
||||||
((node (artdag/dag-get dag id)))
|
|
||||||
(if
|
|
||||||
(persist/kv-has? cache id)
|
|
||||||
(assoc
|
|
||||||
acc
|
|
||||||
:results (assoc (get acc :results) id (persist/kv-get cache id))
|
|
||||||
:hits (concat (get acc :hits) (list id)))
|
|
||||||
(let
|
|
||||||
((inputs (map (fn (in) (artdag/-input-result (get acc :results) cache in)) (artdag/node-inputs node))))
|
|
||||||
(let
|
|
||||||
((result (runner (artdag/node-op node) (artdag/node-params node) inputs)))
|
|
||||||
(begin
|
|
||||||
(persist/kv-put cache id result)
|
|
||||||
(assoc
|
|
||||||
acc
|
|
||||||
:results (assoc (get acc :results) id result)
|
|
||||||
:recomputed (concat (get acc :recomputed) (list id))))))))))
|
|
||||||
|
|
||||||
; execute a plan against a memo cache, returning {:results :recomputed :hits}.
|
|
||||||
(define
|
|
||||||
artdag/execute
|
|
||||||
(fn
|
|
||||||
(dag plan runner cache)
|
|
||||||
(reduce
|
|
||||||
(fn (acc id) (artdag/-exec-node dag runner cache acc id))
|
|
||||||
{:recomputed (list) :results {} :hits (list)}
|
|
||||||
(artdag/plan-flatten plan))))
|
|
||||||
|
|
||||||
; full run over every node, unlimited width.
|
|
||||||
(define
|
|
||||||
artdag/run
|
|
||||||
(fn
|
|
||||||
(dag runner cache)
|
|
||||||
(artdag/execute dag (artdag/plan dag 0) runner cache)))
|
|
||||||
|
|
||||||
; incremental run: schedule only the dirty closure of the changed nodes.
|
|
||||||
(define
|
|
||||||
artdag/run-dirty
|
|
||||||
(fn
|
|
||||||
(dag changed runner cache)
|
|
||||||
(artdag/execute
|
|
||||||
dag
|
|
||||||
(artdag/plan-dirty dag changed 0)
|
|
||||||
runner
|
|
||||||
cache)))
|
|
||||||
|
|
||||||
; ---- result inspection ----
|
|
||||||
|
|
||||||
(define artdag/result-of (fn (exec id) (get (get exec :results) id)))
|
|
||||||
(define
|
|
||||||
artdag/recomputed
|
|
||||||
(fn (exec) (artdag/sort-strings (get exec :recomputed))))
|
|
||||||
(define artdag/recompute-count (fn (exec) (len (get exec :recomputed))))
|
|
||||||
(define artdag/hit-count (fn (exec) (len (get exec :hits))))
|
|
||||||
@@ -1,56 +0,0 @@
|
|||||||
; lib/artdag/fault.sx — fault-tolerant execution. A node op may fail by returning
|
|
||||||
; (artdag/fail reason); the failure is confined to that node and its transitive
|
|
||||||
; dependents (which cannot run without it), while independent branches still
|
|
||||||
; compute. Failed results are NEVER cached, so a later run with the fault fixed
|
|
||||||
; recomputes only the failed closure. Depends on execute.sx and plan.sx.
|
|
||||||
|
|
||||||
(define artdag/fail (fn (reason) {:artdag-fail true :reason reason}))
|
|
||||||
(define artdag/failed? (fn (v) (and (dict? v) (has-key? v :artdag-fail))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
artdag/-exec-safe-node
|
|
||||||
(fn
|
|
||||||
(dag runner cache acc id)
|
|
||||||
(let
|
|
||||||
((node (artdag/dag-get dag id)))
|
|
||||||
(let
|
|
||||||
((ins (artdag/node-inputs node)))
|
|
||||||
(if
|
|
||||||
(some (fn (in) (artdag/member? in (get acc :failed))) ins)
|
|
||||||
(assoc acc :failed (concat (get acc :failed) (list id)))
|
|
||||||
(if
|
|
||||||
(persist/kv-has? cache id)
|
|
||||||
(assoc
|
|
||||||
acc
|
|
||||||
:results (assoc (get acc :results) id (persist/kv-get cache id))
|
|
||||||
:hits (concat (get acc :hits) (list id)))
|
|
||||||
(let
|
|
||||||
((inputs (map (fn (in) (artdag/-input-result (get acc :results) cache in)) ins)))
|
|
||||||
(let
|
|
||||||
((result (runner (artdag/node-op node) (artdag/node-params node) inputs)))
|
|
||||||
(if
|
|
||||||
(artdag/failed? result)
|
|
||||||
(assoc acc :failed (concat (get acc :failed) (list id)))
|
|
||||||
(begin
|
|
||||||
(persist/kv-put cache id result)
|
|
||||||
(assoc
|
|
||||||
acc
|
|
||||||
:results (assoc (get acc :results) id result)
|
|
||||||
:recomputed (concat (get acc :recomputed) (list id)))))))))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
artdag/run-safe
|
|
||||||
(fn
|
|
||||||
(dag runner cache)
|
|
||||||
(reduce
|
|
||||||
(fn (acc id) (artdag/-exec-safe-node dag runner cache acc id))
|
|
||||||
{:recomputed (list) :results {} :hits (list) :failed (list)}
|
|
||||||
(artdag/plan-flatten (artdag/plan dag 0)))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
artdag/failed-nodes
|
|
||||||
(fn (exec) (artdag/sort-strings (get exec :failed))))
|
|
||||||
(define artdag/failure-count (fn (exec) (len (get exec :failed))))
|
|
||||||
(define
|
|
||||||
artdag/all-ok?
|
|
||||||
(fn (exec) (= (len (get exec :failed)) 0)))
|
|
||||||
@@ -1,75 +0,0 @@
|
|||||||
; lib/artdag/federation.sx — Phase 6: shared content-addressed cache across
|
|
||||||
; instances (the L2-registry analog). Because content-ids are global, a result
|
|
||||||
; computed on one instance is reusable on another by id. Imports are trust-gated
|
|
||||||
; and carry provenance so a peer's results can be invalidated when trust is
|
|
||||||
; withdrawn. Transport is injected (mock in tests). Depends on dag.sx, execute.sx
|
|
||||||
; (the cache is a lib/persist/ kv backend) — federation tracks provenance beside it.
|
|
||||||
|
|
||||||
; an instance: a persist kv cache + a provenance map {cid -> origin-peer}.
|
|
||||||
(define artdag/fed-open (fn () {:cache (persist/open) :prov {}}))
|
|
||||||
(define artdag/fed-cache (fn (fed) (get fed :cache)))
|
|
||||||
(define artdag/fed-prov (fn (fed) (get fed :prov)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
artdag/-dict-remove
|
|
||||||
(fn
|
|
||||||
(d key)
|
|
||||||
(reduce
|
|
||||||
(fn (acc k) (if (= k key) acc (assoc acc k (get d k))))
|
|
||||||
{}
|
|
||||||
(keys d))))
|
|
||||||
|
|
||||||
; export every cached result as a bundle of {:cid :result :peer}, tagged with
|
|
||||||
; the exporting instance's peer id (the result's origin/provenance).
|
|
||||||
(define
|
|
||||||
artdag/fed-export
|
|
||||||
(fn
|
|
||||||
(fed peer-id)
|
|
||||||
(map (fn (cid) {:peer peer-id :cid cid :result (persist/kv-get (get fed :cache) cid)}) (persist/kv-keys (get fed :cache)))))
|
|
||||||
|
|
||||||
; import a bundle, accepting only records from trusted peers (trust gating) and
|
|
||||||
; recording each accepted result's provenance. Returns the updated instance.
|
|
||||||
(define
|
|
||||||
artdag/fed-import
|
|
||||||
(fn
|
|
||||||
(fed bundle trusted?)
|
|
||||||
(reduce
|
|
||||||
(fn
|
|
||||||
(f rec)
|
|
||||||
(if
|
|
||||||
(trusted? (get rec :peer))
|
|
||||||
(begin
|
|
||||||
(persist/kv-put (get f :cache) (get rec :cid) (get rec :result))
|
|
||||||
{:cache (get f :cache) :prov (assoc (get f :prov) (get rec :cid) (get rec :peer))})
|
|
||||||
f))
|
|
||||||
fed
|
|
||||||
bundle)))
|
|
||||||
|
|
||||||
; pull from a peer through an injected transport (fetch-fn peer-id -> bundle).
|
|
||||||
(define
|
|
||||||
artdag/fed-pull
|
|
||||||
(fn
|
|
||||||
(fed fetch-fn peer-id trusted?)
|
|
||||||
(artdag/fed-import fed (fetch-fn peer-id) trusted?)))
|
|
||||||
|
|
||||||
; invalidate: drop every cached result provenanced to a peer (trust withdrawn),
|
|
||||||
; from both the cache and the provenance map. Locally-computed results (no
|
|
||||||
; provenance) are untouched. Returns the updated instance.
|
|
||||||
(define
|
|
||||||
artdag/fed-invalidate
|
|
||||||
(fn
|
|
||||||
(fed peer-id)
|
|
||||||
(reduce
|
|
||||||
(fn
|
|
||||||
(f cid)
|
|
||||||
(if
|
|
||||||
(= (get (get f :prov) cid) peer-id)
|
|
||||||
(begin (persist/kv-delete (get f :cache) cid) {:cache (get f :cache) :prov (artdag/-dict-remove (get f :prov) cid)})
|
|
||||||
f))
|
|
||||||
fed
|
|
||||||
(keys (get fed :prov)))))
|
|
||||||
|
|
||||||
; convenience: run a dag against an instance's cache.
|
|
||||||
(define
|
|
||||||
artdag/fed-run
|
|
||||||
(fn (fed dag runner) (artdag/run dag runner (artdag/fed-cache fed))))
|
|
||||||
@@ -1,202 +0,0 @@
|
|||||||
; lib/artdag/optimize.sx — Phase 5: result-preserving DAG rewrites.
|
|
||||||
; DCE — drop nodes not reachable upstream from the requested outputs.
|
|
||||||
; CSE — free from content addressing: structurally identical subexpressions
|
|
||||||
; already collapse to one node at build time (artdag/cse == build).
|
|
||||||
; Fusion — collapse a maximal 1-to-1 chain of fusible unary ops into a single
|
|
||||||
; "artdag/pipeline" node that replays the stages; output-equivalent.
|
|
||||||
; optimize — fuse then DCE in one pass.
|
|
||||||
; Depends on dag.sx and analyze.sx.
|
|
||||||
|
|
||||||
; ---- dict helper ----
|
|
||||||
|
|
||||||
(define
|
|
||||||
artdag/-dict-filter
|
|
||||||
(fn
|
|
||||||
(d keep?)
|
|
||||||
(reduce
|
|
||||||
(fn (acc k) (if (keep? k (get d k)) (assoc acc k (get d k)) acc))
|
|
||||||
{}
|
|
||||||
(keys d))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
artdag/-union
|
|
||||||
(fn
|
|
||||||
(a b)
|
|
||||||
(reduce (fn (acc x) (if (artdag/member? x acc) acc (cons x acc))) a b)))
|
|
||||||
|
|
||||||
; ---- dead-node elimination ----
|
|
||||||
; keep only the outputs and their transitive dependencies; ids are preserved.
|
|
||||||
(define
|
|
||||||
artdag/dce
|
|
||||||
(fn
|
|
||||||
(dag outputs)
|
|
||||||
(let
|
|
||||||
((db (artdag/analyze dag)))
|
|
||||||
(let
|
|
||||||
((live (reduce (fn (acc out) (artdag/-union (artdag/-union acc (list out)) (artdag/ancestors-of db out))) (list) outputs)))
|
|
||||||
{:names (artdag/-dict-filter (artdag/dag-names dag) (fn (k v) (artdag/member? v live))) :order (filter (fn (id) (artdag/member? id live)) (artdag/dag-order dag)) :ok true :nodes (artdag/-dict-filter (artdag/dag-nodes dag) (fn (k v) (artdag/member? k live)))}))))
|
|
||||||
|
|
||||||
; ---- common-subexpression elimination ----
|
|
||||||
; structural sharing is inherent to content addressing: build already maps
|
|
||||||
; structurally identical specs to a single node/id.
|
|
||||||
(define artdag/cse artdag/build)
|
|
||||||
|
|
||||||
; ---- adjacent-op fusion (entry-level rewrite) ----
|
|
||||||
|
|
||||||
(define artdag/pipeline-op "artdag/pipeline")
|
|
||||||
|
|
||||||
(define
|
|
||||||
artdag/-name->entry
|
|
||||||
(fn
|
|
||||||
(entries)
|
|
||||||
(reduce
|
|
||||||
(fn (m e) (assoc m (artdag/entry-name e) e))
|
|
||||||
{}
|
|
||||||
entries)))
|
|
||||||
|
|
||||||
; name -> list of dependent names
|
|
||||||
(define
|
|
||||||
artdag/-deps-map
|
|
||||||
(fn
|
|
||||||
(entries)
|
|
||||||
(reduce
|
|
||||||
(fn
|
|
||||||
(m e)
|
|
||||||
(reduce
|
|
||||||
(fn
|
|
||||||
(mm i)
|
|
||||||
(assoc
|
|
||||||
mm
|
|
||||||
i
|
|
||||||
(cons
|
|
||||||
(artdag/entry-name e)
|
|
||||||
(if (has-key? mm i) (get mm i) (list)))))
|
|
||||||
m
|
|
||||||
(artdag/entry-inputs e)))
|
|
||||||
{}
|
|
||||||
entries)))
|
|
||||||
|
|
||||||
(define artdag/-stage (fn (e) {:op (artdag/entry-op e) :params (artdag/entry-params e)}))
|
|
||||||
|
|
||||||
; the single predecessor that `name` may absorb, or nil. Requires: name is a
|
|
||||||
; fusible unary op; its one input is a locally-defined fusible node whose ONLY
|
|
||||||
; dependent is name (so fusing cannot break sharing).
|
|
||||||
(define
|
|
||||||
artdag/-absorbs
|
|
||||||
(fn
|
|
||||||
(n->e deps fusible? name)
|
|
||||||
(let
|
|
||||||
((e (get n->e name)))
|
|
||||||
(let
|
|
||||||
((ins (artdag/entry-inputs e)))
|
|
||||||
(if
|
|
||||||
(= (len ins) 1)
|
|
||||||
(let
|
|
||||||
((x (first ins)))
|
|
||||||
(if
|
|
||||||
(and
|
|
||||||
(has-key? n->e x)
|
|
||||||
(fusible? (artdag/entry-op e))
|
|
||||||
(fusible? (artdag/entry-op (get n->e x)))
|
|
||||||
(= (get deps x) (list name)))
|
|
||||||
x
|
|
||||||
nil))
|
|
||||||
nil)))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
artdag/-absorbed-set
|
|
||||||
(fn
|
|
||||||
(n->e deps fusible? names)
|
|
||||||
(reduce
|
|
||||||
(fn
|
|
||||||
(acc y)
|
|
||||||
(let
|
|
||||||
((p (artdag/-absorbs n->e deps fusible? y)))
|
|
||||||
(if (nil? p) acc (cons p acc))))
|
|
||||||
(list)
|
|
||||||
names)))
|
|
||||||
|
|
||||||
; walk predecessors from a tail, building stages head->tail.
|
|
||||||
(define
|
|
||||||
artdag/-fuse-chain
|
|
||||||
(fn
|
|
||||||
(n->e deps fusible? cur stages)
|
|
||||||
(let
|
|
||||||
((p (artdag/-absorbs n->e deps fusible? cur)))
|
|
||||||
(if
|
|
||||||
(nil? p)
|
|
||||||
{:stages (cons (artdag/-stage (get n->e cur)) stages) :head cur}
|
|
||||||
(artdag/-fuse-chain
|
|
||||||
n->e
|
|
||||||
deps
|
|
||||||
fusible?
|
|
||||||
p
|
|
||||||
(cons (artdag/-stage (get n->e cur)) stages))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
artdag/fuse-entries
|
|
||||||
(fn
|
|
||||||
(entries fusible?)
|
|
||||||
(let
|
|
||||||
((n->e (artdag/-name->entry entries))
|
|
||||||
(deps (artdag/-deps-map entries))
|
|
||||||
(names (map artdag/entry-name entries)))
|
|
||||||
(let
|
|
||||||
((absorbed (artdag/-absorbed-set n->e deps fusible? names)))
|
|
||||||
(map
|
|
||||||
(fn
|
|
||||||
(name)
|
|
||||||
(let
|
|
||||||
((c (artdag/-fuse-chain n->e deps fusible? name (list))))
|
|
||||||
(if
|
|
||||||
(> (len (get c :stages)) 1)
|
|
||||||
(list
|
|
||||||
name
|
|
||||||
artdag/pipeline-op
|
|
||||||
(artdag/entry-inputs (get n->e (get c :head)))
|
|
||||||
{:stages (get c :stages)})
|
|
||||||
(get n->e name))))
|
|
||||||
(filter (fn (name) (not (artdag/member? name absorbed))) names))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
artdag/fuse
|
|
||||||
(fn
|
|
||||||
(entries fusible?)
|
|
||||||
(artdag/build (artdag/fuse-entries entries fusible?))))
|
|
||||||
|
|
||||||
; runner that replays a fused pipeline over its single input, delegating each
|
|
||||||
; stage to a base runner; non-pipeline ops fall through unchanged.
|
|
||||||
(define
|
|
||||||
artdag/pipeline-run
|
|
||||||
(fn
|
|
||||||
(base-runner)
|
|
||||||
(fn
|
|
||||||
(params inputs)
|
|
||||||
(reduce
|
|
||||||
(fn
|
|
||||||
(val stage)
|
|
||||||
(base-runner (get stage :op) (get stage :params) (list val)))
|
|
||||||
(first inputs)
|
|
||||||
(get params :stages)))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
artdag/fusing-runner
|
|
||||||
(fn
|
|
||||||
(base-runner)
|
|
||||||
(fn
|
|
||||||
(op params inputs)
|
|
||||||
(if
|
|
||||||
(= op artdag/pipeline-op)
|
|
||||||
((artdag/pipeline-run base-runner) params inputs)
|
|
||||||
(base-runner op params inputs)))))
|
|
||||||
|
|
||||||
; ---- full optimization pass ----
|
|
||||||
; fuse the entry list, then drop everything not feeding the requested output
|
|
||||||
; names. Output names survive fusion (sinks are never absorbed).
|
|
||||||
(define
|
|
||||||
artdag/optimize
|
|
||||||
(fn
|
|
||||||
(entries outputs fusible?)
|
|
||||||
(let
|
|
||||||
((fused (artdag/fuse entries fusible?)))
|
|
||||||
(artdag/dce fused (map (fn (nm) (artdag/dag-id fused nm)) outputs)))))
|
|
||||||
@@ -1,100 +0,0 @@
|
|||||||
; lib/artdag/plan.sx — Phase 3: schedule a DAG (or its dirty subset) into
|
|
||||||
; topological batches under a max-parallelism cap. A batch is a set of nodes
|
|
||||||
; whose deps are all satisfied by earlier batches, so they run in parallel.
|
|
||||||
; cap <= 0 means unlimited width. Depends on dag.sx and analyze.sx.
|
|
||||||
|
|
||||||
; inputs of id that also lie inside the scheduled set (out-of-set deps are
|
|
||||||
; treated as already satisfied — e.g. clean cache hits in an incremental plan).
|
|
||||||
(define
|
|
||||||
artdag/-deps-in
|
|
||||||
(fn
|
|
||||||
(dag id sset)
|
|
||||||
(filter
|
|
||||||
(fn (in) (artdag/member? in sset))
|
|
||||||
(artdag/node-inputs (artdag/dag-get dag id)))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
artdag/-ready-in
|
|
||||||
(fn
|
|
||||||
(dag sset placed)
|
|
||||||
(filter
|
|
||||||
(fn
|
|
||||||
(id)
|
|
||||||
(and
|
|
||||||
(not (artdag/member? id placed))
|
|
||||||
(artdag/all-in? (artdag/-deps-in dag id sset) placed)))
|
|
||||||
(artdag/sort-strings sset))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
artdag/-batch-loop
|
|
||||||
(fn
|
|
||||||
(dag sset placed batches)
|
|
||||||
(if
|
|
||||||
(= (len placed) (len sset))
|
|
||||||
batches
|
|
||||||
(let
|
|
||||||
((wave (artdag/-ready-in dag sset placed)))
|
|
||||||
(artdag/-batch-loop
|
|
||||||
dag
|
|
||||||
sset
|
|
||||||
(concat placed wave)
|
|
||||||
(concat batches (list wave)))))))
|
|
||||||
|
|
||||||
; split a wave into consecutive chunks of at most n (sorted order preserved).
|
|
||||||
(define
|
|
||||||
artdag/-chunk
|
|
||||||
(fn
|
|
||||||
(xs n)
|
|
||||||
(if
|
|
||||||
(<= (len xs) n)
|
|
||||||
(list xs)
|
|
||||||
(cons
|
|
||||||
(slice xs 0 n)
|
|
||||||
(artdag/-chunk (slice xs n (len xs)) n)))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
artdag/-cap-split
|
|
||||||
(fn
|
|
||||||
(batches cap)
|
|
||||||
(if
|
|
||||||
(<= cap 0)
|
|
||||||
batches
|
|
||||||
(reduce
|
|
||||||
(fn (acc b) (concat acc (artdag/-chunk b cap)))
|
|
||||||
(list)
|
|
||||||
batches))))
|
|
||||||
|
|
||||||
; schedule an explicit set of node-ids into capped topological batches.
|
|
||||||
(define
|
|
||||||
artdag/plan-subset
|
|
||||||
(fn
|
|
||||||
(dag node-ids cap)
|
|
||||||
(artdag/-cap-split (artdag/-batch-loop dag node-ids (list) (list)) cap)))
|
|
||||||
|
|
||||||
; full plan over every node in the dag.
|
|
||||||
(define
|
|
||||||
artdag/plan
|
|
||||||
(fn (dag cap) (artdag/plan-subset dag (keys (artdag/dag-nodes dag)) cap)))
|
|
||||||
|
|
||||||
; incremental plan: schedule only the dirty closure of the changed nodes.
|
|
||||||
(define
|
|
||||||
artdag/plan-dirty
|
|
||||||
(fn
|
|
||||||
(dag changed cap)
|
|
||||||
(artdag/plan-subset dag (artdag/dirty-closure dag changed) cap)))
|
|
||||||
|
|
||||||
; ---- plan inspection ----
|
|
||||||
|
|
||||||
(define artdag/plan-batches (fn (plan) (len plan)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
artdag/plan-width
|
|
||||||
(fn
|
|
||||||
(plan)
|
|
||||||
(reduce (fn (m b) (if (> (len b) m) (len b) m)) 0 plan)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
artdag/plan-flatten
|
|
||||||
(fn (plan) (reduce (fn (acc b) (concat acc b)) (list) plan)))
|
|
||||||
|
|
||||||
(define artdag/plan-size (fn (plan) (len (artdag/plan-flatten plan))))
|
|
||||||
@@ -1,17 +0,0 @@
|
|||||||
{
|
|
||||||
"suites": {
|
|
||||||
"dag": {"pass": 20, "fail": 0},
|
|
||||||
"analyze": {"pass": 16, "fail": 0},
|
|
||||||
"plan": {"pass": 18, "fail": 0},
|
|
||||||
"execute": {"pass": 15, "fail": 0},
|
|
||||||
"optimize": {"pass": 22, "fail": 0},
|
|
||||||
"fed": {"pass": 15, "fail": 0},
|
|
||||||
"cost": {"pass": 13, "fail": 0},
|
|
||||||
"serialize": {"pass": 13, "fail": 0},
|
|
||||||
"stats": {"pass": 12, "fail": 0},
|
|
||||||
"fault": {"pass": 14, "fail": 0}
|
|
||||||
},
|
|
||||||
"total_pass": 158,
|
|
||||||
"total_fail": 0,
|
|
||||||
"total": 158
|
|
||||||
}
|
|
||||||
@@ -1,17 +0,0 @@
|
|||||||
# artdag Conformance Scoreboard
|
|
||||||
|
|
||||||
_Generated by `lib/artdag/conformance.sh`_
|
|
||||||
|
|
||||||
| Suite | Pass | Fail | Total |
|
|
||||||
|-------|-----:|-----:|------:|
|
|
||||||
| dag | 20 | 0 | 20 |
|
|
||||||
| analyze | 16 | 0 | 16 |
|
|
||||||
| plan | 18 | 0 | 18 |
|
|
||||||
| execute | 15 | 0 | 15 |
|
|
||||||
| optimize | 22 | 0 | 22 |
|
|
||||||
| fed | 15 | 0 | 15 |
|
|
||||||
| cost | 13 | 0 | 13 |
|
|
||||||
| serialize | 13 | 0 | 13 |
|
|
||||||
| stats | 12 | 0 | 12 |
|
|
||||||
| fault | 14 | 0 | 14 |
|
|
||||||
| **Total** | **158** | **0** | **158** |
|
|
||||||
@@ -1,62 +0,0 @@
|
|||||||
; lib/artdag/serialize.sx — portable wire form for whole DAGs, so a peer can
|
|
||||||
; receive and run a graph it did not author. The form is a topo-ordered list of
|
|
||||||
; node records (id op inputs params commutative) — plain lists with keyword-keyed
|
|
||||||
; param dicts, which survive write/read (unlike string-keyed node dicts). The id
|
|
||||||
; is the content-id, so the form is self-verifying. Depends on dag.sx.
|
|
||||||
|
|
||||||
(define
|
|
||||||
artdag/node->record
|
|
||||||
(fn
|
|
||||||
(dag id)
|
|
||||||
(let
|
|
||||||
((n (artdag/dag-get dag id)))
|
|
||||||
(list
|
|
||||||
id
|
|
||||||
(artdag/node-op n)
|
|
||||||
(artdag/node-inputs n)
|
|
||||||
(artdag/node-params n)
|
|
||||||
(get n :commutative)))))
|
|
||||||
|
|
||||||
; dag -> list of records, in topological order.
|
|
||||||
(define
|
|
||||||
artdag/dag->wire
|
|
||||||
(fn
|
|
||||||
(dag)
|
|
||||||
(map (fn (id) (artdag/node->record dag id)) (artdag/dag-order dag))))
|
|
||||||
|
|
||||||
; an empty input list reads back as nil; normalize it.
|
|
||||||
(define
|
|
||||||
artdag/-rec-inputs
|
|
||||||
(fn (rec) (let ((i (nth rec 2))) (if (nil? i) (list) i))))
|
|
||||||
|
|
||||||
(define artdag/-rec->node (fn (rec) {:inputs (artdag/-rec-inputs rec) :commutative (nth rec 4) :op (nth rec 1) :params (nth rec 3)}))
|
|
||||||
|
|
||||||
; records -> dag. Local author names are not part of the wire form; the receiver
|
|
||||||
; works by content-id. :names is left empty.
|
|
||||||
(define
|
|
||||||
artdag/wire->dag
|
|
||||||
(fn
|
|
||||||
(records)
|
|
||||||
(reduce
|
|
||||||
(fn (dag rec) (let ((id (nth rec 0))) {:names (get dag :names) :order (concat (get dag :order) (list id)) :ok true :nodes (assoc (get dag :nodes) id (artdag/-rec->node rec))}))
|
|
||||||
{:names {} :order (list) :ok true :nodes {}}
|
|
||||||
records)))
|
|
||||||
|
|
||||||
; integrity: each record's id must equal the content-id recomputed from its spec.
|
|
||||||
(define
|
|
||||||
artdag/wire-verify
|
|
||||||
(fn
|
|
||||||
(records)
|
|
||||||
(every?
|
|
||||||
(fn
|
|
||||||
(rec)
|
|
||||||
(= (nth rec 0) (artdag/content-id (artdag/-rec->node rec))))
|
|
||||||
records)))
|
|
||||||
|
|
||||||
; string transport.
|
|
||||||
(define
|
|
||||||
artdag/dag->string
|
|
||||||
(fn (dag) (write-to-string (artdag/dag->wire dag))))
|
|
||||||
(define
|
|
||||||
artdag/string->dag
|
|
||||||
(fn (s) (artdag/wire->dag (read (open-input-string s)))))
|
|
||||||
@@ -1,51 +0,0 @@
|
|||||||
; lib/artdag/stats.sx — observability over an execution: cache hit ratio and the
|
|
||||||
; compute work saved by memoization (weighted by the cost model). An exec is the
|
|
||||||
; {:results :recomputed :hits} record returned by artdag/execute. Depends on
|
|
||||||
; execute.sx (exec accessors) and cost.sx (artdag/-node-cost).
|
|
||||||
|
|
||||||
(define
|
|
||||||
artdag/exec-total
|
|
||||||
(fn (exec) (+ (artdag/recompute-count exec) (artdag/hit-count exec))))
|
|
||||||
|
|
||||||
; fraction of executed nodes served from cache (0 when nothing ran).
|
|
||||||
(define
|
|
||||||
artdag/hit-ratio
|
|
||||||
(fn
|
|
||||||
(exec)
|
|
||||||
(let
|
|
||||||
((n (artdag/exec-total exec)))
|
|
||||||
(if (= n 0) 0 (/ (artdag/hit-count exec) n)))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
artdag/-sum-cost
|
|
||||||
(fn
|
|
||||||
(dag cost-fn ids)
|
|
||||||
(reduce
|
|
||||||
(fn (s id) (+ s (artdag/-node-cost dag cost-fn id)))
|
|
||||||
0
|
|
||||||
ids)))
|
|
||||||
|
|
||||||
; weighted compute work that actually ran this execution.
|
|
||||||
(define
|
|
||||||
artdag/work-recomputed
|
|
||||||
(fn
|
|
||||||
(exec dag cost-fn)
|
|
||||||
(artdag/-sum-cost dag cost-fn (get exec :recomputed))))
|
|
||||||
|
|
||||||
; weighted compute work avoided by cache hits.
|
|
||||||
(define
|
|
||||||
artdag/work-saved
|
|
||||||
(fn (exec dag cost-fn) (artdag/-sum-cost dag cost-fn (get exec :hits))))
|
|
||||||
|
|
||||||
; fraction of total weighted work that the cache saved (0 when no work at all).
|
|
||||||
(define
|
|
||||||
artdag/savings-ratio
|
|
||||||
(fn
|
|
||||||
(exec dag cost-fn)
|
|
||||||
(let
|
|
||||||
((saved (artdag/work-saved exec dag cost-fn))
|
|
||||||
(ran (artdag/work-recomputed exec dag cost-fn)))
|
|
||||||
(if (= (+ saved ran) 0) 0 (/ saved (+ saved ran))))))
|
|
||||||
|
|
||||||
; compact summary dict for logging.
|
|
||||||
(define artdag/exec-summary (fn (exec dag cost-fn) {:work-saved (artdag/work-saved exec dag cost-fn) :recomputed (artdag/recompute-count exec) :total (artdag/exec-total exec) :work-ran (artdag/work-recomputed exec dag cost-fn) :hits (artdag/hit-count exec)}))
|
|
||||||
@@ -1,119 +0,0 @@
|
|||||||
; Phase 2 — Analyze on Datalog: deps/dependents/reachability + dirty closure.
|
|
||||||
|
|
||||||
; diamond: a -> b, a -> c, (b,c) -> d
|
|
||||||
(define
|
|
||||||
an-D
|
|
||||||
(artdag/build
|
|
||||||
(list
|
|
||||||
(list "a" "load" (list) {})
|
|
||||||
(list "b" "f" (list "a") {})
|
|
||||||
(list "c" "g" (list "a") {})
|
|
||||||
(list "d" "add" (list "b" "c") {} true))))
|
|
||||||
(define an-db (artdag/analyze an-D))
|
|
||||||
(define an-a (artdag/dag-id an-D "a"))
|
|
||||||
(define an-b (artdag/dag-id an-D "b"))
|
|
||||||
(define an-c (artdag/dag-id an-D "c"))
|
|
||||||
(define an-d (artdag/dag-id an-D "d"))
|
|
||||||
|
|
||||||
; ---- direct deps / dependents ----
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"deps-of: direct inputs"
|
|
||||||
(artdag/deps-of an-db an-d)
|
|
||||||
(artdag/sort-strings (list an-b an-c)))
|
|
||||||
|
|
||||||
(artdag-test "deps-of: leaf has none" (artdag/deps-of an-db an-a) (list))
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"dependents-of: direct consumers"
|
|
||||||
(artdag/dependents-of an-db an-a)
|
|
||||||
(artdag/sort-strings (list an-b an-c)))
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"dependents-of: output has none"
|
|
||||||
(artdag/dependents-of an-db an-d)
|
|
||||||
(list))
|
|
||||||
|
|
||||||
; ---- transitive reachability ----
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"reachable-from: all downstream"
|
|
||||||
(artdag/reachable-from an-db an-a)
|
|
||||||
(artdag/sort-strings (list an-b an-c an-d)))
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"reachable-from: mid node reaches output"
|
|
||||||
(artdag/reachable-from an-db an-b)
|
|
||||||
(list an-d))
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"ancestors-of: all upstream"
|
|
||||||
(artdag/ancestors-of an-db an-d)
|
|
||||||
(artdag/sort-strings (list an-a an-b an-c)))
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"ancestors-of: leaf has none"
|
|
||||||
(artdag/ancestors-of an-db an-a)
|
|
||||||
(list))
|
|
||||||
|
|
||||||
; ---- deep chain ----
|
|
||||||
|
|
||||||
(define
|
|
||||||
ch-D
|
|
||||||
(artdag/build
|
|
||||||
(list
|
|
||||||
(list "a" "load" (list) {})
|
|
||||||
(list "b" "f" (list "a") {})
|
|
||||||
(list "c" "f" (list "b") {})
|
|
||||||
(list "d" "f" (list "c") {}))))
|
|
||||||
(define ch-db (artdag/analyze ch-D))
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"deep chain: reachable-from leaf"
|
|
||||||
(artdag/reachable-from ch-db (artdag/dag-id ch-D "a"))
|
|
||||||
(artdag/sort-strings
|
|
||||||
(list
|
|
||||||
(artdag/dag-id ch-D "b")
|
|
||||||
(artdag/dag-id ch-D "c")
|
|
||||||
(artdag/dag-id ch-D "d"))))
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"deep chain: ancestors of tip"
|
|
||||||
(artdag/ancestors-of ch-db (artdag/dag-id ch-D "d"))
|
|
||||||
(artdag/sort-strings
|
|
||||||
(list
|
|
||||||
(artdag/dag-id ch-D "a")
|
|
||||||
(artdag/dag-id ch-D "b")
|
|
||||||
(artdag/dag-id ch-D "c"))))
|
|
||||||
|
|
||||||
; ---- dirty closure ----
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"dirty closure: change leaf dirties all"
|
|
||||||
(artdag/dirty-closure an-D (list an-a))
|
|
||||||
(artdag/sort-strings (list an-a an-b an-c an-d)))
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"dirty closure: change mid touches only downstream"
|
|
||||||
(artdag/dirty-closure an-D (list an-b))
|
|
||||||
(artdag/sort-strings (list an-b an-d)))
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"dirty closure: unaffected stay clean (count)"
|
|
||||||
(len (artdag/dirty-closure an-D (list an-b)))
|
|
||||||
2)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"dirty closure: change output dirties only itself"
|
|
||||||
(artdag/dirty-closure an-D (list an-d))
|
|
||||||
(list an-d))
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"dirty closure: multiple seeds union"
|
|
||||||
(artdag/dirty-closure an-D (list an-b an-c))
|
|
||||||
(artdag/sort-strings (list an-b an-c an-d)))
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"dirty closure: empty seed set"
|
|
||||||
(artdag/dirty-closure an-D (list))
|
|
||||||
(list))
|
|
||||||
@@ -1,117 +0,0 @@
|
|||||||
; cost model: critical path, makespan under cap, total work, speedup.
|
|
||||||
|
|
||||||
(define
|
|
||||||
cost-CHAIN
|
|
||||||
(artdag/build
|
|
||||||
(list
|
|
||||||
(list "a" "in" (list) {})
|
|
||||||
(list "b" "f" (list "a") {})
|
|
||||||
(list "c" "f" (list "b") {})
|
|
||||||
(list "d" "f" (list "c") {}))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
cost-DIA
|
|
||||||
(artdag/build
|
|
||||||
(list
|
|
||||||
(list "a" "in" (list) {})
|
|
||||||
(list "b" "f" (list "a") {})
|
|
||||||
(list "c" "g" (list "a") {})
|
|
||||||
(list "d" "add" (list "b" "c") {} true))))
|
|
||||||
|
|
||||||
(define cost-W (artdag/op-cost {:f 2 :add 5}))
|
|
||||||
|
|
||||||
; ---- unit cost ----
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"critical path: chain is its length"
|
|
||||||
(artdag/critical-path cost-CHAIN artdag/const-cost)
|
|
||||||
4)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"critical path: diamond longest path"
|
|
||||||
(artdag/critical-path cost-DIA artdag/const-cost)
|
|
||||||
3)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"total work: unit cost equals node count"
|
|
||||||
(artdag/total-work cost-DIA artdag/const-cost)
|
|
||||||
4)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"single node critical path is its cost"
|
|
||||||
(artdag/critical-path
|
|
||||||
(artdag/build (list (list "a" "in" (list) {})))
|
|
||||||
artdag/const-cost)
|
|
||||||
1)
|
|
||||||
|
|
||||||
; ---- makespan vs cap ----
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"full plan makespan equals critical path"
|
|
||||||
(artdag/makespan
|
|
||||||
cost-DIA
|
|
||||||
(artdag/plan cost-DIA 0)
|
|
||||||
artdag/const-cost)
|
|
||||||
(artdag/critical-path cost-DIA artdag/const-cost))
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"serial plan makespan equals total work"
|
|
||||||
(artdag/makespan
|
|
||||||
cost-DIA
|
|
||||||
(artdag/plan cost-DIA 1)
|
|
||||||
artdag/const-cost)
|
|
||||||
(artdag/total-work cost-DIA artdag/const-cost))
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"capped makespan is never below the critical path"
|
|
||||||
(>=
|
|
||||||
(artdag/makespan
|
|
||||||
cost-DIA
|
|
||||||
(artdag/plan cost-DIA 1)
|
|
||||||
artdag/const-cost)
|
|
||||||
(artdag/critical-path cost-DIA artdag/const-cost))
|
|
||||||
true)
|
|
||||||
|
|
||||||
; ---- weighted costs ----
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"weighted critical path follows heavy ops"
|
|
||||||
(artdag/critical-path cost-DIA cost-W)
|
|
||||||
8)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"weighted total work sums all node costs"
|
|
||||||
(artdag/total-work cost-DIA cost-W)
|
|
||||||
9)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"op-cost defaults unknown ops to 1"
|
|
||||||
(artdag/total-work
|
|
||||||
(artdag/build (list (list "a" "in" (list) {})))
|
|
||||||
cost-W)
|
|
||||||
1)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"weighted full-plan makespan equals critical path"
|
|
||||||
(artdag/makespan cost-DIA (artdag/plan cost-DIA 0) cost-W)
|
|
||||||
(artdag/critical-path cost-DIA cost-W))
|
|
||||||
|
|
||||||
; ---- speedup ----
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"serial plan has no speedup"
|
|
||||||
(artdag/speedup
|
|
||||||
cost-DIA
|
|
||||||
(artdag/plan cost-DIA 1)
|
|
||||||
artdag/const-cost)
|
|
||||||
1)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"parallel plan beats serial"
|
|
||||||
(>
|
|
||||||
(artdag/speedup
|
|
||||||
cost-DIA
|
|
||||||
(artdag/plan cost-DIA 0)
|
|
||||||
artdag/const-cost)
|
|
||||||
1)
|
|
||||||
true)
|
|
||||||
@@ -1,182 +0,0 @@
|
|||||||
; Phase 1 — dag model + structural content addressing.
|
|
||||||
|
|
||||||
; ---- content-id determinism ----
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"same spec -> same id"
|
|
||||||
(equal?
|
|
||||||
(artdag/content-id (artdag/node "blur" (list "i1") {:r 3}))
|
|
||||||
(artdag/content-id (artdag/node "blur" (list "i1") {:r 3})))
|
|
||||||
true)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"op affects id"
|
|
||||||
(equal?
|
|
||||||
(artdag/content-id (artdag/node "blur" (list "i1") {}))
|
|
||||||
(artdag/content-id (artdag/node "sharpen" (list "i1") {})))
|
|
||||||
false)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"params affect id"
|
|
||||||
(equal?
|
|
||||||
(artdag/content-id (artdag/node "blur" (list "i1") {:r 3}))
|
|
||||||
(artdag/content-id (artdag/node "blur" (list "i1") {:r 5})))
|
|
||||||
false)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"inputs affect id"
|
|
||||||
(equal?
|
|
||||||
(artdag/content-id (artdag/node "add" (list "i1") {}))
|
|
||||||
(artdag/content-id (artdag/node "add" (list "i2") {})))
|
|
||||||
false)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"param key order does not affect id"
|
|
||||||
(equal?
|
|
||||||
(artdag/content-id (artdag/node "op" (list) {:a 1 :b 2}))
|
|
||||||
(artdag/content-id (artdag/node "op" (list) {:a 1 :b 2})))
|
|
||||||
true)
|
|
||||||
|
|
||||||
; ---- commutativity ----
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"commutative op: input order ignored"
|
|
||||||
(equal?
|
|
||||||
(artdag/content-id (artdag/cnode "add" (list "i1" "i2") {}))
|
|
||||||
(artdag/content-id (artdag/cnode "add" (list "i2" "i1") {})))
|
|
||||||
true)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"non-commutative op: input order matters"
|
|
||||||
(equal?
|
|
||||||
(artdag/content-id (artdag/node "sub" (list "i1" "i2") {}))
|
|
||||||
(artdag/content-id (artdag/node "sub" (list "i2" "i1") {})))
|
|
||||||
false)
|
|
||||||
|
|
||||||
; ---- build: success ----
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"build ok for valid dag"
|
|
||||||
(get
|
|
||||||
(artdag/build
|
|
||||||
(list
|
|
||||||
(list "a" "load" (list) {})
|
|
||||||
(list "b" "load" (list) {:s 1})
|
|
||||||
(list "c" "add" (list "a" "b") {})))
|
|
||||||
:ok)
|
|
||||||
true)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"node-count counts distinct nodes"
|
|
||||||
(artdag/node-count
|
|
||||||
(artdag/build
|
|
||||||
(list
|
|
||||||
(list "a" "load" (list) {})
|
|
||||||
(list "b" "load" (list) {:s 1})
|
|
||||||
(list "c" "add" (list "a" "b") {}))))
|
|
||||||
3)
|
|
||||||
|
|
||||||
; ---- subgraph sharing ----
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"identical leaves dedup to one node"
|
|
||||||
(artdag/node-count
|
|
||||||
(artdag/build
|
|
||||||
(list
|
|
||||||
(list "a" "load" (list) {:s 1})
|
|
||||||
(list "b" "load" (list) {:s 1})
|
|
||||||
(list "c" "add" (list "a" "b") {}))))
|
|
||||||
2)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"duplicate names map to same id"
|
|
||||||
(let
|
|
||||||
((d (artdag/build (list (list "a" "load" (list) {:s 1}) (list "b" "load" (list) {:s 1})))))
|
|
||||||
(equal? (artdag/dag-id d "a") (artdag/dag-id d "b")))
|
|
||||||
true)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"identical subgraph shares id across dags"
|
|
||||||
(let
|
|
||||||
((d1 (artdag/build (list (list "x" "load" (list) {:s 7}) (list "y" "neg" (list "x") {}))))
|
|
||||||
(d2
|
|
||||||
(artdag/build
|
|
||||||
(list
|
|
||||||
(list "p" "load" (list) {:s 7})
|
|
||||||
(list "q" "neg" (list "p") {})))))
|
|
||||||
(equal? (artdag/dag-id d1 "y") (artdag/dag-id d2 "q")))
|
|
||||||
true)
|
|
||||||
|
|
||||||
; ---- validation ----
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"cycle rejected"
|
|
||||||
(get
|
|
||||||
(artdag/build
|
|
||||||
(list
|
|
||||||
(list "a" "f" (list "b") {})
|
|
||||||
(list "b" "g" (list "a") {})))
|
|
||||||
:error)
|
|
||||||
"cycle")
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"self-cycle rejected"
|
|
||||||
(get (artdag/build (list (list "a" "f" (list "a") {}))) :error)
|
|
||||||
"cycle")
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"dangling input rejected"
|
|
||||||
(get
|
|
||||||
(artdag/build (list (list "a" "f" (list "ghost") {})))
|
|
||||||
:error)
|
|
||||||
"dangling")
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"dangling refs reported"
|
|
||||||
(get
|
|
||||||
(artdag/build (list (list "a" "f" (list "ghost") {})))
|
|
||||||
:refs)
|
|
||||||
(list "ghost"))
|
|
||||||
|
|
||||||
; ---- topological order ----
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"topo order: deps before dependents"
|
|
||||||
(let
|
|
||||||
((d (artdag/build (list (list "c" "add" (list "a" "b") {}) (list "a" "load" (list) {:s 1}) (list "b" "load" (list) {:s 2})))))
|
|
||||||
(artdag/dag-order d))
|
|
||||||
(let
|
|
||||||
((d (artdag/build (list (list "c" "add" (list "a" "b") {}) (list "a" "load" (list) {:s 1}) (list "b" "load" (list) {:s 2})))))
|
|
||||||
(list (artdag/dag-id d "a") (artdag/dag-id d "b") (artdag/dag-id d "c"))))
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"topo order: deep chain"
|
|
||||||
(let
|
|
||||||
((d (artdag/build (list (list "d" "f" (list "c") {}) (list "c" "f" (list "b") {}) (list "b" "f" (list "a") {}) (list "a" "load" (list) {})))))
|
|
||||||
(artdag/dag-order d))
|
|
||||||
(let
|
|
||||||
((d (artdag/build (list (list "d" "f" (list "c") {}) (list "c" "f" (list "b") {}) (list "b" "f" (list "a") {}) (list "a" "load" (list) {})))))
|
|
||||||
(list
|
|
||||||
(artdag/dag-id d "a")
|
|
||||||
(artdag/dag-id d "b")
|
|
||||||
(artdag/dag-id d "c")
|
|
||||||
(artdag/dag-id d "d"))))
|
|
||||||
|
|
||||||
; ---- accessors ----
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"dag-node-by-name returns node spec"
|
|
||||||
(artdag/node-op
|
|
||||||
(artdag/dag-node-by-name
|
|
||||||
(artdag/build (list (list "a" "load" (list) {})))
|
|
||||||
"a"))
|
|
||||||
"load")
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"resolved inputs are content-ids"
|
|
||||||
(let
|
|
||||||
((d (artdag/build (list (list "a" "load" (list) {}) (list "b" "neg" (list "a") {})))))
|
|
||||||
(artdag/node-inputs (artdag/dag-node-by-name d "b")))
|
|
||||||
(let
|
|
||||||
((d (artdag/build (list (list "a" "load" (list) {}) (list "b" "neg" (list "a") {})))))
|
|
||||||
(list (artdag/dag-id d "a"))))
|
|
||||||
@@ -1,188 +0,0 @@
|
|||||||
; Phase 4 — Execute: effect interpreter + content-addressed memo + incremental.
|
|
||||||
|
|
||||||
(define ex-RT (artdag/op-table-runner {:in (fn (params inputs) (get params :v)) :add (fn (params inputs) (+ (nth inputs 0) (nth inputs 1))) :inc (fn (params inputs) (+ 1 (first inputs)))}))
|
|
||||||
|
|
||||||
; two-leaf diamond: p,q leaves; b=inc(p); c=inc(q); d=add(b,c)
|
|
||||||
(define
|
|
||||||
ex-D1
|
|
||||||
(artdag/build
|
|
||||||
(list
|
|
||||||
(list "p" "in" (list) {:v 10})
|
|
||||||
(list "q" "in" (list) {:v 20})
|
|
||||||
(list "b" "inc" (list "p") {})
|
|
||||||
(list "c" "inc" (list "q") {})
|
|
||||||
(list "d" "add" (list "b" "c") {} true))))
|
|
||||||
|
|
||||||
; same shape, leaf q changed (20 -> 21)
|
|
||||||
(define
|
|
||||||
ex-D2
|
|
||||||
(artdag/build
|
|
||||||
(list
|
|
||||||
(list "p" "in" (list) {:v 10})
|
|
||||||
(list "q" "in" (list) {:v 21})
|
|
||||||
(list "b" "inc" (list "p") {})
|
|
||||||
(list "c" "inc" (list "q") {})
|
|
||||||
(list "d" "add" (list "b" "c") {} true))))
|
|
||||||
|
|
||||||
; a different dag that shares the p->b subgraph with ex-D1, plus z=inc(b)
|
|
||||||
(define
|
|
||||||
ex-D3
|
|
||||||
(artdag/build
|
|
||||||
(list
|
|
||||||
(list "p" "in" (list) {:v 10})
|
|
||||||
(list "b" "inc" (list "p") {})
|
|
||||||
(list "z" "inc" (list "b") {}))))
|
|
||||||
|
|
||||||
; ---- full execution ----
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"full run: result is correct"
|
|
||||||
(let
|
|
||||||
((cache (persist/open)))
|
|
||||||
(artdag/result-of
|
|
||||||
(artdag/run ex-D1 ex-RT cache)
|
|
||||||
(artdag/dag-id ex-D1 "d")))
|
|
||||||
32)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"full run: cold cache recomputes every node"
|
|
||||||
(let
|
|
||||||
((cache (persist/open)))
|
|
||||||
(artdag/recompute-count (artdag/run ex-D1 ex-RT cache)))
|
|
||||||
5)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"full run: cold cache has no hits"
|
|
||||||
(let
|
|
||||||
((cache (persist/open)))
|
|
||||||
(artdag/hit-count (artdag/run ex-D1 ex-RT cache)))
|
|
||||||
0)
|
|
||||||
|
|
||||||
; ---- memoization ----
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"re-run unchanged: zero recomputes"
|
|
||||||
(let
|
|
||||||
((cache (persist/open)))
|
|
||||||
(begin
|
|
||||||
(artdag/run ex-D1 ex-RT cache)
|
|
||||||
(artdag/recompute-count (artdag/run ex-D1 ex-RT cache))))
|
|
||||||
0)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"re-run unchanged: all cache hits"
|
|
||||||
(let
|
|
||||||
((cache (persist/open)))
|
|
||||||
(begin
|
|
||||||
(artdag/run ex-D1 ex-RT cache)
|
|
||||||
(artdag/hit-count (artdag/run ex-D1 ex-RT cache))))
|
|
||||||
5)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"re-run unchanged: result preserved"
|
|
||||||
(let
|
|
||||||
((cache (persist/open)))
|
|
||||||
(begin
|
|
||||||
(artdag/run ex-D1 ex-RT cache)
|
|
||||||
(artdag/result-of
|
|
||||||
(artdag/run ex-D1 ex-RT cache)
|
|
||||||
(artdag/dag-id ex-D1 "d"))))
|
|
||||||
32)
|
|
||||||
|
|
||||||
; ---- incremental recompute (the keystone) ----
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"leaf change recomputes only the dirty closure (count)"
|
|
||||||
(let
|
|
||||||
((cache (persist/open)))
|
|
||||||
(begin
|
|
||||||
(artdag/run ex-D1 ex-RT cache)
|
|
||||||
(artdag/recompute-count (artdag/run ex-D2 ex-RT cache))))
|
|
||||||
3)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"leaf change: unchanged nodes are cache hits"
|
|
||||||
(let
|
|
||||||
((cache (persist/open)))
|
|
||||||
(begin
|
|
||||||
(artdag/run ex-D1 ex-RT cache)
|
|
||||||
(artdag/hit-count (artdag/run ex-D2 ex-RT cache))))
|
|
||||||
2)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"leaf change: recomputed set is exactly q,c,d"
|
|
||||||
(let
|
|
||||||
((cache (persist/open)))
|
|
||||||
(begin
|
|
||||||
(artdag/run ex-D1 ex-RT cache)
|
|
||||||
(artdag/recomputed (artdag/run ex-D2 ex-RT cache))))
|
|
||||||
(artdag/sort-strings
|
|
||||||
(list
|
|
||||||
(artdag/dag-id ex-D2 "q")
|
|
||||||
(artdag/dag-id ex-D2 "c")
|
|
||||||
(artdag/dag-id ex-D2 "d"))))
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"leaf change: untouched sibling p is reused"
|
|
||||||
(let
|
|
||||||
((cache (persist/open)))
|
|
||||||
(begin
|
|
||||||
(artdag/run ex-D1 ex-RT cache)
|
|
||||||
(artdag/member?
|
|
||||||
(artdag/dag-id ex-D2 "p")
|
|
||||||
(get (artdag/run ex-D2 ex-RT cache) :hits))))
|
|
||||||
true)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"leaf change: new result is correct"
|
|
||||||
(let
|
|
||||||
((cache (persist/open)))
|
|
||||||
(begin
|
|
||||||
(artdag/run ex-D1 ex-RT cache)
|
|
||||||
(artdag/result-of
|
|
||||||
(artdag/run ex-D2 ex-RT cache)
|
|
||||||
(artdag/dag-id ex-D2 "d"))))
|
|
||||||
33)
|
|
||||||
|
|
||||||
; ---- explicit dirty-only execution ----
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"run-dirty: schedules only the changed closure"
|
|
||||||
(let
|
|
||||||
((cache (persist/open)))
|
|
||||||
(begin
|
|
||||||
(artdag/run ex-D1 ex-RT cache)
|
|
||||||
(artdag/recompute-count
|
|
||||||
(artdag/run-dirty ex-D2 (list (artdag/dag-id ex-D2 "q")) ex-RT cache))))
|
|
||||||
3)
|
|
||||||
|
|
||||||
; ---- cross-dag cache sharing (content addressing) ----
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"shared subgraph hits cache across different dags"
|
|
||||||
(let
|
|
||||||
((cache (persist/open)))
|
|
||||||
(begin
|
|
||||||
(artdag/run ex-D1 ex-RT cache)
|
|
||||||
(artdag/recompute-count (artdag/run ex-D3 ex-RT cache))))
|
|
||||||
1)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"shared subgraph: p and b reused across dags"
|
|
||||||
(let
|
|
||||||
((cache (persist/open)))
|
|
||||||
(begin
|
|
||||||
(artdag/run ex-D1 ex-RT cache)
|
|
||||||
(artdag/hit-count (artdag/run ex-D3 ex-RT cache))))
|
|
||||||
2)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"shared subgraph: z still computes correctly"
|
|
||||||
(let
|
|
||||||
((cache (persist/open)))
|
|
||||||
(begin
|
|
||||||
(artdag/run ex-D1 ex-RT cache)
|
|
||||||
(artdag/result-of
|
|
||||||
(artdag/run ex-D3 ex-RT cache)
|
|
||||||
(artdag/dag-id ex-D3 "z"))))
|
|
||||||
12)
|
|
||||||
@@ -1,144 +0,0 @@
|
|||||||
; fault-tolerant execution: failure confined to its closure, cache never poisoned.
|
|
||||||
|
|
||||||
(define ft-BAD (artdag/op-table-runner {:boom (fn (p i) (artdag/fail "kaboom")) :in (fn (p i) (get p :v)) :add (fn (p i) (+ (nth i 0) (nth i 1))) :inc (fn (p i) (+ 1 (first i)))}))
|
|
||||||
|
|
||||||
(define ft-GOOD (artdag/op-table-runner {:boom (fn (p i) 99) :in (fn (p i) (get p :v)) :add (fn (p i) (+ (nth i 0) (nth i 1))) :inc (fn (p i) (+ 1 (first i)))}))
|
|
||||||
|
|
||||||
; p,q leaves; b=inc(p) (independent); c=boom(q); d=add(b,c)
|
|
||||||
(define
|
|
||||||
ft-D
|
|
||||||
(artdag/build
|
|
||||||
(list
|
|
||||||
(list "p" "in" (list) {:v 10})
|
|
||||||
(list "q" "in" (list) {:v 20})
|
|
||||||
(list "b" "inc" (list "p") {})
|
|
||||||
(list "c" "boom" (list "q") {})
|
|
||||||
(list "d" "add" (list "b" "c") {} true))))
|
|
||||||
|
|
||||||
; ---- markers ----
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"fail constructor is detected"
|
|
||||||
(artdag/failed? (artdag/fail "x"))
|
|
||||||
true)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"plain values are not failures"
|
|
||||||
(artdag/failed? 42)
|
|
||||||
false)
|
|
||||||
|
|
||||||
; ---- failure confinement ----
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"failure count covers node and its dependents"
|
|
||||||
(let
|
|
||||||
((cache (persist/open)))
|
|
||||||
(artdag/failure-count (artdag/run-safe ft-D ft-BAD cache)))
|
|
||||||
2)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"failed set is exactly c and d"
|
|
||||||
(let
|
|
||||||
((cache (persist/open)))
|
|
||||||
(artdag/failed-nodes (artdag/run-safe ft-D ft-BAD cache)))
|
|
||||||
(artdag/sort-strings
|
|
||||||
(list (artdag/dag-id ft-D "c") (artdag/dag-id ft-D "d"))))
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"independent branch still computes"
|
|
||||||
(let
|
|
||||||
((cache (persist/open)))
|
|
||||||
(artdag/recompute-count (artdag/run-safe ft-D ft-BAD cache)))
|
|
||||||
3)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"independent node result is available"
|
|
||||||
(let
|
|
||||||
((cache (persist/open)))
|
|
||||||
(artdag/result-of
|
|
||||||
(artdag/run-safe ft-D ft-BAD cache)
|
|
||||||
(artdag/dag-id ft-D "b")))
|
|
||||||
11)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"all-ok? is false when something failed"
|
|
||||||
(let
|
|
||||||
((cache (persist/open)))
|
|
||||||
(artdag/all-ok? (artdag/run-safe ft-D ft-BAD cache)))
|
|
||||||
false)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"all-ok? is true on a clean run"
|
|
||||||
(let
|
|
||||||
((cache (persist/open)))
|
|
||||||
(artdag/all-ok? (artdag/run-safe ft-D ft-GOOD cache)))
|
|
||||||
true)
|
|
||||||
|
|
||||||
; ---- cache integrity ----
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"good node is cached"
|
|
||||||
(let
|
|
||||||
((cache (persist/open)))
|
|
||||||
(begin
|
|
||||||
(artdag/run-safe ft-D ft-BAD cache)
|
|
||||||
(persist/kv-has? cache (artdag/dag-id ft-D "b"))))
|
|
||||||
true)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"failed node is never cached"
|
|
||||||
(let
|
|
||||||
((cache (persist/open)))
|
|
||||||
(begin
|
|
||||||
(artdag/run-safe ft-D ft-BAD cache)
|
|
||||||
(persist/kv-has? cache (artdag/dag-id ft-D "c"))))
|
|
||||||
false)
|
|
||||||
|
|
||||||
; ---- retry after fix ----
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"retry recomputes only the failed closure"
|
|
||||||
(let
|
|
||||||
((cache (persist/open)))
|
|
||||||
(begin
|
|
||||||
(artdag/run-safe ft-D ft-BAD cache)
|
|
||||||
(artdag/recompute-count (artdag/run-safe ft-D ft-GOOD cache))))
|
|
||||||
2)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"retry reuses the good nodes from cache"
|
|
||||||
(let
|
|
||||||
((cache (persist/open)))
|
|
||||||
(begin
|
|
||||||
(artdag/run-safe ft-D ft-BAD cache)
|
|
||||||
(artdag/hit-count (artdag/run-safe ft-D ft-GOOD cache))))
|
|
||||||
3)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"retry produces the correct result"
|
|
||||||
(let
|
|
||||||
((cache (persist/open)))
|
|
||||||
(begin
|
|
||||||
(artdag/run-safe ft-D ft-BAD cache)
|
|
||||||
(artdag/result-of
|
|
||||||
(artdag/run-safe ft-D ft-GOOD cache)
|
|
||||||
(artdag/dag-id ft-D "d"))))
|
|
||||||
110)
|
|
||||||
|
|
||||||
; ---- transitive cascade ----
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"failure cascades through a deep chain"
|
|
||||||
(let
|
|
||||||
((cache (persist/open)))
|
|
||||||
(artdag/failure-count
|
|
||||||
(artdag/run-safe
|
|
||||||
(artdag/build
|
|
||||||
(list
|
|
||||||
(list "a" "in" (list) {:v 1})
|
|
||||||
(list "b" "boom" (list "a") {})
|
|
||||||
(list "c" "inc" (list "b") {})
|
|
||||||
(list "d" "inc" (list "c") {})))
|
|
||||||
ft-BAD
|
|
||||||
cache)))
|
|
||||||
3)
|
|
||||||
@@ -1,157 +0,0 @@
|
|||||||
; Phase 6 — federation: shared content-addressed cache, trust gating, invalidation.
|
|
||||||
|
|
||||||
(define fed-BASE (artdag/op-table-runner {:in (fn (params inputs) (get params :v)) :add (fn (params inputs) (+ (nth inputs 0) (nth inputs 1))) :inc (fn (params inputs) (+ 1 (first inputs)))}))
|
|
||||||
|
|
||||||
(define
|
|
||||||
fed-D
|
|
||||||
(artdag/build
|
|
||||||
(list
|
|
||||||
(list "p" "in" (list) {:v 10})
|
|
||||||
(list "q" "in" (list) {:v 20})
|
|
||||||
(list "b" "inc" (list "p") {})
|
|
||||||
(list "c" "inc" (list "q") {})
|
|
||||||
(list "d" "add" (list "b" "c") {} true))))
|
|
||||||
|
|
||||||
(define fed-trust-A (fn (p) (= p "A")))
|
|
||||||
(define fed-trust-none (fn (p) false))
|
|
||||||
|
|
||||||
; a warmed instance A and its export bundle (origin peer "A").
|
|
||||||
(define fed-A (artdag/fed-open))
|
|
||||||
(define fed-warm (artdag/fed-run fed-A fed-D fed-BASE))
|
|
||||||
(define fed-bundle (artdag/fed-export fed-A "A"))
|
|
||||||
|
|
||||||
; ---- export ----
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"export: bundle covers every cached node"
|
|
||||||
(len fed-bundle)
|
|
||||||
5)
|
|
||||||
|
|
||||||
; ---- remote cache hit ----
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"trusted import enables remote cache hit (no recompute)"
|
|
||||||
(artdag/recompute-count
|
|
||||||
(artdag/fed-run
|
|
||||||
(artdag/fed-import (artdag/fed-open) fed-bundle fed-trust-A)
|
|
||||||
fed-D
|
|
||||||
fed-BASE))
|
|
||||||
0)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"trusted import: every node is a hit"
|
|
||||||
(artdag/hit-count
|
|
||||||
(artdag/fed-run
|
|
||||||
(artdag/fed-import (artdag/fed-open) fed-bundle fed-trust-A)
|
|
||||||
fed-D
|
|
||||||
fed-BASE))
|
|
||||||
5)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"remote hit yields correct result"
|
|
||||||
(artdag/result-of
|
|
||||||
(artdag/fed-run
|
|
||||||
(artdag/fed-import (artdag/fed-open) fed-bundle fed-trust-A)
|
|
||||||
fed-D
|
|
||||||
fed-BASE)
|
|
||||||
(artdag/dag-id fed-D "d"))
|
|
||||||
32)
|
|
||||||
|
|
||||||
; ---- trust gating ----
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"untrusted peer is rejected (recompute everything)"
|
|
||||||
(artdag/recompute-count
|
|
||||||
(artdag/fed-run
|
|
||||||
(artdag/fed-import (artdag/fed-open) fed-bundle fed-trust-none)
|
|
||||||
fed-D
|
|
||||||
fed-BASE))
|
|
||||||
5)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"trust gating: untrusted records never enter the cache"
|
|
||||||
(let
|
|
||||||
((B (artdag/fed-import (artdag/fed-open) (cons {:peer "C" :cid "node:foreign" :result 99} fed-bundle) fed-trust-A)))
|
|
||||||
(persist/kv-has? (artdag/fed-cache B) "node:foreign"))
|
|
||||||
false)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"trust gating: trusted records still admitted alongside rejected"
|
|
||||||
(let
|
|
||||||
((B (artdag/fed-import (artdag/fed-open) (cons {:peer "C" :cid "node:foreign" :result 99} fed-bundle) fed-trust-A)))
|
|
||||||
(persist/kv-has? (artdag/fed-cache B) (artdag/dag-id fed-D "d")))
|
|
||||||
true)
|
|
||||||
|
|
||||||
; ---- provenance ----
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"provenance is recorded for imported results"
|
|
||||||
(get
|
|
||||||
(artdag/fed-prov
|
|
||||||
(artdag/fed-import (artdag/fed-open) fed-bundle fed-trust-A))
|
|
||||||
(artdag/dag-id fed-D "d"))
|
|
||||||
"A")
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"locally computed results carry no provenance"
|
|
||||||
(len (keys (artdag/fed-prov fed-A)))
|
|
||||||
0)
|
|
||||||
|
|
||||||
; ---- injected transport ----
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"fed-pull imports via an injected fetch transport"
|
|
||||||
(artdag/recompute-count
|
|
||||||
(artdag/fed-run
|
|
||||||
(artdag/fed-pull
|
|
||||||
(artdag/fed-open)
|
|
||||||
(fn (peer) fed-bundle)
|
|
||||||
"A"
|
|
||||||
fed-trust-A)
|
|
||||||
fed-D
|
|
||||||
fed-BASE))
|
|
||||||
0)
|
|
||||||
|
|
||||||
; ---- invalidation ----
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"invalidation drops a peer's results (recompute again)"
|
|
||||||
(let
|
|
||||||
((B (artdag/fed-import (artdag/fed-open) fed-bundle fed-trust-A)))
|
|
||||||
(artdag/recompute-count
|
|
||||||
(artdag/fed-run (artdag/fed-invalidate B "A") fed-D fed-BASE)))
|
|
||||||
5)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"invalidation: recomputed result still correct"
|
|
||||||
(let
|
|
||||||
((B (artdag/fed-import (artdag/fed-open) fed-bundle fed-trust-A)))
|
|
||||||
(artdag/result-of
|
|
||||||
(artdag/fed-run (artdag/fed-invalidate B "A") fed-D fed-BASE)
|
|
||||||
(artdag/dag-id fed-D "d")))
|
|
||||||
32)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"invalidation: provenance map is cleared for that peer"
|
|
||||||
(let
|
|
||||||
((B (artdag/fed-import (artdag/fed-open) fed-bundle fed-trust-A)))
|
|
||||||
(len (keys (artdag/fed-prov (artdag/fed-invalidate B "A")))))
|
|
||||||
0)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"invalidation is peer-scoped: other peers' results survive"
|
|
||||||
(let
|
|
||||||
((B (artdag/fed-import (artdag/fed-open) (cons {:peer "C" :cid "node:fromC" :result 7} fed-bundle) (fn (p) true))))
|
|
||||||
(persist/kv-has?
|
|
||||||
(artdag/fed-cache (artdag/fed-invalidate B "A"))
|
|
||||||
"node:fromC"))
|
|
||||||
true)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"invalidation is peer-scoped: target peer's results removed"
|
|
||||||
(let
|
|
||||||
((B (artdag/fed-import (artdag/fed-open) (cons {:peer "C" :cid "node:fromC" :result 7} fed-bundle) (fn (p) true))))
|
|
||||||
(persist/kv-has?
|
|
||||||
(artdag/fed-cache (artdag/fed-invalidate B "A"))
|
|
||||||
(artdag/dag-id fed-D "d")))
|
|
||||||
false)
|
|
||||||
@@ -1,215 +0,0 @@
|
|||||||
; Phase 5 — optimization: DCE, CSE (content-id sharing), adjacent-op fusion.
|
|
||||||
|
|
||||||
(define opt-BASE (artdag/op-table-runner {:in (fn (params inputs) (get params :v)) :sq (fn (params inputs) (* (first inputs) (first inputs))) :add (fn (params inputs) (+ (nth inputs 0) (nth inputs 1))) :inc (fn (params inputs) (+ 1 (first inputs)))}))
|
|
||||||
(define opt-RUN (artdag/fusing-runner opt-BASE))
|
|
||||||
(define opt-inc? (fn (op) (= op "inc")))
|
|
||||||
(define opt-incsq? (fn (op) (or (= op "inc") (= op "sq"))))
|
|
||||||
|
|
||||||
; linear chain a(in) -> b -> c -> d, all inc
|
|
||||||
(define
|
|
||||||
opt-chain
|
|
||||||
(list
|
|
||||||
(list "a" "in" (list) {:v 5})
|
|
||||||
(list "b" "inc" (list "a") {})
|
|
||||||
(list "c" "inc" (list "b") {})
|
|
||||||
(list "d" "inc" (list "c") {})))
|
|
||||||
|
|
||||||
; ---- DCE ----
|
|
||||||
|
|
||||||
(define
|
|
||||||
dce-entries
|
|
||||||
(list
|
|
||||||
(list "a" "in" (list) {:v 5})
|
|
||||||
(list "b" "inc" (list "a") {})
|
|
||||||
(list "c" "inc" (list "b") {})
|
|
||||||
(list "x" "sq" (list "a") {})))
|
|
||||||
(define dce-G (artdag/build dce-entries))
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"dce: removes dead node"
|
|
||||||
(artdag/node-count (artdag/dce dce-G (list (artdag/dag-id dce-G "c"))))
|
|
||||||
3)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"dce: keeps live closure intact"
|
|
||||||
(artdag/node-count (artdag/dce dce-G (list (artdag/dag-id dce-G "x"))))
|
|
||||||
2)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"dce: preserves surviving node ids"
|
|
||||||
(artdag/member?
|
|
||||||
(artdag/dag-id dce-G "c")
|
|
||||||
(keys
|
|
||||||
(artdag/dag-nodes (artdag/dce dce-G (list (artdag/dag-id dce-G "c"))))))
|
|
||||||
true)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"dce: output result unchanged after elimination"
|
|
||||||
(let
|
|
||||||
((cache (persist/open)))
|
|
||||||
(artdag/result-of
|
|
||||||
(artdag/run
|
|
||||||
(artdag/dce dce-G (list (artdag/dag-id dce-G "c")))
|
|
||||||
opt-RUN
|
|
||||||
cache)
|
|
||||||
(artdag/dag-id dce-G "c")))
|
|
||||||
7)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"dce: nothing dead is a no-op on count"
|
|
||||||
(artdag/node-count
|
|
||||||
(artdag/dce
|
|
||||||
dce-G
|
|
||||||
(list (artdag/dag-id dce-G "c") (artdag/dag-id dce-G "x"))))
|
|
||||||
4)
|
|
||||||
|
|
||||||
; ---- CSE (free from content addressing) ----
|
|
||||||
|
|
||||||
(define
|
|
||||||
cse-entries
|
|
||||||
(list
|
|
||||||
(list "a" "in" (list) {:v 3})
|
|
||||||
(list "s1" "sq" (list "a") {})
|
|
||||||
(list "s2" "sq" (list "a") {})
|
|
||||||
(list "d" "add" (list "s1" "s2") {} true)))
|
|
||||||
(define cse-C (artdag/cse cse-entries))
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"cse: identical subexpressions collapse to one node"
|
|
||||||
(artdag/node-count cse-C)
|
|
||||||
3)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"cse: shared node computes once"
|
|
||||||
(let
|
|
||||||
((cache (persist/open)))
|
|
||||||
(artdag/recompute-count (artdag/run cse-C opt-RUN cache)))
|
|
||||||
3)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"cse: s1 and s2 are the same id"
|
|
||||||
(equal? (artdag/dag-id cse-C "s1") (artdag/dag-id cse-C "s2"))
|
|
||||||
true)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"cse: result is correct"
|
|
||||||
(let
|
|
||||||
((cache (persist/open)))
|
|
||||||
(artdag/result-of
|
|
||||||
(artdag/run cse-C opt-RUN cache)
|
|
||||||
(artdag/dag-id cse-C "d")))
|
|
||||||
18)
|
|
||||||
|
|
||||||
; ---- fusion ----
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"fusion: collapses a unary chain"
|
|
||||||
(artdag/node-count (artdag/fuse opt-chain opt-inc?))
|
|
||||||
2)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"fusion: unfused has all nodes"
|
|
||||||
(artdag/node-count (artdag/build opt-chain))
|
|
||||||
4)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"fusion: output-equivalent to unfused"
|
|
||||||
(let
|
|
||||||
((c1 (persist/open)) (c2 (persist/open)))
|
|
||||||
(=
|
|
||||||
(artdag/result-of
|
|
||||||
(artdag/run (artdag/build opt-chain) opt-RUN c1)
|
|
||||||
(artdag/dag-id (artdag/build opt-chain) "d"))
|
|
||||||
(artdag/result-of
|
|
||||||
(artdag/run (artdag/fuse opt-chain opt-inc?) opt-RUN c2)
|
|
||||||
(artdag/dag-id (artdag/fuse opt-chain opt-inc?) "d"))))
|
|
||||||
true)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"fusion: leaf is never fused"
|
|
||||||
(artdag/node-op
|
|
||||||
(artdag/dag-node-by-name (artdag/fuse opt-chain opt-inc?) "a"))
|
|
||||||
"in")
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"fusion: tail becomes a pipeline node"
|
|
||||||
(artdag/node-op
|
|
||||||
(artdag/dag-node-by-name (artdag/fuse opt-chain opt-inc?) "d"))
|
|
||||||
"artdag/pipeline")
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"fusion: mixed fusible set fuses across op kinds"
|
|
||||||
(artdag/node-count
|
|
||||||
(artdag/fuse
|
|
||||||
(list
|
|
||||||
(list "a" "in" (list) {:v 2})
|
|
||||||
(list "b" "inc" (list "a") {})
|
|
||||||
(list "c" "sq" (list "b") {})
|
|
||||||
(list "d" "inc" (list "c") {}))
|
|
||||||
opt-incsq?))
|
|
||||||
2)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"fusion: mixed chain replays correctly"
|
|
||||||
(let
|
|
||||||
((cache (persist/open)))
|
|
||||||
(let
|
|
||||||
((f (artdag/fuse (list (list "a" "in" (list) {:v 2}) (list "b" "inc" (list "a") {}) (list "c" "sq" (list "b") {}) (list "d" "inc" (list "c") {})) opt-incsq?)))
|
|
||||||
(artdag/result-of (artdag/run f opt-RUN cache) (artdag/dag-id f "d"))))
|
|
||||||
10)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"fusion: fanout node is not fused"
|
|
||||||
(artdag/node-count
|
|
||||||
(artdag/fuse
|
|
||||||
(list
|
|
||||||
(list "a" "in" (list) {:v 1})
|
|
||||||
(list "b" "inc" (list "a") {})
|
|
||||||
(list "c" "inc" (list "b") {})
|
|
||||||
(list "e" "sq" (list "b") {}))
|
|
||||||
opt-inc?))
|
|
||||||
4)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"fusion: empty fusible set leaves dag unchanged"
|
|
||||||
(artdag/node-count (artdag/fuse opt-chain (fn (op) false)))
|
|
||||||
4)
|
|
||||||
|
|
||||||
; ---- full optimization pass (fuse + dce) ----
|
|
||||||
|
|
||||||
(define
|
|
||||||
optp-entries
|
|
||||||
(list
|
|
||||||
(list "a" "in" (list) {:v 5})
|
|
||||||
(list "b" "inc" (list "a") {})
|
|
||||||
(list "c" "inc" (list "b") {})
|
|
||||||
(list "x" "sq" (list "a") {})))
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"optimize: fuses chain and drops dead node"
|
|
||||||
(artdag/node-count (artdag/optimize optp-entries (list "c") opt-inc?))
|
|
||||||
2)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"optimize: leaves dead node when it is an output"
|
|
||||||
(artdag/node-count (artdag/optimize optp-entries (list "c" "x") opt-inc?))
|
|
||||||
3)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"optimize: result equals the unoptimized dag"
|
|
||||||
(let
|
|
||||||
((c1 (persist/open)) (c2 (persist/open)))
|
|
||||||
(let
|
|
||||||
((o (artdag/optimize optp-entries (list "c") opt-inc?)))
|
|
||||||
(=
|
|
||||||
(artdag/result-of (artdag/run o opt-RUN c1) (artdag/dag-id o "c"))
|
|
||||||
(artdag/result-of
|
|
||||||
(artdag/run (artdag/build optp-entries) opt-RUN c2)
|
|
||||||
(artdag/dag-id (artdag/build optp-entries) "c")))))
|
|
||||||
true)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"optimize: no fusible ops still drops dead nodes"
|
|
||||||
(artdag/node-count
|
|
||||||
(artdag/optimize optp-entries (list "c") (fn (op) false)))
|
|
||||||
3)
|
|
||||||
@@ -1,122 +0,0 @@
|
|||||||
; Phase 3 — Plan: topological batches under a parallelism cap, incremental plan.
|
|
||||||
|
|
||||||
; diamond: a -> b, a -> c, (b,c) -> d
|
|
||||||
(define
|
|
||||||
pl-D
|
|
||||||
(artdag/build
|
|
||||||
(list
|
|
||||||
(list "a" "load" (list) {})
|
|
||||||
(list "b" "f" (list "a") {})
|
|
||||||
(list "c" "g" (list "a") {})
|
|
||||||
(list "d" "add" (list "b" "c") {} true))))
|
|
||||||
(define pl-a (artdag/dag-id pl-D "a"))
|
|
||||||
(define pl-b (artdag/dag-id pl-D "b"))
|
|
||||||
(define pl-c (artdag/dag-id pl-D "c"))
|
|
||||||
(define pl-d (artdag/dag-id pl-D "d"))
|
|
||||||
|
|
||||||
; wide: a -> b, c, e, f (four independent dependents)
|
|
||||||
(define
|
|
||||||
pl-W
|
|
||||||
(artdag/build
|
|
||||||
(list
|
|
||||||
(list "a" "load" (list) {})
|
|
||||||
(list "b" "f" (list "a") {})
|
|
||||||
(list "c" "g" (list "a") {})
|
|
||||||
(list "e" "h" (list "a") {})
|
|
||||||
(list "f" "k" (list "a") {}))))
|
|
||||||
|
|
||||||
; ---- full plan, unlimited width ----
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"full plan: batch count"
|
|
||||||
(artdag/plan-batches (artdag/plan pl-D 0))
|
|
||||||
3)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"full plan: schedules every node"
|
|
||||||
(artdag/plan-size (artdag/plan pl-D 0))
|
|
||||||
4)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"full plan: first batch is the leaf"
|
|
||||||
(first (artdag/plan pl-D 0))
|
|
||||||
(list pl-a))
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"full plan: middle batch runs b,c in parallel"
|
|
||||||
(first (rest (artdag/plan pl-D 0)))
|
|
||||||
(artdag/sort-strings (list pl-b pl-c)))
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"full plan: last batch is the sink"
|
|
||||||
(first (rest (rest (artdag/plan pl-D 0))))
|
|
||||||
(list pl-d))
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"full plan: max width is 2"
|
|
||||||
(artdag/plan-width (artdag/plan pl-D 0))
|
|
||||||
2)
|
|
||||||
|
|
||||||
; ---- parallelism cap ----
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"cap 1: width never exceeds 1"
|
|
||||||
(artdag/plan-width (artdag/plan pl-D 1))
|
|
||||||
1)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"cap 1: serializes into one node per batch"
|
|
||||||
(artdag/plan-batches (artdag/plan pl-D 1))
|
|
||||||
4)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"cap larger than widest wave is a no-op"
|
|
||||||
(artdag/plan pl-D 10)
|
|
||||||
(artdag/plan pl-D 0))
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"wide cap 2: width capped at 2"
|
|
||||||
(artdag/plan-width (artdag/plan pl-W 2))
|
|
||||||
2)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"wide cap 2: leaf wave then two capped sub-batches"
|
|
||||||
(artdag/plan-batches (artdag/plan pl-W 2))
|
|
||||||
3)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"wide cap 2: still schedules all five nodes"
|
|
||||||
(artdag/plan-size (artdag/plan pl-W 2))
|
|
||||||
5)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"wide unlimited: single wave of four after leaf"
|
|
||||||
(artdag/plan-width (artdag/plan pl-W 0))
|
|
||||||
4)
|
|
||||||
|
|
||||||
; ---- incremental (dirty-only) plan ----
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"dirty plan: schedules only the dirty closure"
|
|
||||||
(artdag/plan-size (artdag/plan-dirty pl-D (list pl-b) 0))
|
|
||||||
2)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"dirty plan: b then d"
|
|
||||||
(artdag/plan-dirty pl-D (list pl-b) 0)
|
|
||||||
(list (list pl-b) (list pl-d)))
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"dirty plan: clean deps treated as satisfied"
|
|
||||||
(first (artdag/plan-dirty pl-D (list pl-b) 0))
|
|
||||||
(list pl-b))
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"dirty plan: leaf change replans whole graph"
|
|
||||||
(artdag/plan-size (artdag/plan-dirty pl-D (list pl-a) 0))
|
|
||||||
4)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"dirty plan: sink change is a single batch"
|
|
||||||
(artdag/plan-dirty pl-D (list pl-d) 0)
|
|
||||||
(list (list pl-d)))
|
|
||||||
@@ -1,115 +0,0 @@
|
|||||||
; portable wire form: dag <-> records <-> string, with content-id integrity.
|
|
||||||
|
|
||||||
(define ser-RT (artdag/op-table-runner {:in (fn (p i) (get p :v)) :add (fn (p i) (+ (nth i 0) (nth i 1))) :inc (fn (p i) (+ 1 (first i)))}))
|
|
||||||
|
|
||||||
(define
|
|
||||||
ser-D
|
|
||||||
(artdag/build
|
|
||||||
(list
|
|
||||||
(list "a" "in" (list) {:v 10})
|
|
||||||
(list "b" "inc" (list "a") {})
|
|
||||||
(list "c" "add" (list "a" "b") {} true))))
|
|
||||||
|
|
||||||
(define ser-cid (artdag/dag-id ser-D "c"))
|
|
||||||
|
|
||||||
; ---- wire form ----
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"wire has one record per node"
|
|
||||||
(len (artdag/dag->wire ser-D))
|
|
||||||
3)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"wire records follow topological order"
|
|
||||||
(map (fn (rec) (nth rec 0)) (artdag/dag->wire ser-D))
|
|
||||||
(artdag/dag-order ser-D))
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"wire record carries the content-id"
|
|
||||||
(nth (nth (artdag/dag->wire ser-D) 0) 0)
|
|
||||||
(artdag/dag-id ser-D "a"))
|
|
||||||
|
|
||||||
; ---- reconstruction ----
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"wire->dag restores node count"
|
|
||||||
(artdag/node-count (artdag/wire->dag (artdag/dag->wire ser-D)))
|
|
||||||
3)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"wire->dag restores order"
|
|
||||||
(artdag/dag-order (artdag/wire->dag (artdag/dag->wire ser-D)))
|
|
||||||
(artdag/dag-order ser-D))
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"reconstructed leaf inputs normalize to empty list"
|
|
||||||
(artdag/node-inputs
|
|
||||||
(artdag/dag-get
|
|
||||||
(artdag/wire->dag (artdag/dag->wire ser-D))
|
|
||||||
(artdag/dag-id ser-D "a")))
|
|
||||||
(list))
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"reconstructed node preserves inputs"
|
|
||||||
(artdag/node-inputs
|
|
||||||
(artdag/dag-get (artdag/wire->dag (artdag/dag->wire ser-D)) ser-cid))
|
|
||||||
(artdag/node-inputs (artdag/dag-get ser-D ser-cid)))
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"reconstructed node id matches recomputed content-id"
|
|
||||||
(artdag/content-id
|
|
||||||
(artdag/dag-get (artdag/wire->dag (artdag/dag->wire ser-D)) ser-cid))
|
|
||||||
ser-cid)
|
|
||||||
|
|
||||||
; ---- execution equivalence ----
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"reconstructed dag executes to same result"
|
|
||||||
(let
|
|
||||||
((c1 (persist/open)) (c2 (persist/open)))
|
|
||||||
(=
|
|
||||||
(artdag/result-of (artdag/run ser-D ser-RT c1) ser-cid)
|
|
||||||
(artdag/result-of
|
|
||||||
(artdag/run (artdag/wire->dag (artdag/dag->wire ser-D)) ser-RT c2)
|
|
||||||
ser-cid)))
|
|
||||||
true)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"string round-trip executes to same result"
|
|
||||||
(let
|
|
||||||
((cache (persist/open)))
|
|
||||||
(artdag/result-of
|
|
||||||
(artdag/run
|
|
||||||
(artdag/string->dag (artdag/dag->string ser-D))
|
|
||||||
ser-RT
|
|
||||||
cache)
|
|
||||||
ser-cid))
|
|
||||||
21)
|
|
||||||
|
|
||||||
; ---- integrity ----
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"wire-verify accepts a genuine wire form"
|
|
||||||
(artdag/wire-verify (artdag/dag->wire ser-D))
|
|
||||||
true)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"wire-verify rejects a tampered id"
|
|
||||||
(artdag/wire-verify
|
|
||||||
(list (list "node:bogus" "in" (list) {:v 1} false)))
|
|
||||||
false)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"wire-verify rejects mutated params under a stale id"
|
|
||||||
(artdag/wire-verify
|
|
||||||
(map
|
|
||||||
(fn
|
|
||||||
(rec)
|
|
||||||
(list
|
|
||||||
(nth rec 0)
|
|
||||||
(nth rec 1)
|
|
||||||
(nth rec 2)
|
|
||||||
{:v 999}
|
|
||||||
(nth rec 4)))
|
|
||||||
(artdag/dag->wire ser-D)))
|
|
||||||
false)
|
|
||||||
@@ -1,150 +0,0 @@
|
|||||||
; execution stats: hit ratio + memoized work saved (cost-weighted).
|
|
||||||
|
|
||||||
(define st-RT (artdag/op-table-runner {:in (fn (p i) (get p :v)) :add (fn (p i) (+ (nth i 0) (nth i 1))) :inc (fn (p i) (+ 1 (first i)))}))
|
|
||||||
|
|
||||||
(define
|
|
||||||
st-D
|
|
||||||
(artdag/build
|
|
||||||
(list
|
|
||||||
(list "p" "in" (list) {:v 10})
|
|
||||||
(list "q" "in" (list) {:v 20})
|
|
||||||
(list "b" "inc" (list "p") {})
|
|
||||||
(list "c" "inc" (list "q") {})
|
|
||||||
(list "d" "add" (list "b" "c") {} true))))
|
|
||||||
|
|
||||||
; same shape, leaf q changed -> dirty closure {q,c,d}
|
|
||||||
(define
|
|
||||||
st-D2
|
|
||||||
(artdag/build
|
|
||||||
(list
|
|
||||||
(list "p" "in" (list) {:v 10})
|
|
||||||
(list "q" "in" (list) {:v 21})
|
|
||||||
(list "b" "inc" (list "p") {})
|
|
||||||
(list "c" "inc" (list "q") {})
|
|
||||||
(list "d" "add" (list "b" "c") {} true))))
|
|
||||||
|
|
||||||
(define st-W (artdag/op-cost {:add 5 :inc 2}))
|
|
||||||
|
|
||||||
; ---- cold run ----
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"cold run: hit ratio is zero"
|
|
||||||
(let
|
|
||||||
((cache (persist/open)))
|
|
||||||
(artdag/hit-ratio (artdag/run st-D st-RT cache)))
|
|
||||||
0)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"cold run: nothing saved"
|
|
||||||
(let
|
|
||||||
((cache (persist/open)))
|
|
||||||
(artdag/work-saved (artdag/run st-D st-RT cache) st-D artdag/const-cost))
|
|
||||||
0)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"cold run: all work runs"
|
|
||||||
(let
|
|
||||||
((cache (persist/open)))
|
|
||||||
(artdag/work-recomputed
|
|
||||||
(artdag/run st-D st-RT cache)
|
|
||||||
st-D
|
|
||||||
artdag/const-cost))
|
|
||||||
5)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"cold run: weighted work ran"
|
|
||||||
(let
|
|
||||||
((cache (persist/open)))
|
|
||||||
(artdag/work-recomputed (artdag/run st-D st-RT cache) st-D st-W))
|
|
||||||
11)
|
|
||||||
|
|
||||||
; ---- warm rerun ----
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"warm rerun: hit ratio is one"
|
|
||||||
(let
|
|
||||||
((cache (persist/open)))
|
|
||||||
(begin
|
|
||||||
(artdag/run st-D st-RT cache)
|
|
||||||
(artdag/hit-ratio (artdag/run st-D st-RT cache))))
|
|
||||||
1)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"warm rerun: savings ratio is one"
|
|
||||||
(let
|
|
||||||
((cache (persist/open)))
|
|
||||||
(begin
|
|
||||||
(artdag/run st-D st-RT cache)
|
|
||||||
(artdag/savings-ratio
|
|
||||||
(artdag/run st-D st-RT cache)
|
|
||||||
st-D
|
|
||||||
artdag/const-cost)))
|
|
||||||
1)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"warm rerun: all weighted work saved"
|
|
||||||
(let
|
|
||||||
((cache (persist/open)))
|
|
||||||
(begin
|
|
||||||
(artdag/run st-D st-RT cache)
|
|
||||||
(artdag/work-saved (artdag/run st-D st-RT cache) st-D st-W)))
|
|
||||||
11)
|
|
||||||
|
|
||||||
; ---- partial (incremental) ----
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"incremental: total is every node"
|
|
||||||
(let
|
|
||||||
((cache (persist/open)))
|
|
||||||
(begin
|
|
||||||
(artdag/run st-D st-RT cache)
|
|
||||||
(artdag/exec-total (artdag/run st-D2 st-RT cache))))
|
|
||||||
5)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"incremental: saved work counts unchanged nodes"
|
|
||||||
(let
|
|
||||||
((cache (persist/open)))
|
|
||||||
(begin
|
|
||||||
(artdag/run st-D st-RT cache)
|
|
||||||
(artdag/work-saved
|
|
||||||
(artdag/run st-D2 st-RT cache)
|
|
||||||
st-D2
|
|
||||||
artdag/const-cost)))
|
|
||||||
2)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"incremental: ran work counts dirty closure"
|
|
||||||
(let
|
|
||||||
((cache (persist/open)))
|
|
||||||
(begin
|
|
||||||
(artdag/run st-D st-RT cache)
|
|
||||||
(artdag/work-recomputed
|
|
||||||
(artdag/run st-D2 st-RT cache)
|
|
||||||
st-D2
|
|
||||||
artdag/const-cost)))
|
|
||||||
3)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"summary reports recompute count"
|
|
||||||
(let
|
|
||||||
((cache (persist/open)))
|
|
||||||
(get
|
|
||||||
(artdag/exec-summary
|
|
||||||
(artdag/run st-D st-RT cache)
|
|
||||||
st-D
|
|
||||||
artdag/const-cost)
|
|
||||||
:recomputed))
|
|
||||||
5)
|
|
||||||
|
|
||||||
(artdag-test
|
|
||||||
"summary reports total"
|
|
||||||
(let
|
|
||||||
((cache (persist/open)))
|
|
||||||
(get
|
|
||||||
(artdag/exec-summary
|
|
||||||
(artdag/run st-D st-RT cache)
|
|
||||||
st-D
|
|
||||||
artdag/const-cost)
|
|
||||||
:total))
|
|
||||||
5)
|
|
||||||
@@ -1,56 +0,0 @@
|
|||||||
;; lib/commerce/api.sx — public commerce surface.
|
|
||||||
;;
|
|
||||||
;; A session bundles a pricing context with a cart: {:ctx CTX :cart CART}.
|
|
||||||
;; All operations are pure and return a new session. The total and the
|
|
||||||
;; per-line breakdown are deterministic functions of (ctx, cart).
|
|
||||||
;;
|
|
||||||
;; commerce-checkout is a Phase-3 stub — the order lifecycle is a durable
|
|
||||||
;; flow that suspends at the SumUp payment boundary.
|
|
||||||
|
|
||||||
(define commerce-session (fn (ctx) {:cart empty-cart :ctx ctx}))
|
|
||||||
|
|
||||||
(define commerce-ctx (fn (sess) (get sess :ctx)))
|
|
||||||
(define commerce-cart (fn (sess) (get sess :cart)))
|
|
||||||
(define commerce-lines (fn (sess) (cart-lines (get sess :cart))))
|
|
||||||
(define commerce-count (fn (sess) (cart-count (get sess :cart))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
commerce-add
|
|
||||||
(fn
|
|
||||||
(sess sku variant qty)
|
|
||||||
(assoc sess :cart (cart-add (get sess :cart) sku variant qty))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
commerce-remove
|
|
||||||
(fn
|
|
||||||
(sess sku variant)
|
|
||||||
(assoc sess :cart (cart-remove (get sess :cart) sku variant))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
commerce-set-qty
|
|
||||||
(fn
|
|
||||||
(sess sku variant qty)
|
|
||||||
(assoc sess :cart (cart-set-qty (get sess :cart) sku variant qty))))
|
|
||||||
|
|
||||||
;; True when the sku exists in the session's catalog snapshot.
|
|
||||||
(define
|
|
||||||
commerce-can-add?
|
|
||||||
(fn (sess sku) (catalog-has? (ctx-catalog (get sess :ctx)) sku)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
commerce-total
|
|
||||||
(fn (sess) (cart-total (get sess :ctx) (get sess :cart))))
|
|
||||||
|
|
||||||
;; Per-line audit breakdown — the "which line contributed what" view.
|
|
||||||
(define
|
|
||||||
line-detail
|
|
||||||
(fn (ctx line) (let ((cat (ctx-catalog ctx))) {:sku (line-sku line) :unit (line-unit-price cat (line-sku line) (line-variant line)) :qty (line-qty line) :variant (line-variant line) :extended (line-extended cat line) :tax (line-tax ctx line)})))
|
|
||||||
|
|
||||||
(define
|
|
||||||
commerce-explain
|
|
||||||
(fn
|
|
||||||
(sess)
|
|
||||||
(map (fn (l) (line-detail (get sess :ctx) l)) (get sess :cart))))
|
|
||||||
|
|
||||||
;; Phase 3 — order lifecycle flow (reserve -> pay -> fulfil) lands here.
|
|
||||||
(define commerce-checkout (fn (sess) {:note "order lifecycle flow lands in Phase 3" :phase 3 :status :not-implemented}))
|
|
||||||
@@ -1,100 +0,0 @@
|
|||||||
;; lib/commerce/attribution.sx — line-level discount attribution.
|
|
||||||
;;
|
|
||||||
;; The briefing's marquee backward query: "which line item triggered this
|
|
||||||
;; discount?". promo.sx computes discount amounts at the class/order level;
|
|
||||||
;; this layer answers the *scope* question relationally and in both directions:
|
|
||||||
;; forward — which lines does code C touch? (lines-for-code)
|
|
||||||
;; backward — which codes touch this line? (codes-for-line)
|
|
||||||
;; Both are the same relation promo-toucheso run with different vars bound.
|
|
||||||
;;
|
|
||||||
;; A :fixed promo is order-level (touches no single line); query those with
|
|
||||||
;; order-level-codes. Only promos that actually apply (amount > 0) touch lines.
|
|
||||||
|
|
||||||
;; Lines whose sku is in product-class `cls`.
|
|
||||||
(define
|
|
||||||
class-lines
|
|
||||||
(fn
|
|
||||||
(ctx cart cls)
|
|
||||||
(filter
|
|
||||||
(fn (l) (= (catalog-class (ctx-catalog ctx) (line-sku l)) cls))
|
|
||||||
cart)))
|
|
||||||
|
|
||||||
;; The lines a promo applies to (its scope). :fixed is order-level → no lines.
|
|
||||||
(define
|
|
||||||
promo-lines
|
|
||||||
(fn
|
|
||||||
(ctx cart p)
|
|
||||||
(let
|
|
||||||
((k (promo-kind p)))
|
|
||||||
(cond
|
|
||||||
((= k :percent) (class-lines ctx cart (nth p 2)))
|
|
||||||
((= k :member)
|
|
||||||
(if
|
|
||||||
(= (get ctx :customer) :member)
|
|
||||||
(class-lines ctx cart (nth p 2))
|
|
||||||
(list)))
|
|
||||||
((= k :bundle)
|
|
||||||
(filter (fn (l) (= (line-sku l) (nth p 2))) cart))
|
|
||||||
(:else (list))))))
|
|
||||||
|
|
||||||
;; Relation: promo `code` touches `line`. Only applying promos (amount > 0)
|
|
||||||
;; touch anything, so an inapplicable promo contributes no pairs.
|
|
||||||
(define
|
|
||||||
promo-toucheso
|
|
||||||
(fn
|
|
||||||
(ctx cart ruleset code line)
|
|
||||||
(fresh
|
|
||||||
(p)
|
|
||||||
(membero p ruleset)
|
|
||||||
(project
|
|
||||||
(p)
|
|
||||||
(if
|
|
||||||
(> (promo-amount ctx cart p) 0)
|
|
||||||
(mk-conj
|
|
||||||
(== code (promo-code p))
|
|
||||||
(membero line (promo-lines ctx cart p)))
|
|
||||||
fail)))))
|
|
||||||
|
|
||||||
;; --- query helpers ---
|
|
||||||
|
|
||||||
(define
|
|
||||||
lines-for-code
|
|
||||||
(fn
|
|
||||||
(ctx cart ruleset code)
|
|
||||||
(run* line (promo-toucheso ctx cart ruleset code line))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
codes-for-line
|
|
||||||
(fn
|
|
||||||
(ctx cart ruleset line)
|
|
||||||
(run* code (promo-toucheso ctx cart ruleset code line))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
line-touched-by?
|
|
||||||
(fn
|
|
||||||
(ctx cart ruleset code line)
|
|
||||||
(not
|
|
||||||
(empty?
|
|
||||||
(run
|
|
||||||
1
|
|
||||||
c
|
|
||||||
(mk-conj (promo-toucheso ctx cart ruleset code line) (== c true)))))))
|
|
||||||
|
|
||||||
;; Applying order-level (:fixed) promos — discounts with no single line.
|
|
||||||
(define
|
|
||||||
order-level-codes
|
|
||||||
(fn
|
|
||||||
(ctx cart ruleset)
|
|
||||||
(run*
|
|
||||||
code
|
|
||||||
(fresh
|
|
||||||
(p)
|
|
||||||
(membero p ruleset)
|
|
||||||
(project
|
|
||||||
(p)
|
|
||||||
(if
|
|
||||||
(and
|
|
||||||
(> (promo-amount ctx cart p) 0)
|
|
||||||
(= (promo-kind p) :fixed))
|
|
||||||
(== code (promo-code p))
|
|
||||||
fail))))))
|
|
||||||
@@ -1,86 +0,0 @@
|
|||||||
;; lib/commerce/cart.sx — cart as an ordered list of line items.
|
|
||||||
;;
|
|
||||||
;; A cart is a native list of lines; a line is (list sku variant qty).
|
|
||||||
;; All operations are pure: they return a new cart, never mutate. Line
|
|
||||||
;; order is insertion order (stable) so totals are reproducible.
|
|
||||||
;;
|
|
||||||
;; cart-lineo is the relational view — because a line *is* a (sku variant qty)
|
|
||||||
;; tuple, membero queries the cart directly, forward or backward.
|
|
||||||
|
|
||||||
(define empty-cart (list))
|
|
||||||
|
|
||||||
(define make-line (fn (sku variant qty) (list sku variant qty)))
|
|
||||||
(define line-sku (fn (l) (nth l 0)))
|
|
||||||
(define line-variant (fn (l) (nth l 1)))
|
|
||||||
(define line-qty (fn (l) (nth l 2)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
same-line?
|
|
||||||
(fn
|
|
||||||
(l sku variant)
|
|
||||||
(and (= (line-sku l) sku) (= (line-variant l) variant))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
cart-qty
|
|
||||||
(fn
|
|
||||||
(cart sku variant)
|
|
||||||
(let
|
|
||||||
((m (filter (fn (l) (same-line? l sku variant)) cart)))
|
|
||||||
(if (empty? m) 0 (line-qty (first m))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
cart-remove
|
|
||||||
(fn
|
|
||||||
(cart sku variant)
|
|
||||||
(filter (fn (l) (not (same-line? l sku variant))) cart)))
|
|
||||||
|
|
||||||
;; Add qty units; merges into an existing (sku,variant) line in place,
|
|
||||||
;; otherwise appends a new line at the end.
|
|
||||||
(define
|
|
||||||
cart-add
|
|
||||||
(fn
|
|
||||||
(cart sku variant qty)
|
|
||||||
(let
|
|
||||||
((existing (cart-qty cart sku variant)))
|
|
||||||
(if
|
|
||||||
(= existing 0)
|
|
||||||
(append cart (list (make-line sku variant qty)))
|
|
||||||
(map
|
|
||||||
(fn
|
|
||||||
(l)
|
|
||||||
(if
|
|
||||||
(same-line? l sku variant)
|
|
||||||
(make-line sku variant (+ existing qty))
|
|
||||||
l))
|
|
||||||
cart)))))
|
|
||||||
|
|
||||||
;; Set the absolute quantity; qty <= 0 removes the line.
|
|
||||||
(define
|
|
||||||
cart-set-qty
|
|
||||||
(fn
|
|
||||||
(cart sku variant qty)
|
|
||||||
(if
|
|
||||||
(<= qty 0)
|
|
||||||
(cart-remove cart sku variant)
|
|
||||||
(if
|
|
||||||
(= (cart-qty cart sku variant) 0)
|
|
||||||
(append cart (list (make-line sku variant qty)))
|
|
||||||
(map
|
|
||||||
(fn
|
|
||||||
(l)
|
|
||||||
(if (same-line? l sku variant) (make-line sku variant qty) l))
|
|
||||||
cart)))))
|
|
||||||
|
|
||||||
(define cart-empty? (fn (cart) (empty? cart)))
|
|
||||||
(define cart-lines (fn (cart) cart))
|
|
||||||
(define cart-skus (fn (cart) (map line-sku cart)))
|
|
||||||
|
|
||||||
;; Total number of units across all lines.
|
|
||||||
(define
|
|
||||||
cart-count
|
|
||||||
(fn (cart) (reduce (fn (acc l) (+ acc (line-qty l))) 0 cart)))
|
|
||||||
|
|
||||||
;; Relational view of cart lines.
|
|
||||||
(define
|
|
||||||
cart-lineo
|
|
||||||
(fn (cart sku variant qty) (membero (list sku variant qty) cart)))
|
|
||||||
@@ -1,83 +0,0 @@
|
|||||||
;; lib/commerce/catalog.sx — catalog snapshot + relational accessors.
|
|
||||||
;;
|
|
||||||
;; A catalog snapshot is an immutable dict:
|
|
||||||
;; {:products (list (list sku price class) ...)
|
|
||||||
;; :variants (list (list sku variant delta) ...)
|
|
||||||
;; :stock (list (list sku variant qty) ...)}
|
|
||||||
;;
|
|
||||||
;; Money is integer minor units (pence/cents). class is a keyword product
|
|
||||||
;; class consumed later by tax and promotion relations. delta is a signed
|
|
||||||
;; price adjustment for a variant; qty is on-hand stock for (sku,variant).
|
|
||||||
;;
|
|
||||||
;; Accessor relations take the snapshot as the first argument and are fully
|
|
||||||
;; multidirectional: (producto cat "widget" p c) binds p,c forward;
|
|
||||||
;; (producto cat s 1000 c) enumerates every sku priced 1000 backward.
|
|
||||||
|
|
||||||
(define empty-catalog {:products (list) :stock (list) :variants (list)})
|
|
||||||
|
|
||||||
(define make-catalog (fn (products variants stock) {:products products :stock stock :variants variants}))
|
|
||||||
|
|
||||||
(define cat-products (fn (cat) (get cat :products)))
|
|
||||||
(define cat-variants (fn (cat) (get cat :variants)))
|
|
||||||
(define cat-stock (fn (cat) (get cat :stock)))
|
|
||||||
|
|
||||||
;; --- core fact relations ---
|
|
||||||
|
|
||||||
(define
|
|
||||||
producto
|
|
||||||
(fn
|
|
||||||
(cat sku price class)
|
|
||||||
(membero (list sku price class) (get cat :products))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
varianto
|
|
||||||
(fn
|
|
||||||
(cat sku variant delta)
|
|
||||||
(membero (list sku variant delta) (get cat :variants))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
stocko
|
|
||||||
(fn
|
|
||||||
(cat sku variant qty)
|
|
||||||
(membero (list sku variant qty) (get cat :stock))))
|
|
||||||
|
|
||||||
;; --- derived relations ---
|
|
||||||
|
|
||||||
(define
|
|
||||||
priceo
|
|
||||||
(fn (cat sku price) (fresh (c) (producto cat sku price c))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
classo
|
|
||||||
(fn (cat sku class) (fresh (p) (producto cat sku p class))))
|
|
||||||
|
|
||||||
;; Effective unit price of a (sku,variant): base + variant delta.
|
|
||||||
(define
|
|
||||||
unit-priceo
|
|
||||||
(fn
|
|
||||||
(cat sku variant price)
|
|
||||||
(fresh
|
|
||||||
(base delta)
|
|
||||||
(priceo cat sku base)
|
|
||||||
(varianto cat sku variant delta)
|
|
||||||
(pluso-i base delta price))))
|
|
||||||
|
|
||||||
;; --- deterministic lookups (first solution under fixed fact order) ---
|
|
||||||
|
|
||||||
(define
|
|
||||||
catalog-price
|
|
||||||
(fn
|
|
||||||
(cat sku)
|
|
||||||
(let
|
|
||||||
((rs (run 1 p (priceo cat sku p))))
|
|
||||||
(if (empty? rs) nil (first rs)))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
catalog-class
|
|
||||||
(fn
|
|
||||||
(cat sku)
|
|
||||||
(let
|
|
||||||
((rs (run 1 c (classo cat sku c))))
|
|
||||||
(if (empty? rs) nil (first rs)))))
|
|
||||||
|
|
||||||
(define catalog-has? (fn (cat sku) (not (nil? (catalog-price cat sku)))))
|
|
||||||
@@ -1,153 +0,0 @@
|
|||||||
#!/usr/bin/env bash
|
|
||||||
# lib/commerce/conformance.sh — run commerce test suites in one sx_server
|
|
||||||
# process per suite, emit scoreboard.json + scoreboard.md.
|
|
||||||
#
|
|
||||||
# commerce-on-sx builds pricing/promotion as miniKanren relations, so every
|
|
||||||
# suite loads the miniKanren stack first, then the commerce modules.
|
|
||||||
|
|
||||||
set -uo pipefail
|
|
||||||
cd "$(git rev-parse --show-toplevel)"
|
|
||||||
|
|
||||||
SX_SERVER="${SX_SERVER:-/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe}"
|
|
||||||
if [ ! -x "$SX_SERVER" ]; then
|
|
||||||
SX_SERVER="hosts/ocaml/_build/default/bin/sx_server.exe"
|
|
||||||
fi
|
|
||||||
if [ ! -x "$SX_SERVER" ]; then
|
|
||||||
echo "ERROR: sx_server.exe not found." >&2
|
|
||||||
exit 1
|
|
||||||
fi
|
|
||||||
|
|
||||||
SUITES=(catalog cart price api promo stack quote ledger order recon federation attribution payment window nettax stock refund integration)
|
|
||||||
|
|
||||||
OUT_JSON="lib/commerce/scoreboard.json"
|
|
||||||
OUT_MD="lib/commerce/scoreboard.md"
|
|
||||||
|
|
||||||
run_suite() {
|
|
||||||
local suite=$1
|
|
||||||
local file="lib/commerce/tests/${suite}.sx"
|
|
||||||
local TMP
|
|
||||||
TMP=$(mktemp)
|
|
||||||
cat > "$TMP" << EPOCHS
|
|
||||||
(epoch 1)
|
|
||||||
(load "spec/stdlib.sx")
|
|
||||||
(load "lib/r7rs.sx")
|
|
||||||
(load "lib/guest/match.sx")
|
|
||||||
(load "lib/minikanren/unify.sx")
|
|
||||||
(load "lib/minikanren/stream.sx")
|
|
||||||
(load "lib/minikanren/goals.sx")
|
|
||||||
(load "lib/minikanren/fresh.sx")
|
|
||||||
(load "lib/minikanren/conde.sx")
|
|
||||||
(load "lib/minikanren/run.sx")
|
|
||||||
(load "lib/minikanren/relations.sx")
|
|
||||||
(load "lib/minikanren/project.sx")
|
|
||||||
(load "lib/minikanren/intarith.sx")
|
|
||||||
(load "lib/minikanren/matche.sx")
|
|
||||||
(load "lib/minikanren/defrel.sx")
|
|
||||||
(load "lib/persist/event.sx")
|
|
||||||
(load "lib/persist/backend.sx")
|
|
||||||
(load "lib/persist/log.sx")
|
|
||||||
(load "lib/persist/kv.sx")
|
|
||||||
(load "lib/persist/idempotency.sx")
|
|
||||||
(load "lib/guest/lex.sx")
|
|
||||||
(load "lib/guest/reflective/env.sx")
|
|
||||||
(load "lib/guest/reflective/quoting.sx")
|
|
||||||
(load "lib/scheme/parser.sx")
|
|
||||||
(load "lib/scheme/eval.sx")
|
|
||||||
(load "lib/scheme/runtime.sx")
|
|
||||||
(load "lib/flow/spec.sx")
|
|
||||||
(load "lib/flow/store.sx")
|
|
||||||
(load "lib/flow/remote.sx")
|
|
||||||
(load "lib/flow/host.sx")
|
|
||||||
(load "lib/flow/api.sx")
|
|
||||||
(load "lib/commerce/catalog.sx")
|
|
||||||
(load "lib/commerce/cart.sx")
|
|
||||||
(load "lib/commerce/price.sx")
|
|
||||||
(load "lib/commerce/api.sx")
|
|
||||||
(load "lib/commerce/promo.sx")
|
|
||||||
(load "lib/commerce/stack.sx")
|
|
||||||
(load "lib/commerce/quote.sx")
|
|
||||||
(load "lib/commerce/window.sx")
|
|
||||||
(load "lib/commerce/nettax.sx")
|
|
||||||
(load "lib/commerce/stock.sx")
|
|
||||||
(load "lib/commerce/ledger.sx")
|
|
||||||
(load "lib/commerce/order.sx")
|
|
||||||
(load "lib/commerce/refund.sx")
|
|
||||||
(load "lib/commerce/payment.sx")
|
|
||||||
(load "lib/commerce/recon.sx")
|
|
||||||
(load "lib/commerce/federation.sx")
|
|
||||||
(load "lib/commerce/attribution.sx")
|
|
||||||
(epoch 2)
|
|
||||||
(eval "(define ct-pass 0)")
|
|
||||||
(eval "(define ct-fail 0)")
|
|
||||||
(eval "(define ct-fails (list))")
|
|
||||||
(eval "(define commerce-test (fn (name got expected) (if (= got expected) (set! ct-pass (+ ct-pass 1)) (begin (set! ct-fail (+ ct-fail 1)) (append! ct-fails name)))))")
|
|
||||||
(epoch 3)
|
|
||||||
(load "${file}")
|
|
||||||
(epoch 4)
|
|
||||||
(eval "(list ct-pass ct-fail)")
|
|
||||||
(eval "ct-fails")
|
|
||||||
EPOCHS
|
|
||||||
|
|
||||||
local OUTPUT
|
|
||||||
OUTPUT=$(timeout 560 "$SX_SERVER" < "$TMP" 2>/dev/null)
|
|
||||||
rm -f "$TMP"
|
|
||||||
|
|
||||||
# The (list ct-pass ct-fail) result follows its (ok-len 2 N) ack line.
|
|
||||||
local LINE
|
|
||||||
LINE=$(echo "$OUTPUT" | grep -oE '^\([0-9]+ [0-9]+\)$' | tail -1)
|
|
||||||
local P F
|
|
||||||
P=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\)$/\1/')
|
|
||||||
F=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\)$/\2/')
|
|
||||||
P=${P:-0}
|
|
||||||
F=${F:-0}
|
|
||||||
echo "${P} ${F}"
|
|
||||||
}
|
|
||||||
|
|
||||||
declare -A SUITE_PASS
|
|
||||||
declare -A SUITE_FAIL
|
|
||||||
TOTAL_PASS=0
|
|
||||||
TOTAL_FAIL=0
|
|
||||||
|
|
||||||
echo "Running commerce conformance suite..." >&2
|
|
||||||
for s in "${SUITES[@]}"; do
|
|
||||||
read -r p f < <(run_suite "$s")
|
|
||||||
SUITE_PASS[$s]=$p
|
|
||||||
SUITE_FAIL[$s]=$f
|
|
||||||
TOTAL_PASS=$((TOTAL_PASS + p))
|
|
||||||
TOTAL_FAIL=$((TOTAL_FAIL + f))
|
|
||||||
printf " %-12s %d/%d\n" "$s" "$p" "$((p+f))" >&2
|
|
||||||
done
|
|
||||||
|
|
||||||
{
|
|
||||||
printf '{\n'
|
|
||||||
printf ' "suites": {\n'
|
|
||||||
first=1
|
|
||||||
for s in "${SUITES[@]}"; do
|
|
||||||
if [ $first -eq 0 ]; then printf ',\n'; fi
|
|
||||||
printf ' "%s": {"pass": %d, "fail": %d}' "$s" "${SUITE_PASS[$s]}" "${SUITE_FAIL[$s]}"
|
|
||||||
first=0
|
|
||||||
done
|
|
||||||
printf '\n },\n'
|
|
||||||
printf ' "total_pass": %d,\n' "$TOTAL_PASS"
|
|
||||||
printf ' "total_fail": %d,\n' "$TOTAL_FAIL"
|
|
||||||
printf ' "total": %d\n' "$((TOTAL_PASS + TOTAL_FAIL))"
|
|
||||||
printf '}\n'
|
|
||||||
} > "$OUT_JSON"
|
|
||||||
|
|
||||||
{
|
|
||||||
printf '# commerce Conformance Scoreboard\n\n'
|
|
||||||
printf '_Generated by `lib/commerce/conformance.sh`_\n\n'
|
|
||||||
printf '| Suite | Pass | Fail | Total |\n'
|
|
||||||
printf '|-------|-----:|-----:|------:|\n'
|
|
||||||
for s in "${SUITES[@]}"; do
|
|
||||||
p=${SUITE_PASS[$s]}
|
|
||||||
f=${SUITE_FAIL[$s]}
|
|
||||||
printf '| %s | %d | %d | %d |\n' "$s" "$p" "$f" "$((p+f))"
|
|
||||||
done
|
|
||||||
printf '| **Total** | **%d** | **%d** | **%d** |\n' "$TOTAL_PASS" "$TOTAL_FAIL" "$((TOTAL_PASS + TOTAL_FAIL))"
|
|
||||||
} > "$OUT_MD"
|
|
||||||
|
|
||||||
echo "Wrote $OUT_JSON and $OUT_MD" >&2
|
|
||||||
echo "Total: $TOTAL_PASS pass, $TOTAL_FAIL fail" >&2
|
|
||||||
|
|
||||||
[ "$TOTAL_FAIL" -eq 0 ]
|
|
||||||
@@ -1,86 +0,0 @@
|
|||||||
;; lib/commerce/federation.sx — cross-instance catalog (federated marketplace).
|
|
||||||
;;
|
|
||||||
;; STUB: instances are registered in-process; there is no real network or
|
|
||||||
;; ActivityPub transport here (that lives in the federation service). The point
|
|
||||||
;; is the relational model: a federated catalog is just the UNION of each
|
|
||||||
;; instance's product facts, tagged with origin, so the same miniKanren
|
|
||||||
;; relations answer cross-instance questions — "which instances sell this sku?",
|
|
||||||
;; "which is cheapest?" — as backward queries, no new query engine.
|
|
||||||
|
|
||||||
(define federation-stub? true)
|
|
||||||
|
|
||||||
(define make-federation (fn (instance cat) {:instances (list (list instance cat))}))
|
|
||||||
|
|
||||||
(define
|
|
||||||
federation-add
|
|
||||||
(fn
|
|
||||||
(fed instance cat)
|
|
||||||
(assoc
|
|
||||||
fed
|
|
||||||
:instances (append (get fed :instances) (list (list instance cat))))))
|
|
||||||
|
|
||||||
(define federation-instances (fn (fed) (map first (get fed :instances))))
|
|
||||||
|
|
||||||
;; Flatten to (instance sku price class) origin-tagged tuples.
|
|
||||||
(define
|
|
||||||
fed-products
|
|
||||||
(fn
|
|
||||||
(fed)
|
|
||||||
(reduce
|
|
||||||
(fn
|
|
||||||
(acc pair)
|
|
||||||
(let
|
|
||||||
((instance (first pair)) (cat (nth pair 1)))
|
|
||||||
(append
|
|
||||||
acc
|
|
||||||
(map (fn (p) (cons instance p)) (get cat :products)))))
|
|
||||||
(list)
|
|
||||||
(get fed :instances))))
|
|
||||||
|
|
||||||
;; --- relations over the federated catalog (multidirectional) ---
|
|
||||||
|
|
||||||
(define
|
|
||||||
fed-producto
|
|
||||||
(fn
|
|
||||||
(fed instance sku price class)
|
|
||||||
(membero (list instance sku price class) (fed-products fed))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
fed-priceo
|
|
||||||
(fn
|
|
||||||
(fed instance sku price)
|
|
||||||
(fresh (c) (fed-producto fed instance sku price c))))
|
|
||||||
|
|
||||||
;; --- query helpers ---
|
|
||||||
|
|
||||||
;; Which instances carry a sku? (backward query)
|
|
||||||
(define
|
|
||||||
instances-with-sku
|
|
||||||
(fn (fed sku) (run* inst (fresh (p c) (fed-producto fed inst sku p c)))))
|
|
||||||
|
|
||||||
;; All (price instance) offers for a sku, in federation order.
|
|
||||||
(define
|
|
||||||
sku-offers
|
|
||||||
(fn
|
|
||||||
(fed sku)
|
|
||||||
(run*
|
|
||||||
pair
|
|
||||||
(fresh
|
|
||||||
(inst p c)
|
|
||||||
(fed-producto fed inst sku p c)
|
|
||||||
(== pair (list p inst))))))
|
|
||||||
|
|
||||||
;; Cheapest (price instance) for a sku — the deterministic selection layer.
|
|
||||||
(define
|
|
||||||
cheapest-offer
|
|
||||||
(fn
|
|
||||||
(fed sku)
|
|
||||||
(let
|
|
||||||
((offers (sku-offers fed sku)))
|
|
||||||
(if
|
|
||||||
(empty? offers)
|
|
||||||
nil
|
|
||||||
(reduce
|
|
||||||
(fn (best x) (if (< (first x) (first best)) x best))
|
|
||||||
(first offers)
|
|
||||||
offers)))))
|
|
||||||
@@ -1,176 +0,0 @@
|
|||||||
;; lib/commerce/ledger.sx — the order ledger as a persist event stream.
|
|
||||||
;;
|
|
||||||
;; Each order is an append-only stream "order/<id>" in a persist backend.
|
|
||||||
;; Order state is never stored directly — it is a projection (fold) over the
|
|
||||||
;; events, so the ledger is the single source of truth and replays identically.
|
|
||||||
;;
|
|
||||||
;; Lifecycle events:
|
|
||||||
;; :created quote snapshot {:subtotal :discount :tax :total :codes ...}
|
|
||||||
;; :reserved stock reserved
|
|
||||||
;; :paid {:amount :ref} — recorded idempotently on the payment ref
|
|
||||||
;; :fulfilled order shipped/delivered
|
|
||||||
;; :cancelled / :refunded
|
|
||||||
;;
|
|
||||||
;; Idempotency: the SumUp webhook can fire twice for one payment. order-pay
|
|
||||||
;; uses persist/append-once keyed by the payment ref, so a replayed webhook
|
|
||||||
;; yields the SAME :paid event without double-recording. Reconciliation then
|
|
||||||
;; detects genuine mismatches (paid != ordered) across the whole ledger.
|
|
||||||
|
|
||||||
(define order-stream (fn (order-id) (str "order/" order-id)))
|
|
||||||
|
|
||||||
;; --- writes ---
|
|
||||||
|
|
||||||
(define
|
|
||||||
order-create
|
|
||||||
(fn
|
|
||||||
(b order-id at quote)
|
|
||||||
(persist/append b (order-stream order-id) :created at quote)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
order-reserve
|
|
||||||
(fn
|
|
||||||
(b order-id at data)
|
|
||||||
(persist/append b (order-stream order-id) :reserved at data)))
|
|
||||||
|
|
||||||
;; Idempotent on payment ref — a replayed webhook does not double-record.
|
|
||||||
(define
|
|
||||||
order-pay
|
|
||||||
(fn
|
|
||||||
(b order-id ref at amount)
|
|
||||||
(persist/append-once b (order-stream order-id) ref :paid at {:amount amount :ref ref})))
|
|
||||||
|
|
||||||
(define
|
|
||||||
order-fulfil
|
|
||||||
(fn
|
|
||||||
(b order-id at data)
|
|
||||||
(persist/append b (order-stream order-id) :fulfilled at data)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
order-cancel
|
|
||||||
(fn
|
|
||||||
(b order-id at reason)
|
|
||||||
(persist/append b (order-stream order-id) :cancelled at {:reason reason})))
|
|
||||||
|
|
||||||
(define
|
|
||||||
order-refund
|
|
||||||
(fn
|
|
||||||
(b order-id ref at amount)
|
|
||||||
(persist/append-once
|
|
||||||
b
|
|
||||||
(order-stream order-id)
|
|
||||||
(str "refund/" ref)
|
|
||||||
:refunded at
|
|
||||||
{:amount amount :ref ref})))
|
|
||||||
|
|
||||||
;; --- reads ---
|
|
||||||
|
|
||||||
(define
|
|
||||||
order-events
|
|
||||||
(fn (b order-id) (persist/read b (order-stream order-id))))
|
|
||||||
|
|
||||||
;; --- projections over an event list ---
|
|
||||||
|
|
||||||
(define
|
|
||||||
order-status-of
|
|
||||||
(fn
|
|
||||||
(events)
|
|
||||||
(reduce
|
|
||||||
(fn
|
|
||||||
(st e)
|
|
||||||
(let
|
|
||||||
((t (persist/event-type e)))
|
|
||||||
(cond
|
|
||||||
((= t :created) :pending)
|
|
||||||
((= t :reserved) :reserved)
|
|
||||||
((= t :paid) :paid)
|
|
||||||
((= t :fulfilled) :fulfilled)
|
|
||||||
((= t :cancelled) :cancelled)
|
|
||||||
((= t :refunded) :refunded)
|
|
||||||
(:else st))))
|
|
||||||
:new events)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
order-total-of
|
|
||||||
(fn
|
|
||||||
(events)
|
|
||||||
(let
|
|
||||||
((created (filter (fn (e) (= (persist/event-type e) :created)) events)))
|
|
||||||
(if
|
|
||||||
(empty? created)
|
|
||||||
0
|
|
||||||
(get (persist/event-data (first created)) :total)))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
order-paid-amount-of
|
|
||||||
(fn
|
|
||||||
(events)
|
|
||||||
(reduce
|
|
||||||
(fn
|
|
||||||
(acc e)
|
|
||||||
(if
|
|
||||||
(= (persist/event-type e) :paid)
|
|
||||||
(+ acc (get (persist/event-data e) :amount))
|
|
||||||
acc))
|
|
||||||
0
|
|
||||||
events)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
order-refunded-amount-of
|
|
||||||
(fn
|
|
||||||
(events)
|
|
||||||
(reduce
|
|
||||||
(fn
|
|
||||||
(acc e)
|
|
||||||
(if
|
|
||||||
(= (persist/event-type e) :refunded)
|
|
||||||
(+ acc (get (persist/event-data e) :amount))
|
|
||||||
acc))
|
|
||||||
0
|
|
||||||
events)))
|
|
||||||
|
|
||||||
;; Net settled = paid - refunded. Reconciliation compares this to the order
|
|
||||||
;; total, but only once a payment exists.
|
|
||||||
(define
|
|
||||||
order-recon-of
|
|
||||||
(fn
|
|
||||||
(events)
|
|
||||||
(let
|
|
||||||
((net (- (order-paid-amount-of events) (order-refunded-amount-of events)))
|
|
||||||
(total (order-total-of events))
|
|
||||||
(has-paid (some (fn (e) (= (persist/event-type e) :paid)) events)))
|
|
||||||
(cond
|
|
||||||
((not has-paid) :unpaid)
|
|
||||||
((= net total) :ok)
|
|
||||||
((< net total) :underpaid)
|
|
||||||
(:else :overpaid)))))
|
|
||||||
|
|
||||||
;; --- backend-level helpers ---
|
|
||||||
|
|
||||||
(define
|
|
||||||
order-status
|
|
||||||
(fn (b order-id) (order-status-of (order-events b order-id))))
|
|
||||||
(define
|
|
||||||
order-total
|
|
||||||
(fn (b order-id) (order-total-of (order-events b order-id))))
|
|
||||||
(define
|
|
||||||
order-paid
|
|
||||||
(fn (b order-id) (order-paid-amount-of (order-events b order-id))))
|
|
||||||
(define
|
|
||||||
order-recon
|
|
||||||
(fn (b order-id) (order-recon-of (order-events b order-id))))
|
|
||||||
|
|
||||||
(define order-ids (fn (b) (persist/backend-streams b)))
|
|
||||||
|
|
||||||
;; Streams whose net payment does not match the order total (true mismatches,
|
|
||||||
;; excluding orders that are simply not yet paid).
|
|
||||||
(define
|
|
||||||
ledger-mismatches
|
|
||||||
(fn
|
|
||||||
(b)
|
|
||||||
(filter
|
|
||||||
(fn
|
|
||||||
(s)
|
|
||||||
(let
|
|
||||||
((r (order-recon-of (persist/read b s))))
|
|
||||||
(or (= r :underpaid) (= r :overpaid))))
|
|
||||||
(persist/backend-streams b))))
|
|
||||||
@@ -1,80 +0,0 @@
|
|||||||
;; lib/commerce/nettax.sx — discount-aware tax (alternative policy).
|
|
||||||
;;
|
|
||||||
;; price.sx / quote.sx tax the GROSS per-line amounts (discount reduces payable
|
|
||||||
;; but not the tax base). This module is the alternative explicit policy: tax the
|
|
||||||
;; NET (post-discount) base. The basket-level discount is allocated across lines
|
|
||||||
;; in proportion to each line's extended price, with a deterministic
|
|
||||||
;; largest-remainder pass so per-line shares sum EXACTLY to the discount; tax is
|
|
||||||
;; then charged on each line's net at its class rate.
|
|
||||||
;;
|
|
||||||
;; Both policies are reproducible from (ctx, cart, ruleset, exclusions); pick the
|
|
||||||
;; one the jurisdiction requires. cart-quote-net mirrors cart-quote's shape.
|
|
||||||
|
|
||||||
(define ct-sum (fn (xs) (reduce (fn (a x) (+ a x)) 0 xs)))
|
|
||||||
|
|
||||||
;; Add 1 to the first `rem` elements (deterministic remainder distribution).
|
|
||||||
(define
|
|
||||||
ct-add-rem
|
|
||||||
(fn
|
|
||||||
(xs rem)
|
|
||||||
(cond
|
|
||||||
((empty? xs) (list))
|
|
||||||
((> rem 0)
|
|
||||||
(cons
|
|
||||||
(+ (first xs) 1)
|
|
||||||
(ct-add-rem (rest xs) (- rem 1))))
|
|
||||||
(:else xs))))
|
|
||||||
|
|
||||||
;; Per-line discount allocation (parallel to cart), summing exactly to
|
|
||||||
;; total-discount, proportional to line-extended share.
|
|
||||||
(define
|
|
||||||
allocate-discount
|
|
||||||
(fn
|
|
||||||
(cat cart total-discount)
|
|
||||||
(let
|
|
||||||
((sub (cart-subtotal cat cart)))
|
|
||||||
(if
|
|
||||||
(= sub 0)
|
|
||||||
(map (fn (l) 0) cart)
|
|
||||||
(let
|
|
||||||
((floors (map (fn (l) (quotient (* total-discount (line-extended cat l)) sub)) cart)))
|
|
||||||
(ct-add-rem floors (- total-discount (ct-sum floors))))))))
|
|
||||||
|
|
||||||
;; Tax on one line's net (extended - allocated discount), clamped at 0.
|
|
||||||
(define
|
|
||||||
net-line-tax
|
|
||||||
(fn
|
|
||||||
(ctx line alloc)
|
|
||||||
(let
|
|
||||||
((cat (ctx-catalog ctx)))
|
|
||||||
(let
|
|
||||||
((net (- (line-extended cat line) alloc)))
|
|
||||||
(apply-bps
|
|
||||||
(if (< net 0) 0 net)
|
|
||||||
(rate-bps
|
|
||||||
(get ctx :tax-rules)
|
|
||||||
(get ctx :jurisdiction)
|
|
||||||
(catalog-class cat (line-sku line))
|
|
||||||
(get ctx :customer)))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
net-tax
|
|
||||||
(fn
|
|
||||||
(ctx cart allocations)
|
|
||||||
(ct-sum
|
|
||||||
(map (fn (line alloc) (net-line-tax ctx line alloc)) cart allocations))))
|
|
||||||
|
|
||||||
;; Discount-aware quote: tax computed on the net (post-discount) base.
|
|
||||||
(define
|
|
||||||
cart-quote-net
|
|
||||||
(fn
|
|
||||||
(ctx cart ruleset exclusions)
|
|
||||||
(let
|
|
||||||
((cat (ctx-catalog ctx)))
|
|
||||||
(let
|
|
||||||
((sub (cart-subtotal cat cart))
|
|
||||||
(disc (best-promo-discount ctx cart ruleset exclusions))
|
|
||||||
(codes (best-promo-codes ctx cart ruleset exclusions)))
|
|
||||||
(let
|
|
||||||
((tax (net-tax ctx cart (allocate-discount cat cart disc))))
|
|
||||||
{:codes codes :subtotal sub :discount disc :total (+ (- sub disc) tax) :tax tax})))))
|
|
||||||
@@ -1,119 +0,0 @@
|
|||||||
;; lib/commerce/order.sx — order lifecycle as a durable flow-on-sx flow.
|
|
||||||
;;
|
|
||||||
;; The lifecycle (reserve -> await payment -> fulfil) is a Scheme flow running
|
|
||||||
;; in the flow-on-sx guest (lib/flow). The flow is PURE ORCHESTRATION: it
|
|
||||||
;; carries only the order-id and enforces step ordering + the suspension at the
|
|
||||||
;; payment IO boundary. All IO/state lives in SX: the SX driver here services
|
|
||||||
;; each flow request by appending to the persist ledger (ledger.sx).
|
|
||||||
;;
|
|
||||||
;; reserve -> SX appends :reserved, resumes (synchronous host effect)
|
|
||||||
;; payment -> flow stays SUSPENDED until the SumUp webhook resumes it
|
|
||||||
;; fulfil -> SX appends :fulfilled, resumes (synchronous host effect)
|
|
||||||
;;
|
|
||||||
;; Durability: the flow's replay log is plain data (flow-store-export), so a
|
|
||||||
;; suspended order survives a process restart — order-flow-restart! simulates
|
|
||||||
;; that entirely Scheme-side. Idempotency: order-settle! only resumes a flow
|
|
||||||
;; still waiting on payment, so a replayed webhook is a no-op at the flow level,
|
|
||||||
;; and order-pay is idempotent at the ledger level.
|
|
||||||
|
|
||||||
;; The flow definition (Scheme source). oid is in scope throughout the begin.
|
|
||||||
(define
|
|
||||||
order-flow-src
|
|
||||||
"(defflow order-lifecycle (lambda (oid) (begin (request (quote reserve) oid) (request (quote payment) oid) (request (quote fulfil) oid))))")
|
|
||||||
|
|
||||||
;; Build a flow env with the order flow registered. Never returns the env from
|
|
||||||
;; an eval boundary (the env is large/cyclic — serializing it hangs).
|
|
||||||
(define
|
|
||||||
order-make-env
|
|
||||||
(fn
|
|
||||||
()
|
|
||||||
(let
|
|
||||||
((env (flow-make-env)))
|
|
||||||
(begin (flow-run-in env order-flow-src) env))))
|
|
||||||
|
|
||||||
;; --- thin Scheme bridge (string-interpolated flow ops) ---
|
|
||||||
|
|
||||||
(define
|
|
||||||
order-flow-start
|
|
||||||
(fn
|
|
||||||
(env oid)
|
|
||||||
(flow-run-in env (str "(flow/start order-lifecycle \"" oid "\")"))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
order-flow-resume
|
|
||||||
(fn
|
|
||||||
(env id sym)
|
|
||||||
(flow-run-in env (str "(flow/resume " id " (quote " sym "))"))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
order-flow-status
|
|
||||||
(fn (env id) (flow-run-in env (str "(flow/status " id ")"))))
|
|
||||||
(define
|
|
||||||
order-flow-result
|
|
||||||
(fn (env id) (flow-run-in env (str "(flow/result " id ")"))))
|
|
||||||
|
|
||||||
;; The request kind the flow with this id is waiting on, or nil if it is not
|
|
||||||
;; suspended on a host request (done / cancelled / unknown).
|
|
||||||
(define
|
|
||||||
order-flow-waiting
|
|
||||||
(fn
|
|
||||||
(env id)
|
|
||||||
(let
|
|
||||||
((reqs (flow-run-in env "(flow-host-requests)")))
|
|
||||||
(let
|
|
||||||
((mine (filter (fn (r) (= (first r) id)) reqs)))
|
|
||||||
(if (empty? mine) nil (nth (first mine) 1))))))
|
|
||||||
|
|
||||||
;; Id out of a (flow-suspended id tag) start/resume result.
|
|
||||||
(define order-susp-id (fn (susp) (nth susp 1)))
|
|
||||||
|
|
||||||
;; --- high-level lifecycle (flow + ledger composed) ---
|
|
||||||
|
|
||||||
;; Create the order, start the flow, service the reserve step, and leave the
|
|
||||||
;; flow suspended at payment. Returns the flow id (needed to settle later).
|
|
||||||
(define
|
|
||||||
order-begin!
|
|
||||||
(fn
|
|
||||||
(env b oid at quote)
|
|
||||||
(begin
|
|
||||||
(order-create b oid at quote)
|
|
||||||
(let
|
|
||||||
((id (order-susp-id (order-flow-start env oid))))
|
|
||||||
(begin
|
|
||||||
(order-reserve b oid (+ at 1) {})
|
|
||||||
(order-flow-resume env id :reserved)
|
|
||||||
id)))))
|
|
||||||
|
|
||||||
;; Settle a payment: record it, resume the flow past payment, service fulfil.
|
|
||||||
;; Idempotent — only acts when the flow is still waiting on payment, so a
|
|
||||||
;; replayed webhook returns :already-settled without double-charging.
|
|
||||||
(define
|
|
||||||
order-settle!
|
|
||||||
(fn
|
|
||||||
(env b id oid ref at amount)
|
|
||||||
(if
|
|
||||||
(= (order-flow-waiting env id) "payment")
|
|
||||||
(begin
|
|
||||||
(order-pay b oid ref at amount)
|
|
||||||
(order-flow-resume env id :paid)
|
|
||||||
(order-fulfil b oid (+ at 1) {})
|
|
||||||
(order-flow-resume env id :fulfilled)
|
|
||||||
:settled)
|
|
||||||
:already-settled)))
|
|
||||||
|
|
||||||
;; Simulate a process restart: export the flow store, reset the runtime, reload
|
|
||||||
;; the flow definition, reimport the store. Done entirely Scheme-side so the
|
|
||||||
;; (large) store is never marshalled across the boundary. The persist ledger is
|
|
||||||
;; a separate store and is unaffected. Suspended flows resume afterwards.
|
|
||||||
(define
|
|
||||||
order-flow-restart!
|
|
||||||
(fn
|
|
||||||
(env)
|
|
||||||
(flow-run-in
|
|
||||||
env
|
|
||||||
(str
|
|
||||||
"(begin (define _saved (flow-store-export)) "
|
|
||||||
flow-reset-src
|
|
||||||
" "
|
|
||||||
order-flow-src
|
|
||||||
" (flow-store-import! _saved) #t)"))))
|
|
||||||
@@ -1,41 +0,0 @@
|
|||||||
;; lib/commerce/payment.sx — provider-neutral payment-request envelope.
|
|
||||||
;;
|
|
||||||
;; The order flow (order.sx) suspends on `(request 'payment oid)` — it carries
|
|
||||||
;; ONLY the order-id and calls no provider. This layer materialises, at the IO
|
|
||||||
;; edge, the envelope a provider adapter needs to initiate payment:
|
|
||||||
;;
|
|
||||||
;; {:order oid :amount <ledger total> :currency C :return-url U}
|
|
||||||
;;
|
|
||||||
;; amount comes from the ledger (the :created quote total); currency + return-url
|
|
||||||
;; are host/provider config (legitimately host-supplied). The engine stays
|
|
||||||
;; vendor-agnostic: SumUp/Stripe/etc. adapters consume this envelope, and
|
|
||||||
;; order-settle!(ref, amount) is the vendor-neutral resume seam. No provider
|
|
||||||
;; SDK, HTTP, or webhook parsing lives here — that is the orders service's job.
|
|
||||||
|
|
||||||
(define payment-request (fn (b oid currency return-url) {:order oid :amount (order-total b oid) :return-url return-url :currency currency}))
|
|
||||||
|
|
||||||
(define payment-request-order (fn (pr) (get pr :order)))
|
|
||||||
(define payment-request-amount (fn (pr) (get pr :amount)))
|
|
||||||
(define payment-request-currency (fn (pr) (get pr :currency)))
|
|
||||||
(define payment-request-return-url (fn (pr) (get pr :return-url)))
|
|
||||||
|
|
||||||
;; A Scheme string carried as a flow payload round-trips back to SX wrapped as
|
|
||||||
;; {:scm-string "..."}; unwrap it to the bare order-id.
|
|
||||||
(define
|
|
||||||
scm->string
|
|
||||||
(fn
|
|
||||||
(v)
|
|
||||||
(if (and (dict? v) (has-key? v :scm-string)) (get v :scm-string) v)))
|
|
||||||
|
|
||||||
;; Host poller seam: every order currently suspended awaiting payment, each with
|
|
||||||
;; its envelope. A provider adapter iterates these, initiates payment, and later
|
|
||||||
;; calls order-settle! when the webhook arrives. Needs the flow env.
|
|
||||||
(define
|
|
||||||
pending-payments
|
|
||||||
(fn
|
|
||||||
(env b currency return-url)
|
|
||||||
(let
|
|
||||||
((reqs (flow-run-in env "(flow-host-requests)")))
|
|
||||||
(map
|
|
||||||
(fn (r) {:id (first r) :request (payment-request b (scm->string (nth r 2)) currency return-url)})
|
|
||||||
(filter (fn (r) (= (nth r 1) "payment")) reqs)))))
|
|
||||||
@@ -1,110 +0,0 @@
|
|||||||
;; lib/commerce/price.sx — deterministic subtotal + jurisdiction-relational tax.
|
|
||||||
;;
|
|
||||||
;; A pricing context bundles the inputs that make a total reproducible:
|
|
||||||
;; {:catalog CAT :tax-rules RULES :jurisdiction J :customer C}
|
|
||||||
;; Same context + same cart => identical total, every run.
|
|
||||||
;;
|
|
||||||
;; Tax is NOT a hardcoded VAT rate. Rules are facts indexed by
|
|
||||||
;; (jurisdiction, product-class, customer-class) -> rate-bps
|
|
||||||
;; where rate-bps is an integer in basis points (2000 = 20%). taxo queries
|
|
||||||
;; them multidirectionally. Money stays in integer minor units; rounding is
|
|
||||||
;; half-up per line via integer arithmetic only — never floats.
|
|
||||||
|
|
||||||
(define
|
|
||||||
make-pricing-context
|
|
||||||
(fn (catalog tax-rules jurisdiction customer) {:customer customer :jurisdiction jurisdiction :catalog catalog :tax-rules tax-rules}))
|
|
||||||
|
|
||||||
(define ctx-catalog (fn (ctx) (get ctx :catalog)))
|
|
||||||
|
|
||||||
;; --- unit + line pricing ---
|
|
||||||
|
|
||||||
;; Variant delta, defaulting to 0 when the (sku,variant) has no variant fact.
|
|
||||||
(define
|
|
||||||
variant-delta
|
|
||||||
(fn
|
|
||||||
(cat sku variant)
|
|
||||||
(let
|
|
||||||
((rs (run 1 d (varianto cat sku variant d))))
|
|
||||||
(if (empty? rs) 0 (first rs)))))
|
|
||||||
|
|
||||||
;; Effective unit price = base price + variant delta. nil if sku unknown.
|
|
||||||
(define
|
|
||||||
line-unit-price
|
|
||||||
(fn
|
|
||||||
(cat sku variant)
|
|
||||||
(let
|
|
||||||
((base (catalog-price cat sku)))
|
|
||||||
(if (nil? base) nil (+ base (variant-delta cat sku variant))))))
|
|
||||||
|
|
||||||
;; Extended (line) price = unit price * quantity.
|
|
||||||
(define
|
|
||||||
line-extended
|
|
||||||
(fn
|
|
||||||
(cat line)
|
|
||||||
(*
|
|
||||||
(line-unit-price cat (line-sku line) (line-variant line))
|
|
||||||
(line-qty line))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
cart-subtotal
|
|
||||||
(fn
|
|
||||||
(cat cart)
|
|
||||||
(reduce (fn (acc l) (+ acc (line-extended cat l))) 0 cart)))
|
|
||||||
|
|
||||||
;; --- tax (jurisdiction-relational) ---
|
|
||||||
|
|
||||||
;; rules: (list (list jurisdiction class customer bps) ...)
|
|
||||||
(define
|
|
||||||
taxo
|
|
||||||
(fn
|
|
||||||
(rules juris class cust bps)
|
|
||||||
(membero (list juris class cust bps) rules)))
|
|
||||||
|
|
||||||
;; Deterministic rate lookup; 0 when no rule matches.
|
|
||||||
(define
|
|
||||||
rate-bps
|
|
||||||
(fn
|
|
||||||
(rules juris class cust)
|
|
||||||
(let
|
|
||||||
((rs (run 1 b (taxo rules juris class cust b))))
|
|
||||||
(if (empty? rs) 0 (first rs)))))
|
|
||||||
|
|
||||||
;; Apply a basis-point rate to an integer amount, rounding half up.
|
|
||||||
(define
|
|
||||||
apply-bps
|
|
||||||
(fn (amount bps) (quotient (+ (* amount bps) 5000) 10000)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
line-tax
|
|
||||||
(fn
|
|
||||||
(ctx line)
|
|
||||||
(let
|
|
||||||
((cat (ctx-catalog ctx)))
|
|
||||||
(let
|
|
||||||
((class (catalog-class cat (line-sku line))))
|
|
||||||
(apply-bps
|
|
||||||
(line-extended cat line)
|
|
||||||
(rate-bps
|
|
||||||
(get ctx :tax-rules)
|
|
||||||
(get ctx :jurisdiction)
|
|
||||||
class
|
|
||||||
(get ctx :customer)))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
cart-tax
|
|
||||||
(fn
|
|
||||||
(ctx cart)
|
|
||||||
(reduce (fn (acc l) (+ acc (line-tax ctx l))) 0 cart)))
|
|
||||||
|
|
||||||
;; --- total ---
|
|
||||||
|
|
||||||
;; Returns {:subtotal :discounts :tax :total}. discounts is 0 until Phase 2.
|
|
||||||
(define
|
|
||||||
cart-total
|
|
||||||
(fn
|
|
||||||
(ctx cart)
|
|
||||||
(let
|
|
||||||
((cat (ctx-catalog ctx)))
|
|
||||||
(let
|
|
||||||
((sub (cart-subtotal cat cart)) (tax (cart-tax ctx cart)))
|
|
||||||
{:subtotal sub :discounts 0 :total (+ sub tax) :tax tax}))))
|
|
||||||
@@ -1,153 +0,0 @@
|
|||||||
;; lib/commerce/promo.sx — promotions as relations over the cart + catalog.
|
|
||||||
;;
|
|
||||||
;; A promo is a tagged tuple; the second field is always its code:
|
|
||||||
;; (:percent code class pct-bps) pct-bps off every line of product-class
|
|
||||||
;; (:fixed code threshold amount) amount off when subtotal >= threshold
|
|
||||||
;; (:bundle code sku n) every nth unit of sku is free
|
|
||||||
;; (:member code class pct-bps) like :percent, members only
|
|
||||||
;;
|
|
||||||
;; A ruleset is a list of promo tuples. The discount a promo yields on a
|
|
||||||
;; given cart is a pure integer computation (minor units); the *enumeration*
|
|
||||||
;; of which promos apply is relational, so promo-applieso runs forward
|
|
||||||
;; ("which codes apply and for how much?") and backward ("which code yields
|
|
||||||
;; this discount?"). Stacking precedence is a separate layer (stack.sx).
|
|
||||||
|
|
||||||
(define promo-kind (fn (p) (nth p 0)))
|
|
||||||
(define promo-code (fn (p) (nth p 1)))
|
|
||||||
|
|
||||||
;; Extended price of all lines whose sku is in product-class `class`.
|
|
||||||
(define
|
|
||||||
class-extended
|
|
||||||
(fn
|
|
||||||
(ctx cart class)
|
|
||||||
(let
|
|
||||||
((cat (ctx-catalog ctx)))
|
|
||||||
(reduce
|
|
||||||
(fn
|
|
||||||
(acc l)
|
|
||||||
(if
|
|
||||||
(= (catalog-class cat (line-sku l)) class)
|
|
||||||
(+ acc (line-extended cat l))
|
|
||||||
acc))
|
|
||||||
0
|
|
||||||
cart))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
sku-qty
|
|
||||||
(fn
|
|
||||||
(cart sku)
|
|
||||||
(reduce
|
|
||||||
(fn (acc l) (if (= (line-sku l) sku) (+ acc (line-qty l)) acc))
|
|
||||||
0
|
|
||||||
cart)))
|
|
||||||
|
|
||||||
;; --- per-type discount amounts (pure, integer minor units) ---
|
|
||||||
|
|
||||||
(define
|
|
||||||
percent-amount
|
|
||||||
(fn
|
|
||||||
(ctx cart p)
|
|
||||||
(apply-bps
|
|
||||||
(class-extended ctx cart (nth p 2))
|
|
||||||
(nth p 3))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
fixed-amount
|
|
||||||
(fn
|
|
||||||
(ctx cart p)
|
|
||||||
(let
|
|
||||||
((sub (cart-subtotal (ctx-catalog ctx) cart)))
|
|
||||||
(if
|
|
||||||
(>= sub (nth p 2))
|
|
||||||
(min (nth p 3) sub)
|
|
||||||
0))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
bundle-amount
|
|
||||||
(fn
|
|
||||||
(ctx cart p)
|
|
||||||
(let
|
|
||||||
((sku (nth p 2)) (n (nth p 3)))
|
|
||||||
(let
|
|
||||||
((free (quotient (sku-qty cart sku) n)))
|
|
||||||
(* free (catalog-price (ctx-catalog ctx) sku))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
member-amount
|
|
||||||
(fn
|
|
||||||
(ctx cart p)
|
|
||||||
(if
|
|
||||||
(= (get ctx :customer) :member)
|
|
||||||
(apply-bps
|
|
||||||
(class-extended ctx cart (nth p 2))
|
|
||||||
(nth p 3))
|
|
||||||
0)))
|
|
||||||
|
|
||||||
;; Discount this promo yields on this cart (0 if it does not apply).
|
|
||||||
(define
|
|
||||||
promo-amount
|
|
||||||
(fn
|
|
||||||
(ctx cart p)
|
|
||||||
(let
|
|
||||||
((k (promo-kind p)))
|
|
||||||
(cond
|
|
||||||
((= k :percent) (percent-amount ctx cart p))
|
|
||||||
((= k :fixed) (fixed-amount ctx cart p))
|
|
||||||
((= k :bundle) (bundle-amount ctx cart p))
|
|
||||||
((= k :member) (member-amount ctx cart p))
|
|
||||||
(:else 0)))))
|
|
||||||
|
|
||||||
;; --- relational enumeration ---
|
|
||||||
|
|
||||||
;; (code, amount) for every promo in the ruleset (amount may be 0).
|
|
||||||
(define
|
|
||||||
promo-discounto
|
|
||||||
(fn
|
|
||||||
(ctx cart ruleset code amount)
|
|
||||||
(fresh
|
|
||||||
(p)
|
|
||||||
(membero p ruleset)
|
|
||||||
(project
|
|
||||||
(p)
|
|
||||||
(== code (promo-code p))
|
|
||||||
(== amount (promo-amount ctx cart p))))))
|
|
||||||
|
|
||||||
;; (code, amount) restricted to promos that actually apply (amount > 0).
|
|
||||||
(define
|
|
||||||
promo-applieso
|
|
||||||
(fn
|
|
||||||
(ctx cart ruleset code amount)
|
|
||||||
(fresh
|
|
||||||
(p)
|
|
||||||
(membero p ruleset)
|
|
||||||
(project
|
|
||||||
(p)
|
|
||||||
(if
|
|
||||||
(> (promo-amount ctx cart p) 0)
|
|
||||||
(mk-conj
|
|
||||||
(== code (promo-code p))
|
|
||||||
(== amount (promo-amount ctx cart p)))
|
|
||||||
fail)))))
|
|
||||||
|
|
||||||
;; --- deterministic helpers ---
|
|
||||||
|
|
||||||
;; List of (list code amount) for applicable promos, in ruleset order.
|
|
||||||
(define
|
|
||||||
applicable-promos
|
|
||||||
(fn
|
|
||||||
(ctx cart ruleset)
|
|
||||||
(run*
|
|
||||||
pair
|
|
||||||
(fresh
|
|
||||||
(code amount)
|
|
||||||
(promo-applieso ctx cart ruleset code amount)
|
|
||||||
(== pair (list code amount))))))
|
|
||||||
|
|
||||||
;; Discount for one code (0 if absent / inapplicable).
|
|
||||||
(define
|
|
||||||
promo-amount-for
|
|
||||||
(fn
|
|
||||||
(ctx cart ruleset code)
|
|
||||||
(let
|
|
||||||
((rs (run 1 a (promo-applieso ctx cart ruleset code a))))
|
|
||||||
(if (empty? rs) 0 (first rs)))))
|
|
||||||
@@ -1,36 +0,0 @@
|
|||||||
;; lib/commerce/quote.sx — the final priced quote: price + promo + stacking.
|
|
||||||
;;
|
|
||||||
;; A quote is the deterministic composition of the pricing pipeline for a
|
|
||||||
;; (context, cart, ruleset, exclusions) tuple:
|
|
||||||
;; {:subtotal S :discount D :tax T :total (S - D + T) :codes (...)}
|
|
||||||
;;
|
|
||||||
;; Tax policy (explicit, for the determinism contract): tax is computed on the
|
|
||||||
;; GROSS per-line amounts (pre-discount), via price.sx cart-tax. The best
|
|
||||||
;; promo stacking reduces the payable total but not the tax base. Same inputs
|
|
||||||
;; always yield the same quote — this is the value the order flow carries.
|
|
||||||
|
|
||||||
(define
|
|
||||||
cart-quote
|
|
||||||
(fn
|
|
||||||
(ctx cart ruleset exclusions)
|
|
||||||
(let
|
|
||||||
((cat (ctx-catalog ctx)))
|
|
||||||
(let
|
|
||||||
((sub (cart-subtotal cat cart))
|
|
||||||
(disc (best-promo-discount ctx cart ruleset exclusions))
|
|
||||||
(tax (cart-tax ctx cart))
|
|
||||||
(codes (best-promo-codes ctx cart ruleset exclusions)))
|
|
||||||
{:codes codes :subtotal sub :discount disc :total (+ (- sub disc) tax) :tax tax}))))
|
|
||||||
|
|
||||||
(define quote-subtotal (fn (q) (get q :subtotal)))
|
|
||||||
(define quote-discount (fn (q) (get q :discount)))
|
|
||||||
(define quote-tax (fn (q) (get q :tax)))
|
|
||||||
(define quote-total (fn (q) (get q :total)))
|
|
||||||
(define quote-codes (fn (q) (get q :codes)))
|
|
||||||
|
|
||||||
;; Session-level convenience (a session is {:ctx :cart}).
|
|
||||||
(define
|
|
||||||
session-quote
|
|
||||||
(fn
|
|
||||||
(sess ruleset exclusions)
|
|
||||||
(cart-quote (get sess :ctx) (get sess :cart) ruleset exclusions)))
|
|
||||||
@@ -1,100 +0,0 @@
|
|||||||
;; lib/commerce/recon.sx — reconciliation as relational queries over the ledger.
|
|
||||||
;;
|
|
||||||
;; The ledger (ledger.sx) is the source of truth; reconciliation projects it
|
|
||||||
;; into per-order summary tuples and then asks miniKanren questions about them.
|
|
||||||
;; "Which orders are overpaid?" / "which order settled to net N?" are backward
|
|
||||||
;; queries (run*) over the same relation, not separate code paths.
|
|
||||||
;;
|
|
||||||
;; A summary tuple is positional:
|
|
||||||
;; (order-stream total paid refunded net status)
|
|
||||||
;; net = paid - refunded; status = :unpaid|:ok|:underpaid|:overpaid.
|
|
||||||
|
|
||||||
(define
|
|
||||||
order-summary
|
|
||||||
(fn
|
|
||||||
(b stream)
|
|
||||||
(let
|
|
||||||
((events (persist/read b stream)))
|
|
||||||
(let
|
|
||||||
((total (order-total-of events))
|
|
||||||
(paid (order-paid-amount-of events))
|
|
||||||
(refunded (order-refunded-amount-of events)))
|
|
||||||
(list
|
|
||||||
stream
|
|
||||||
total
|
|
||||||
paid
|
|
||||||
refunded
|
|
||||||
(- paid refunded)
|
|
||||||
(order-recon-of events))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
ledger-summaries
|
|
||||||
(fn (b) (map (fn (s) (order-summary b s)) (persist/backend-streams b))))
|
|
||||||
|
|
||||||
;; --- relations over the summary set ---
|
|
||||||
|
|
||||||
(define
|
|
||||||
summaryo
|
|
||||||
(fn
|
|
||||||
(summaries id total paid refunded net status)
|
|
||||||
(membero (list id total paid refunded net status) summaries)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
recon-statuso
|
|
||||||
(fn
|
|
||||||
(summaries id status)
|
|
||||||
(fresh (t p r n) (summaryo summaries id t p r n status))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
neto
|
|
||||||
(fn
|
|
||||||
(summaries id net)
|
|
||||||
(fresh (t p r status) (summaryo summaries id t p r net status))))
|
|
||||||
|
|
||||||
;; A mismatch is any order whose money does not reconcile (over or under).
|
|
||||||
(define
|
|
||||||
mismatcho
|
|
||||||
(fn
|
|
||||||
(summaries id)
|
|
||||||
(fresh
|
|
||||||
(status)
|
|
||||||
(recon-statuso summaries id status)
|
|
||||||
(conde ((== status :underpaid)) ((== status :overpaid))))))
|
|
||||||
|
|
||||||
;; --- deterministic query helpers (run* over the live ledger) ---
|
|
||||||
|
|
||||||
(define
|
|
||||||
orders-with-status
|
|
||||||
(fn (b status) (run* id (recon-statuso (ledger-summaries b) id status))))
|
|
||||||
|
|
||||||
(define overpaid-orders (fn (b) (orders-with-status b :overpaid)))
|
|
||||||
(define underpaid-orders (fn (b) (orders-with-status b :underpaid)))
|
|
||||||
(define settled-orders (fn (b) (orders-with-status b :ok)))
|
|
||||||
(define unpaid-orders (fn (b) (orders-with-status b :unpaid)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
mismatched-orders
|
|
||||||
(fn (b) (run* id (mismatcho (ledger-summaries b) id))))
|
|
||||||
|
|
||||||
;; Backward: which order(s) settled to a given net amount?
|
|
||||||
(define
|
|
||||||
orders-with-net
|
|
||||||
(fn (b net) (run* id (neto (ledger-summaries b) id net))))
|
|
||||||
|
|
||||||
;; Total signed discrepancy across the ledger (net - total over paid orders);
|
|
||||||
;; 0 when every settled order reconciles exactly.
|
|
||||||
(define
|
|
||||||
ledger-discrepancy
|
|
||||||
(fn
|
|
||||||
(b)
|
|
||||||
(reduce
|
|
||||||
(fn
|
|
||||||
(acc s)
|
|
||||||
(let
|
|
||||||
((status (nth s 5)))
|
|
||||||
(if
|
|
||||||
(= status :unpaid)
|
|
||||||
acc
|
|
||||||
(+ acc (- (nth s 4) (nth s 1))))))
|
|
||||||
0
|
|
||||||
(ledger-summaries b))))
|
|
||||||
@@ -1,97 +0,0 @@
|
|||||||
;; lib/commerce/refund.sx — refund lifecycle as a second flow-on-sx flow.
|
|
||||||
;;
|
|
||||||
;; A refund is request → approve → settle, with TWO genuine suspension points:
|
|
||||||
;; approval (a human/policy decision) and settlement (the provider issuing the
|
|
||||||
;; refund). Like order.sx the flow is pure orchestration carrying only the
|
|
||||||
;; order-id; the SX driver does all ledger IO and reuses order.sx's generic flow
|
|
||||||
;; helpers (order-flow-waiting/-resume/-status, order-susp-id).
|
|
||||||
;;
|
|
||||||
;; refund-begin! → ledger :refund-requested, flow suspends at 'approve
|
|
||||||
;; refund-approve! → resume past approval, flow suspends at 'settle
|
|
||||||
;; refund-settle! → ledger :refunded (idempotent), flow completes
|
|
||||||
;; refund-reject! → ledger :refund-rejected, flow cancelled
|
|
||||||
;;
|
|
||||||
;; Only :refunded moves the books (recon.sx), so a requested-but-unsettled or
|
|
||||||
;; rejected refund leaves reconciliation unchanged.
|
|
||||||
|
|
||||||
(define
|
|
||||||
refund-flow-src
|
|
||||||
"(defflow refund-lifecycle (lambda (oid) (begin (request (quote approve) oid) (request (quote settle) oid))))")
|
|
||||||
|
|
||||||
(define
|
|
||||||
refund-make-env
|
|
||||||
(fn
|
|
||||||
()
|
|
||||||
(let
|
|
||||||
((env (flow-make-env)))
|
|
||||||
(begin (flow-run-in env refund-flow-src) env))))
|
|
||||||
|
|
||||||
;; Register the refund flow into an existing (e.g. order) env.
|
|
||||||
(define
|
|
||||||
refund-flow-load!
|
|
||||||
(fn (env) (begin (flow-run-in env refund-flow-src) env)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
refund-flow-start
|
|
||||||
(fn
|
|
||||||
(env oid)
|
|
||||||
(flow-run-in env (str "(flow/start refund-lifecycle \"" oid "\")"))))
|
|
||||||
|
|
||||||
;; --- ledger writes ---
|
|
||||||
|
|
||||||
(define
|
|
||||||
refund-request
|
|
||||||
(fn
|
|
||||||
(b oid ref at amount)
|
|
||||||
(persist/append-once
|
|
||||||
b
|
|
||||||
(order-stream oid)
|
|
||||||
(str "refund-req/" ref)
|
|
||||||
:refund-requested at
|
|
||||||
{:amount amount :ref ref})))
|
|
||||||
|
|
||||||
;; --- lifecycle ---
|
|
||||||
|
|
||||||
;; Open a refund: record the request, start the flow, suspend at approval.
|
|
||||||
(define
|
|
||||||
refund-begin!
|
|
||||||
(fn
|
|
||||||
(env b oid ref at amount)
|
|
||||||
(begin
|
|
||||||
(refund-request b oid ref at amount)
|
|
||||||
(order-susp-id (refund-flow-start env oid)))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
refund-approve!
|
|
||||||
(fn
|
|
||||||
(env id)
|
|
||||||
(if
|
|
||||||
(= (order-flow-waiting env id) "approve")
|
|
||||||
(begin (order-flow-resume env id :approved) :approved)
|
|
||||||
:not-pending-approval)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
refund-reject!
|
|
||||||
(fn
|
|
||||||
(env b oid id at reason)
|
|
||||||
(if
|
|
||||||
(= (order-flow-waiting env id) "approve")
|
|
||||||
(begin
|
|
||||||
(persist/append b (order-stream oid) :refund-rejected at {:reason reason})
|
|
||||||
(flow-run-in env (str "(flow/cancel " id ")"))
|
|
||||||
:rejected)
|
|
||||||
:not-pending-approval)))
|
|
||||||
|
|
||||||
;; Settle (provider issued the refund): idempotent — only acts while waiting on
|
|
||||||
;; settle, so a replayed provider callback returns :already-settled.
|
|
||||||
(define
|
|
||||||
refund-settle!
|
|
||||||
(fn
|
|
||||||
(env b id oid ref at amount)
|
|
||||||
(if
|
|
||||||
(= (order-flow-waiting env id) "settle")
|
|
||||||
(begin
|
|
||||||
(order-refund b oid ref at amount)
|
|
||||||
(order-flow-resume env id :settled)
|
|
||||||
:settled)
|
|
||||||
:already-settled)))
|
|
||||||
@@ -1,25 +0,0 @@
|
|||||||
{
|
|
||||||
"suites": {
|
|
||||||
"catalog": {"pass": 16, "fail": 0},
|
|
||||||
"cart": {"pass": 18, "fail": 0},
|
|
||||||
"price": {"pass": 20, "fail": 0},
|
|
||||||
"api": {"pass": 12, "fail": 0},
|
|
||||||
"promo": {"pass": 17, "fail": 0},
|
|
||||||
"stack": {"pass": 16, "fail": 0},
|
|
||||||
"quote": {"pass": 13, "fail": 0},
|
|
||||||
"ledger": {"pass": 20, "fail": 0},
|
|
||||||
"order": {"pass": 22, "fail": 0},
|
|
||||||
"recon": {"pass": 20, "fail": 0},
|
|
||||||
"federation": {"pass": 12, "fail": 0},
|
|
||||||
"attribution": {"pass": 16, "fail": 0},
|
|
||||||
"payment": {"pass": 7, "fail": 0},
|
|
||||||
"window": {"pass": 19, "fail": 0},
|
|
||||||
"nettax": {"pass": 11, "fail": 0},
|
|
||||||
"stock": {"pass": 19, "fail": 0},
|
|
||||||
"refund": {"pass": 20, "fail": 0},
|
|
||||||
"integration": {"pass": 19, "fail": 0}
|
|
||||||
},
|
|
||||||
"total_pass": 297,
|
|
||||||
"total_fail": 0,
|
|
||||||
"total": 297
|
|
||||||
}
|
|
||||||
@@ -1,25 +0,0 @@
|
|||||||
# commerce Conformance Scoreboard
|
|
||||||
|
|
||||||
_Generated by `lib/commerce/conformance.sh`_
|
|
||||||
|
|
||||||
| Suite | Pass | Fail | Total |
|
|
||||||
|-------|-----:|-----:|------:|
|
|
||||||
| catalog | 16 | 0 | 16 |
|
|
||||||
| cart | 18 | 0 | 18 |
|
|
||||||
| price | 20 | 0 | 20 |
|
|
||||||
| api | 12 | 0 | 12 |
|
|
||||||
| promo | 17 | 0 | 17 |
|
|
||||||
| stack | 16 | 0 | 16 |
|
|
||||||
| quote | 13 | 0 | 13 |
|
|
||||||
| ledger | 20 | 0 | 20 |
|
|
||||||
| order | 22 | 0 | 22 |
|
|
||||||
| recon | 20 | 0 | 20 |
|
|
||||||
| federation | 12 | 0 | 12 |
|
|
||||||
| attribution | 16 | 0 | 16 |
|
|
||||||
| payment | 7 | 0 | 7 |
|
|
||||||
| window | 19 | 0 | 19 |
|
|
||||||
| nettax | 11 | 0 | 11 |
|
|
||||||
| stock | 19 | 0 | 19 |
|
|
||||||
| refund | 20 | 0 | 20 |
|
|
||||||
| integration | 19 | 0 | 19 |
|
|
||||||
| **Total** | **297** | **0** | **297** |
|
|
||||||
@@ -1,121 +0,0 @@
|
|||||||
;; lib/commerce/stack.sx — promotion stacking precedence + best price.
|
|
||||||
;;
|
|
||||||
;; Per the miniKanren design rule, precedence is NOT encoded inside the promo
|
|
||||||
;; rules. promo.sx enumerates which promos apply; this layer enumerates which
|
|
||||||
;; *combinations* are legal and selects the best one by an explicit cost
|
|
||||||
;; function (max total discount = min price).
|
|
||||||
;;
|
|
||||||
;; Exclusivity is a list of unordered code pairs that may not both apply:
|
|
||||||
;; exclusions = (list (list code-a code-b) ...)
|
|
||||||
;; A stacking is a subset of applicable (code amount) pairs containing no
|
|
||||||
;; excluded pair. valid-stackings enumerates them; best-stacking is the
|
|
||||||
;; deterministic selection layer; stacking-by-totalo is the backward query
|
|
||||||
;; ("which legal stacking yields this total discount?").
|
|
||||||
|
|
||||||
(define
|
|
||||||
excluded-pair?
|
|
||||||
(fn
|
|
||||||
(exclusions a b)
|
|
||||||
(some
|
|
||||||
(fn
|
|
||||||
(p)
|
|
||||||
(or
|
|
||||||
(and (= (first p) a) (= (nth p 1) b))
|
|
||||||
(and (= (first p) b) (= (nth p 1) a))))
|
|
||||||
exclusions)))
|
|
||||||
|
|
||||||
;; True when no two distinct codes in the list are mutually excluded.
|
|
||||||
(define
|
|
||||||
compatible?
|
|
||||||
(fn
|
|
||||||
(exclusions codes)
|
|
||||||
(every?
|
|
||||||
(fn
|
|
||||||
(a)
|
|
||||||
(every?
|
|
||||||
(fn (b) (or (= a b) (not (excluded-pair? exclusions a b))))
|
|
||||||
codes))
|
|
||||||
codes)))
|
|
||||||
|
|
||||||
;; All subsets of xs, preserving element order. 2^n entries.
|
|
||||||
(define
|
|
||||||
powerset
|
|
||||||
(fn
|
|
||||||
(xs)
|
|
||||||
(if
|
|
||||||
(empty? xs)
|
|
||||||
(list (list))
|
|
||||||
(let
|
|
||||||
((r (powerset (cdr xs))))
|
|
||||||
(append r (map (fn (s) (cons (first xs) s)) r))))))
|
|
||||||
|
|
||||||
(define stacking-codes (fn (st) (map first st)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
stacking-total
|
|
||||||
(fn
|
|
||||||
(st)
|
|
||||||
(reduce (fn (acc pair) (+ acc (nth pair 1))) 0 st)))
|
|
||||||
|
|
||||||
;; Every legal stacking of the applicable (code amount) pairs.
|
|
||||||
(define
|
|
||||||
valid-stackings
|
|
||||||
(fn
|
|
||||||
(exclusions applicable)
|
|
||||||
(filter
|
|
||||||
(fn (st) (compatible? exclusions (stacking-codes st)))
|
|
||||||
(powerset applicable))))
|
|
||||||
|
|
||||||
;; Deterministic selection: the legal stacking with the greatest total
|
|
||||||
;; discount; ties keep the earlier (stable) candidate, so the result is a
|
|
||||||
;; reproducible function of (exclusions, applicable).
|
|
||||||
(define
|
|
||||||
best-stacking
|
|
||||||
(fn
|
|
||||||
(exclusions applicable)
|
|
||||||
(reduce
|
|
||||||
(fn
|
|
||||||
(best st)
|
|
||||||
(if (> (stacking-total st) (stacking-total best)) st best))
|
|
||||||
(list)
|
|
||||||
(valid-stackings exclusions applicable))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
best-discount
|
|
||||||
(fn
|
|
||||||
(exclusions applicable)
|
|
||||||
(stacking-total (best-stacking exclusions applicable))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
best-codes
|
|
||||||
(fn
|
|
||||||
(exclusions applicable)
|
|
||||||
(stacking-codes (best-stacking exclusions applicable))))
|
|
||||||
|
|
||||||
;; Backward query: legal stackings (as code lists) whose total discount = D.
|
|
||||||
(define
|
|
||||||
stacking-by-totalo
|
|
||||||
(fn
|
|
||||||
(stackings codes total)
|
|
||||||
(fresh
|
|
||||||
(st)
|
|
||||||
(membero st stackings)
|
|
||||||
(project
|
|
||||||
(st)
|
|
||||||
(mk-conj
|
|
||||||
(== codes (stacking-codes st))
|
|
||||||
(== total (stacking-total st)))))))
|
|
||||||
|
|
||||||
;; --- top-level entry: best discount for a cart under a ruleset ---
|
|
||||||
|
|
||||||
(define
|
|
||||||
best-promo-discount
|
|
||||||
(fn
|
|
||||||
(ctx cart ruleset exclusions)
|
|
||||||
(best-discount exclusions (applicable-promos ctx cart ruleset))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
best-promo-codes
|
|
||||||
(fn
|
|
||||||
(ctx cart ruleset exclusions)
|
|
||||||
(best-codes exclusions (applicable-promos ctx cart ruleset))))
|
|
||||||
@@ -1,106 +0,0 @@
|
|||||||
;; lib/commerce/stock.sx — stock-constrained reservation.
|
|
||||||
;;
|
|
||||||
;; Reservation is a precondition the host checks BEFORE order-begin! (validate →
|
|
||||||
;; begin), so the order flow stays pure orchestration. Availability is read
|
|
||||||
;; relationally from the catalog stock facts (catalog.sx stocko); a stock view
|
|
||||||
;; subtracts already-reserved quantities so concurrent orders can't over-reserve.
|
|
||||||
;;
|
|
||||||
;; can-reserve? cat cart — every line fits available stock
|
|
||||||
;; reservation-shortfalls cat cart — the lines that do not, with detail
|
|
||||||
;; effective-available cat reservations … — availability net of reservations
|
|
||||||
;; sufficient-stocko cat sku variant qty — relational "can supply qty?" query
|
|
||||||
|
|
||||||
;; Deterministic on-hand stock for a (sku,variant); 0 if absent.
|
|
||||||
(define
|
|
||||||
available-stock
|
|
||||||
(fn
|
|
||||||
(cat sku variant)
|
|
||||||
(let
|
|
||||||
((rs (run 1 q (stocko cat sku variant q))))
|
|
||||||
(if (empty? rs) 0 (first rs)))))
|
|
||||||
|
|
||||||
;; Units a line cannot fulfil from on-hand stock (0 if it fits).
|
|
||||||
(define
|
|
||||||
line-shortfall
|
|
||||||
(fn
|
|
||||||
(cat line)
|
|
||||||
(let
|
|
||||||
((short (- (line-qty line) (available-stock cat (line-sku line) (line-variant line)))))
|
|
||||||
(if (< short 0) 0 short))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
line-reservable?
|
|
||||||
(fn (cat line) (= (line-shortfall cat line) 0)))
|
|
||||||
|
|
||||||
;; Lines that cannot be fully reserved, each with requested/available/short.
|
|
||||||
(define
|
|
||||||
reservation-shortfalls
|
|
||||||
(fn
|
|
||||||
(cat cart)
|
|
||||||
(reduce
|
|
||||||
(fn
|
|
||||||
(acc line)
|
|
||||||
(let
|
|
||||||
((short (line-shortfall cat line)))
|
|
||||||
(if (> short 0) (append acc (list {:requested (line-qty line) :available (available-stock cat (line-sku line) (line-variant line)) :sku (line-sku line) :variant (line-variant line) :short short})) acc)))
|
|
||||||
(list)
|
|
||||||
cart)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
can-reserve?
|
|
||||||
(fn (cat cart) (empty? (reservation-shortfalls cat cart))))
|
|
||||||
|
|
||||||
;; Validate → reject; the host gates order-begin! on this.
|
|
||||||
(define
|
|
||||||
reserve-check
|
|
||||||
(fn (cat cart) (if (can-reserve? cat cart) :ok {:shortfalls (reservation-shortfalls cat cart) :rejected :insufficient-stock})))
|
|
||||||
|
|
||||||
;; --- reservation view (concurrent-safety) ---
|
|
||||||
;; reservations: list of (sku variant qty) already held.
|
|
||||||
|
|
||||||
(define
|
|
||||||
reserved-qty
|
|
||||||
(fn
|
|
||||||
(reservations sku variant)
|
|
||||||
(reduce
|
|
||||||
(fn
|
|
||||||
(acc r)
|
|
||||||
(if
|
|
||||||
(and (= (first r) sku) (= (nth r 1) variant))
|
|
||||||
(+ acc (nth r 2))
|
|
||||||
acc))
|
|
||||||
0
|
|
||||||
reservations)))
|
|
||||||
|
|
||||||
;; On-hand minus already-reserved (clamped at 0).
|
|
||||||
(define
|
|
||||||
effective-available
|
|
||||||
(fn
|
|
||||||
(cat reservations sku variant)
|
|
||||||
(let
|
|
||||||
((eff (- (available-stock cat sku variant) (reserved-qty reservations sku variant))))
|
|
||||||
(if (< eff 0) 0 eff))))
|
|
||||||
|
|
||||||
;; Can a line be reserved given existing reservations?
|
|
||||||
(define
|
|
||||||
line-reservable-with?
|
|
||||||
(fn
|
|
||||||
(cat reservations line)
|
|
||||||
(<=
|
|
||||||
(line-qty line)
|
|
||||||
(effective-available
|
|
||||||
cat
|
|
||||||
reservations
|
|
||||||
(line-sku line)
|
|
||||||
(line-variant line)))))
|
|
||||||
|
|
||||||
;; --- relational availability query (the showcase) ---
|
|
||||||
|
|
||||||
;; Succeeds when on-hand stock for (sku,variant) covers qty. Multidirectional
|
|
||||||
;; over the stock facts: "which variants of widget can supply 5?" is a backward
|
|
||||||
;; query.
|
|
||||||
(define
|
|
||||||
sufficient-stocko
|
|
||||||
(fn
|
|
||||||
(cat sku variant qty)
|
|
||||||
(fresh (avail) (stocko cat sku variant avail) (lteo-i qty avail))))
|
|
||||||
@@ -1,73 +0,0 @@
|
|||||||
;; lib/commerce/tests/api.sx — public commerce session surface.
|
|
||||||
;; Uses (commerce-test name got expected) provided by conformance.sh.
|
|
||||||
|
|
||||||
(define
|
|
||||||
acat
|
|
||||||
(make-catalog
|
|
||||||
(list
|
|
||||||
(list "widget" 1000 :standard)
|
|
||||||
(list "book" 800 :zero-rated))
|
|
||||||
(list (list "widget" :small -200))
|
|
||||||
(list)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
arules
|
|
||||||
(list
|
|
||||||
(list :uk :standard :guest 2000)
|
|
||||||
(list :uk :zero-rated :guest 0)))
|
|
||||||
|
|
||||||
(define actx (make-pricing-context acat arules :uk :guest))
|
|
||||||
(define sess0 (commerce-session actx))
|
|
||||||
|
|
||||||
;; --- empty session ---
|
|
||||||
|
|
||||||
(commerce-test "new-session-empty" (commerce-cart sess0) empty-cart)
|
|
||||||
(commerce-test "new-count" (commerce-count sess0) 0)
|
|
||||||
(commerce-test "new-total" (commerce-total sess0) {:subtotal 0 :discounts 0 :total 0 :tax 0})
|
|
||||||
|
|
||||||
;; --- add + total ---
|
|
||||||
|
|
||||||
(define
|
|
||||||
sess1
|
|
||||||
(commerce-add
|
|
||||||
(commerce-add sess0 "widget" :small 2)
|
|
||||||
"book"
|
|
||||||
:none 1))
|
|
||||||
|
|
||||||
(commerce-test "add-count" (commerce-count sess1) 3)
|
|
||||||
(commerce-test
|
|
||||||
"add-lines"
|
|
||||||
(commerce-lines sess1)
|
|
||||||
(list (list "widget" :small 2) (list "book" :none 1)))
|
|
||||||
(commerce-test "add-total" (commerce-total sess1) {:subtotal 2400 :discounts 0 :total 2720 :tax 320})
|
|
||||||
|
|
||||||
;; --- mutate ---
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"set-qty"
|
|
||||||
(commerce-lines (commerce-set-qty sess1 "widget" :small 1))
|
|
||||||
(list (list "widget" :small 1) (list "book" :none 1)))
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"remove"
|
|
||||||
(commerce-lines (commerce-remove sess1 "book" :none))
|
|
||||||
(list (list "widget" :small 2)))
|
|
||||||
|
|
||||||
;; --- validation ---
|
|
||||||
|
|
||||||
(commerce-test "can-add-yes" (commerce-can-add? sess0 "widget") true)
|
|
||||||
(commerce-test "can-add-no" (commerce-can-add? sess0 "ghost") false)
|
|
||||||
|
|
||||||
;; --- audit breakdown ---
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"explain"
|
|
||||||
(commerce-explain sess1)
|
|
||||||
(list {:sku "widget" :unit 800 :qty 2 :variant :small :extended 1600 :tax 320} {:sku "book" :unit 800 :qty 1 :variant :none :extended 800 :tax 0}))
|
|
||||||
|
|
||||||
;; --- checkout stub ---
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"checkout-stub"
|
|
||||||
(get (commerce-checkout sess1) :status)
|
|
||||||
:not-implemented)
|
|
||||||
@@ -1,124 +0,0 @@
|
|||||||
;; lib/commerce/tests/attribution.sx — line-level discount attribution.
|
|
||||||
;; Uses (commerce-test name got expected) provided by conformance.sh.
|
|
||||||
|
|
||||||
(define
|
|
||||||
pcat
|
|
||||||
(make-catalog
|
|
||||||
(list
|
|
||||||
(list "widget" 1000 :standard)
|
|
||||||
(list "gizmo" 2000 :standard)
|
|
||||||
(list "book" 800 :zero-rated)
|
|
||||||
(list "tea" 1000 :reduced))
|
|
||||||
(list)
|
|
||||||
(list)))
|
|
||||||
|
|
||||||
(define gctx (make-pricing-context pcat (list) :uk :guest))
|
|
||||||
(define mctx (make-pricing-context pcat (list) :uk :member))
|
|
||||||
|
|
||||||
(define
|
|
||||||
cart
|
|
||||||
(list
|
|
||||||
(list "widget" :none 2)
|
|
||||||
(list "gizmo" :none 1)
|
|
||||||
(list "book" :none 1)
|
|
||||||
(list "tea" :none 6)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
ruleset
|
|
||||||
(list
|
|
||||||
(list :percent "TEN" :standard 1000)
|
|
||||||
(list :percent "TWENTY" :standard 2000)
|
|
||||||
(list :bundle "B3T" "tea" 3)
|
|
||||||
(list :fixed "FIVE" 0 500)
|
|
||||||
(list :member "MEM" :standard 1500)))
|
|
||||||
|
|
||||||
(define w-line (list "widget" :none 2))
|
|
||||||
(define t-line (list "tea" :none 6))
|
|
||||||
(define bk-line (list "book" :none 1))
|
|
||||||
|
|
||||||
;; --- scope helpers ---
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"class-lines-standard"
|
|
||||||
(class-lines gctx cart :standard)
|
|
||||||
(list (list "widget" :none 2) (list "gizmo" :none 1)))
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"promo-lines-bundle"
|
|
||||||
(promo-lines gctx cart (list :bundle "B3T" "tea" 3))
|
|
||||||
(list (list "tea" :none 6)))
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"promo-lines-fixed-none"
|
|
||||||
(promo-lines gctx cart (list :fixed "FIVE" 0 500))
|
|
||||||
(list))
|
|
||||||
|
|
||||||
;; --- forward: which lines does a code touch? ---
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"lines-for-ten"
|
|
||||||
(lines-for-code gctx cart ruleset "TEN")
|
|
||||||
(list (list "widget" :none 2) (list "gizmo" :none 1)))
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"lines-for-bundle"
|
|
||||||
(lines-for-code gctx cart ruleset "B3T")
|
|
||||||
(list (list "tea" :none 6)))
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"lines-for-fixed-empty"
|
|
||||||
(lines-for-code gctx cart ruleset "FIVE")
|
|
||||||
(list))
|
|
||||||
(commerce-test
|
|
||||||
"lines-for-mem-guest-empty"
|
|
||||||
(lines-for-code gctx cart ruleset "MEM")
|
|
||||||
(list))
|
|
||||||
|
|
||||||
;; --- backward: which codes touch this line? (the showcase) ---
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"codes-for-widget-guest"
|
|
||||||
(codes-for-line gctx cart ruleset w-line)
|
|
||||||
(list "TEN" "TWENTY"))
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"codes-for-tea"
|
|
||||||
(codes-for-line gctx cart ruleset t-line)
|
|
||||||
(list "B3T"))
|
|
||||||
(commerce-test
|
|
||||||
"codes-for-book-none"
|
|
||||||
(codes-for-line gctx cart ruleset bk-line)
|
|
||||||
(list))
|
|
||||||
|
|
||||||
;; member sees the member rate too
|
|
||||||
(commerce-test
|
|
||||||
"codes-for-widget-member"
|
|
||||||
(codes-for-line mctx cart ruleset w-line)
|
|
||||||
(list "TEN" "TWENTY" "MEM"))
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"lines-for-mem-member"
|
|
||||||
(lines-for-code mctx cart ruleset "MEM")
|
|
||||||
(list (list "widget" :none 2) (list "gizmo" :none 1)))
|
|
||||||
|
|
||||||
;; --- predicate ---
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"touched-yes"
|
|
||||||
(line-touched-by? gctx cart ruleset "TEN" w-line)
|
|
||||||
true)
|
|
||||||
(commerce-test
|
|
||||||
"touched-no-wrong-class"
|
|
||||||
(line-touched-by? gctx cart ruleset "B3T" w-line)
|
|
||||||
false)
|
|
||||||
(commerce-test
|
|
||||||
"touched-no-guest-mem"
|
|
||||||
(line-touched-by? gctx cart ruleset "MEM" w-line)
|
|
||||||
false)
|
|
||||||
|
|
||||||
;; --- order-level (fixed) codes ---
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"order-level"
|
|
||||||
(order-level-codes gctx cart ruleset)
|
|
||||||
(list "FIVE"))
|
|
||||||
@@ -1,103 +0,0 @@
|
|||||||
;; lib/commerce/tests/cart.sx — cart structure + line operations.
|
|
||||||
;; Uses (commerce-test name got expected) provided by conformance.sh.
|
|
||||||
|
|
||||||
;; --- add ---
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"add-to-empty"
|
|
||||||
(cart-add empty-cart "widget" :small 2)
|
|
||||||
(list (list "widget" :small 2)))
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"add-merges-same-line"
|
|
||||||
(cart-add
|
|
||||||
(cart-add empty-cart "widget" :small 2)
|
|
||||||
"widget"
|
|
||||||
:small 3)
|
|
||||||
(list (list "widget" :small 5)))
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"add-different-variant-separate"
|
|
||||||
(cart-add
|
|
||||||
(cart-add empty-cart "widget" :small 2)
|
|
||||||
"widget"
|
|
||||||
:large 1)
|
|
||||||
(list (list "widget" :small 2) (list "widget" :large 1)))
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"add-different-sku-separate"
|
|
||||||
(cart-add
|
|
||||||
(cart-add empty-cart "widget" :small 2)
|
|
||||||
"gadget"
|
|
||||||
:std 1)
|
|
||||||
(list (list "widget" :small 2) (list "gadget" :std 1)))
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"add-preserves-order"
|
|
||||||
(cart-skus
|
|
||||||
(cart-add
|
|
||||||
(cart-add (cart-add empty-cart "a" :v 1) "b" :v 1)
|
|
||||||
"c"
|
|
||||||
:v 1))
|
|
||||||
(list "a" "b" "c"))
|
|
||||||
|
|
||||||
;; --- qty queries ---
|
|
||||||
|
|
||||||
(define
|
|
||||||
c2
|
|
||||||
(cart-add
|
|
||||||
(cart-add empty-cart "widget" :small 2)
|
|
||||||
"gadget"
|
|
||||||
:std 4))
|
|
||||||
|
|
||||||
(commerce-test "cart-qty-found" (cart-qty c2 "widget" :small) 2)
|
|
||||||
(commerce-test "cart-qty-missing" (cart-qty c2 "widget" :large) 0)
|
|
||||||
(commerce-test "cart-count" (cart-count c2) 6)
|
|
||||||
(commerce-test "cart-empty-yes" (cart-empty? empty-cart) true)
|
|
||||||
(commerce-test "cart-empty-no" (cart-empty? c2) false)
|
|
||||||
|
|
||||||
;; --- set-qty ---
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"set-qty-existing"
|
|
||||||
(cart-set-qty c2 "widget" :small 10)
|
|
||||||
(list (list "widget" :small 10) (list "gadget" :std 4)))
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"set-qty-new-line"
|
|
||||||
(cart-set-qty empty-cart "book" :std 3)
|
|
||||||
(list (list "book" :std 3)))
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"set-qty-zero-removes"
|
|
||||||
(cart-set-qty c2 "widget" :small 0)
|
|
||||||
(list (list "gadget" :std 4)))
|
|
||||||
|
|
||||||
;; --- remove ---
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"remove-line"
|
|
||||||
(cart-remove c2 "gadget" :std)
|
|
||||||
(list (list "widget" :small 2)))
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"remove-missing-noop"
|
|
||||||
(cart-remove c2 "nope" :std)
|
|
||||||
(list (list "widget" :small 2) (list "gadget" :std 4)))
|
|
||||||
|
|
||||||
;; --- relational view ---
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"cart-lineo-forward"
|
|
||||||
(run* q (cart-lineo c2 "gadget" :std q))
|
|
||||||
(list 4))
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"cart-lineo-sku-by-qty-backward"
|
|
||||||
(run* sk (fresh (v) (cart-lineo c2 sk v 4)))
|
|
||||||
(list "gadget"))
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"cart-lineo-all-skus"
|
|
||||||
(run* sk (fresh (v q) (cart-lineo c2 sk v q)))
|
|
||||||
(list "widget" "gadget"))
|
|
||||||
@@ -1,93 +0,0 @@
|
|||||||
;; lib/commerce/tests/catalog.sx — catalog facts + relational accessors.
|
|
||||||
;; Uses (commerce-test name got expected) provided by conformance.sh.
|
|
||||||
;; Query vars avoid the name `s` (the run-n macro binds `s` internally).
|
|
||||||
|
|
||||||
(define
|
|
||||||
cat
|
|
||||||
(make-catalog
|
|
||||||
(list
|
|
||||||
(list "widget" 1000 :standard)
|
|
||||||
(list "gadget" 2500 :standard)
|
|
||||||
(list "book" 800 :zero-rated)
|
|
||||||
(list "tea" 1000 :reduced))
|
|
||||||
(list
|
|
||||||
(list "widget" :small -200)
|
|
||||||
(list "widget" :large 500)
|
|
||||||
(list "gadget" :std 0))
|
|
||||||
(list
|
|
||||||
(list "widget" :small 5)
|
|
||||||
(list "widget" :large 0)
|
|
||||||
(list "gadget" :std 12))))
|
|
||||||
|
|
||||||
;; --- forward lookups ---
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"price-forward"
|
|
||||||
(run* p (priceo cat "widget" p))
|
|
||||||
(list 1000))
|
|
||||||
(commerce-test
|
|
||||||
"class-forward"
|
|
||||||
(run* c (classo cat "book" c))
|
|
||||||
(list :zero-rated))
|
|
||||||
(commerce-test
|
|
||||||
"product-forward"
|
|
||||||
(run* q (fresh (p c) (producto cat "gadget" p c) (== q (list p c))))
|
|
||||||
(list (list 2500 :standard)))
|
|
||||||
|
|
||||||
;; --- backward lookups (the showcase) ---
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"sku-by-price-backward"
|
|
||||||
(run* sk (priceo cat sk 1000))
|
|
||||||
(list "widget" "tea"))
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"sku-by-class-backward"
|
|
||||||
(run* sk (classo cat sk :standard))
|
|
||||||
(list "widget" "gadget"))
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"all-prices"
|
|
||||||
(run* p (fresh (sk) (priceo cat sk p)))
|
|
||||||
(list 1000 2500 800 1000))
|
|
||||||
|
|
||||||
;; --- variants + effective unit price ---
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"variant-delta-forward"
|
|
||||||
(run* d (varianto cat "widget" :small d))
|
|
||||||
(list -200))
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"unit-price-small"
|
|
||||||
(run* p (unit-priceo cat "widget" :small p))
|
|
||||||
(list 800))
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"unit-price-large"
|
|
||||||
(run* p (unit-priceo cat "widget" :large p))
|
|
||||||
(list 1500))
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"variant-by-delta-backward"
|
|
||||||
(run* v (varianto cat "widget" v -200))
|
|
||||||
(list :small))
|
|
||||||
|
|
||||||
;; --- stock ---
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"stock-forward"
|
|
||||||
(run* q (stocko cat "widget" :small q))
|
|
||||||
(list 5))
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"in-stock-skus-backward"
|
|
||||||
(run* sk (fresh (v q) (stocko cat sk v q) (lto-i 0 q)))
|
|
||||||
(list "widget" "gadget"))
|
|
||||||
|
|
||||||
;; --- deterministic helpers ---
|
|
||||||
|
|
||||||
(commerce-test "catalog-price-helper" (catalog-price cat "gadget") 2500)
|
|
||||||
(commerce-test "catalog-class-helper" (catalog-class cat "tea") :reduced)
|
|
||||||
(commerce-test "catalog-has-yes" (catalog-has? cat "book") true)
|
|
||||||
(commerce-test "catalog-has-no" (catalog-has? cat "nonesuch") false)
|
|
||||||
@@ -1,88 +0,0 @@
|
|||||||
;; lib/commerce/tests/federation.sx — federated catalog (out-of-scope stub).
|
|
||||||
;; Uses (commerce-test name got expected) provided by conformance.sh.
|
|
||||||
|
|
||||||
(define
|
|
||||||
cat-a
|
|
||||||
(make-catalog
|
|
||||||
(list
|
|
||||||
(list "widget" 1000 :standard)
|
|
||||||
(list "book" 800 :zero-rated))
|
|
||||||
(list)
|
|
||||||
(list)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
cat-b
|
|
||||||
(make-catalog
|
|
||||||
(list
|
|
||||||
(list "widget" 900 :standard)
|
|
||||||
(list "tea" 1200 :reduced))
|
|
||||||
(list)
|
|
||||||
(list)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
cat-c
|
|
||||||
(make-catalog (list (list "widget" 1100 :standard)) (list) (list)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
fed
|
|
||||||
(federation-add
|
|
||||||
(federation-add (make-federation :alpha cat-a) :beta cat-b)
|
|
||||||
:gamma cat-c))
|
|
||||||
|
|
||||||
;; --- structure ---
|
|
||||||
|
|
||||||
(commerce-test "is-stub" federation-stub? true)
|
|
||||||
(commerce-test
|
|
||||||
"instances"
|
|
||||||
(federation-instances fed)
|
|
||||||
(list :alpha :beta :gamma))
|
|
||||||
(commerce-test "product-count" (len (fed-products fed)) 5)
|
|
||||||
|
|
||||||
;; --- forward query ---
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"price-at-instance"
|
|
||||||
(run* p (fed-priceo fed :beta "widget" p))
|
|
||||||
(list 900))
|
|
||||||
|
|
||||||
;; --- backward queries (the showcase) ---
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"instances-with-widget"
|
|
||||||
(instances-with-sku fed "widget")
|
|
||||||
(list :alpha :beta :gamma))
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"instances-with-book"
|
|
||||||
(instances-with-sku fed "book")
|
|
||||||
(list :alpha))
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"instances-with-tea"
|
|
||||||
(instances-with-sku fed "tea")
|
|
||||||
(list :beta))
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"instance-by-price-backward"
|
|
||||||
(run* inst (fresh (c) (fed-producto fed inst "widget" 1100 c)))
|
|
||||||
(list :gamma))
|
|
||||||
|
|
||||||
;; --- offers + cheapest (deterministic selection) ---
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"widget-offers"
|
|
||||||
(sku-offers fed "widget")
|
|
||||||
(list
|
|
||||||
(list 1000 :alpha)
|
|
||||||
(list 900 :beta)
|
|
||||||
(list 1100 :gamma)))
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"cheapest-widget"
|
|
||||||
(cheapest-offer fed "widget")
|
|
||||||
(list 900 :beta))
|
|
||||||
(commerce-test
|
|
||||||
"cheapest-book"
|
|
||||||
(cheapest-offer fed "book")
|
|
||||||
(list 800 :alpha))
|
|
||||||
(commerce-test "cheapest-missing" (cheapest-offer fed "ghost") nil)
|
|
||||||
@@ -1,104 +0,0 @@
|
|||||||
;; lib/commerce/tests/integration.sx — end-to-end composition proof.
|
|
||||||
;; Uses (commerce-test name got expected) provided by conformance.sh.
|
|
||||||
;;
|
|
||||||
;; One narrative across every module: catalog → stock check → quote
|
|
||||||
;; (promo+stack+tax) → order flow → payment envelope → settle → recon → refund.
|
|
||||||
;; Proves the seams tie together with consistent numbers (the project's thesis:
|
|
||||||
;; minikanren pricing + flow lifecycle + persist ledger compose).
|
|
||||||
;; Builds one flow env with BOTH the order and refund flows.
|
|
||||||
|
|
||||||
(define env (order-make-env))
|
|
||||||
(define _rf (refund-flow-load! env))
|
|
||||||
(define b (persist/mem-backend))
|
|
||||||
|
|
||||||
(define
|
|
||||||
cat
|
|
||||||
(make-catalog
|
|
||||||
(list
|
|
||||||
(list "widget" 1000 :standard)
|
|
||||||
(list "book" 800 :zero-rated))
|
|
||||||
(list (list "widget" :small -200))
|
|
||||||
(list (list "widget" :small 10) (list "book" :none 5))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
rules
|
|
||||||
(list
|
|
||||||
(list :uk :standard :guest 2000)
|
|
||||||
(list :uk :zero-rated :guest 0)))
|
|
||||||
|
|
||||||
(define ctx (make-pricing-context cat rules :uk :guest))
|
|
||||||
|
|
||||||
(define
|
|
||||||
ruleset
|
|
||||||
(list
|
|
||||||
(list :percent "TEN" :standard 1000)
|
|
||||||
(list :fixed "FIVE" 0 50)))
|
|
||||||
|
|
||||||
;; widget :small x2 → unit 800, extended 1600 (standard); book x1 → 800 (zero-rated)
|
|
||||||
(define
|
|
||||||
cart
|
|
||||||
(list (list "widget" :small 2) (list "book" :none 1)))
|
|
||||||
|
|
||||||
;; 1. stock gating passes (widget:small 10 >= 2)
|
|
||||||
(commerce-test "int-can-reserve" (can-reserve? cat cart) true)
|
|
||||||
|
|
||||||
;; 2. quote ties the whole pricing pipeline together
|
|
||||||
;; subtotal 2400; discount TEN 160 + FIVE 50 = 210; tax 1600@20% = 320;
|
|
||||||
;; total 2400 - 210 + 320 = 2510
|
|
||||||
(define q (cart-quote ctx cart ruleset (list)))
|
|
||||||
(commerce-test "int-quote-subtotal" (quote-subtotal q) 2400)
|
|
||||||
(commerce-test "int-quote-discount" (quote-discount q) 210)
|
|
||||||
(commerce-test "int-quote-tax" (quote-tax q) 320)
|
|
||||||
(commerce-test "int-quote-total" (quote-total q) 2510)
|
|
||||||
|
|
||||||
;; 3. attribution explains where the discount landed
|
|
||||||
(commerce-test
|
|
||||||
"int-attribution"
|
|
||||||
(codes-for-line ctx cart ruleset (list "widget" :small 2))
|
|
||||||
(list "TEN"))
|
|
||||||
(commerce-test
|
|
||||||
"int-order-level"
|
|
||||||
(order-level-codes ctx cart ruleset)
|
|
||||||
(list "FIVE"))
|
|
||||||
|
|
||||||
;; 4. order carries the quote total into the ledger; suspends at payment
|
|
||||||
(define oid "INT-1")
|
|
||||||
(define id (order-begin! env b oid 1000 q))
|
|
||||||
(commerce-test "int-order-total-from-quote" (order-total b oid) 2510)
|
|
||||||
(commerce-test "int-waiting-payment" (order-flow-waiting env id) "payment")
|
|
||||||
|
|
||||||
;; 5. the payment envelope reflects the quoted total
|
|
||||||
(commerce-test
|
|
||||||
"int-payment-envelope"
|
|
||||||
(payment-request b oid :GBP "https://shop/return")
|
|
||||||
{:order "INT-1" :amount 2510 :return-url "https://shop/return" :currency :GBP})
|
|
||||||
|
|
||||||
;; 6. settle the quoted amount → reconciles exactly
|
|
||||||
(commerce-test
|
|
||||||
"int-settled"
|
|
||||||
(order-settle! env b id oid "pay-int" 1002 2510)
|
|
||||||
:settled)
|
|
||||||
(commerce-test "int-status-fulfilled" (order-status b oid) :fulfilled)
|
|
||||||
(commerce-test "int-recon-ok" (order-recon b oid) :ok)
|
|
||||||
|
|
||||||
;; 7. partial refund via its own flow → recon moves to underpaid
|
|
||||||
(define rid (refund-begin! env b oid "rf-int" 2000 510))
|
|
||||||
(commerce-test "int-refund-approve" (refund-approve! env rid) :approved)
|
|
||||||
(commerce-test
|
|
||||||
"int-refund-settle"
|
|
||||||
(refund-settle! env b rid oid "rf-int" 2001 510)
|
|
||||||
:settled)
|
|
||||||
(commerce-test
|
|
||||||
"int-refunded-amount"
|
|
||||||
(order-refunded-amount-of (order-events b oid))
|
|
||||||
510)
|
|
||||||
(commerce-test "int-recon-after-refund" (order-recon b oid) :underpaid)
|
|
||||||
|
|
||||||
;; 8. ledger reconciliation flags the now-mismatched order
|
|
||||||
(commerce-test
|
|
||||||
"int-mismatch"
|
|
||||||
(mismatched-orders b)
|
|
||||||
(list (order-stream "INT-1")))
|
|
||||||
|
|
||||||
;; 9. distinct flow ids for the order and the refund
|
|
||||||
(commerce-test "int-distinct-flow-ids" (not (= id rid)) true)
|
|
||||||
@@ -1,80 +0,0 @@
|
|||||||
;; lib/commerce/tests/ledger.sx — order ledger on persist + idempotent recon.
|
|
||||||
;; Uses (commerce-test name got expected) provided by conformance.sh.
|
|
||||||
|
|
||||||
(define q1 {:codes (list) :subtotal 1000 :discount 0 :total 1200 :tax 200})
|
|
||||||
|
|
||||||
;; --- lifecycle status projection ---
|
|
||||||
|
|
||||||
(define b1 (persist/mem-backend))
|
|
||||||
(define _c1 (order-create b1 "A1" 100 q1))
|
|
||||||
(commerce-test "status-pending" (order-status b1 "A1") :pending)
|
|
||||||
(define _r1 (order-reserve b1 "A1" 101 {:lines 2}))
|
|
||||||
(commerce-test "status-reserved" (order-status b1 "A1") :reserved)
|
|
||||||
(define _p1 (order-pay b1 "A1" "ref-1" 102 1200))
|
|
||||||
(commerce-test "status-paid" (order-status b1 "A1") :paid)
|
|
||||||
(define _f1 (order-fulfil b1 "A1" 103 {:carrier "post"}))
|
|
||||||
(commerce-test "status-fulfilled" (order-status b1 "A1") :fulfilled)
|
|
||||||
|
|
||||||
(commerce-test "total-projection" (order-total b1 "A1") 1200)
|
|
||||||
(commerce-test "paid-projection" (order-paid b1 "A1") 1200)
|
|
||||||
(commerce-test "recon-ok" (order-recon b1 "A1") :ok)
|
|
||||||
(commerce-test "event-count" (len (order-events b1 "A1")) 4)
|
|
||||||
|
|
||||||
;; --- idempotency: replayed webhook does not double-record ---
|
|
||||||
|
|
||||||
(define b2 (persist/mem-backend))
|
|
||||||
(define _c2 (order-create b2 "B1" 200 q1))
|
|
||||||
(define _p2a (order-pay b2 "B1" "sumup-9" 201 1200))
|
|
||||||
(define _p2b (order-pay b2 "B1" "sumup-9" 201 1200))
|
|
||||||
(define _p2c (order-pay b2 "B1" "sumup-9" 201 1200))
|
|
||||||
|
|
||||||
(commerce-test "idem-single-event" (len (order-events b2 "B1")) 2)
|
|
||||||
(commerce-test "idem-paid-once" (order-paid b2 "B1") 1200)
|
|
||||||
(commerce-test "idem-recon-ok" (order-recon b2 "B1") :ok)
|
|
||||||
(commerce-test "idem-same-event" (= _p2a _p2c) true)
|
|
||||||
|
|
||||||
;; --- mismatch detection ---
|
|
||||||
|
|
||||||
(define bun (persist/mem-backend))
|
|
||||||
(define _cu (order-create bun "U1" 300 q1))
|
|
||||||
(commerce-test "unpaid-recon" (order-recon bun "U1") :unpaid)
|
|
||||||
|
|
||||||
(define bup (persist/mem-backend))
|
|
||||||
(define _cp (order-create bup "U2" 300 q1))
|
|
||||||
(define _pp1 (order-pay bup "U2" "r-a" 301 1200))
|
|
||||||
(define _pp2 (order-pay bup "U2" "r-b" 302 1200))
|
|
||||||
(commerce-test "double-charge-overpaid" (order-recon bup "U2") :overpaid)
|
|
||||||
(commerce-test "double-charge-amount" (order-paid bup "U2") 2400)
|
|
||||||
|
|
||||||
(define bsh (persist/mem-backend))
|
|
||||||
(define _cs (order-create bsh "U3" 400 q1))
|
|
||||||
(define _ps (order-pay bsh "U3" "r-short" 401 1000))
|
|
||||||
(commerce-test "underpaid-recon" (order-recon bsh "U3") :underpaid)
|
|
||||||
|
|
||||||
;; --- refund (idempotent) reduces net ---
|
|
||||||
|
|
||||||
(define brf (persist/mem-backend))
|
|
||||||
(define _crf (order-create brf "R1" 500 q1))
|
|
||||||
(define _prf (order-pay brf "R1" "p-1" 501 1200))
|
|
||||||
(define _rf1 (order-refund brf "R1" "rf-1" 502 200))
|
|
||||||
(define _rf2 (order-refund brf "R1" "rf-1" 502 200))
|
|
||||||
(commerce-test "refund-idem-net" (order-recon brf "R1") :underpaid)
|
|
||||||
(commerce-test "refund-idem-events" (len (order-events brf "R1")) 3)
|
|
||||||
|
|
||||||
;; --- cross-ledger reconciliation ---
|
|
||||||
|
|
||||||
(define bL (persist/mem-backend))
|
|
||||||
(define _l1 (order-create bL "OK1" 600 q1))
|
|
||||||
(define _l1p (order-pay bL "OK1" "ok-ref" 601 1200))
|
|
||||||
(define _l2 (order-create bL "OVER1" 600 q1))
|
|
||||||
(define _l2a (order-pay bL "OVER1" "o-a" 602 1200))
|
|
||||||
(define _l2b (order-pay bL "OVER1" "o-b" 603 1200))
|
|
||||||
(define _l3 (order-create bL "UNDER1" 600 q1))
|
|
||||||
(define _l3p (order-pay bL "UNDER1" "u-ref" 604 900))
|
|
||||||
(define _l4 (order-create bL "PENDING1" 600 q1))
|
|
||||||
|
|
||||||
(commerce-test "ledger-order-count" (len (order-ids bL)) 4)
|
|
||||||
(commerce-test
|
|
||||||
"ledger-mismatches"
|
|
||||||
(sort (ledger-mismatches bL))
|
|
||||||
(sort (list (order-stream "OVER1") (order-stream "UNDER1"))))
|
|
||||||
@@ -1,92 +0,0 @@
|
|||||||
;; lib/commerce/tests/nettax.sx — discount-aware (net) tax policy.
|
|
||||||
;; Uses (commerce-test name got expected) provided by conformance.sh.
|
|
||||||
|
|
||||||
(define
|
|
||||||
pcat
|
|
||||||
(make-catalog
|
|
||||||
(list
|
|
||||||
(list "widget" 1000 :standard)
|
|
||||||
(list "tea" 1000 :reduced))
|
|
||||||
(list)
|
|
||||||
(list)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
rules
|
|
||||||
(list
|
|
||||||
(list :uk :standard :guest 2000)
|
|
||||||
(list :uk :reduced :guest 500)))
|
|
||||||
|
|
||||||
(define gctx (make-pricing-context pcat rules :uk :guest))
|
|
||||||
|
|
||||||
;; widget x3 = 3000 (standard), tea x6 = 6000 (reduced); subtotal 9000
|
|
||||||
(define
|
|
||||||
cart
|
|
||||||
(list (list "widget" :none 3) (list "tea" :none 6)))
|
|
||||||
|
|
||||||
(define ruleset (list (list :percent "TEN" :standard 1000)))
|
|
||||||
|
|
||||||
;; --- allocation: proportional, sums exactly to the discount ---
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"allocate-even"
|
|
||||||
(allocate-discount pcat cart 300)
|
|
||||||
(list 100 200))
|
|
||||||
(commerce-test
|
|
||||||
"allocate-sums-to-discount"
|
|
||||||
(ct-sum (allocate-discount pcat cart 300))
|
|
||||||
300)
|
|
||||||
|
|
||||||
;; remainder distribution: 100 over (3000,6000)/9000 = (33,66) rem 1 -> (34,66)
|
|
||||||
(commerce-test
|
|
||||||
"allocate-remainder"
|
|
||||||
(allocate-discount pcat cart 100)
|
|
||||||
(list 34 66))
|
|
||||||
(commerce-test
|
|
||||||
"allocate-remainder-sums"
|
|
||||||
(ct-sum (allocate-discount pcat cart 100))
|
|
||||||
100)
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"allocate-zero"
|
|
||||||
(allocate-discount pcat cart 0)
|
|
||||||
(list 0 0))
|
|
||||||
(commerce-test
|
|
||||||
"allocate-empty"
|
|
||||||
(allocate-discount pcat empty-cart 0)
|
|
||||||
(list))
|
|
||||||
|
|
||||||
;; --- net tax vs gross tax ---
|
|
||||||
;; discount = TEN 10% of standard 3000 = 300, allocated (100 200).
|
|
||||||
;; net: widget 2900@20%=580, tea 5800@5%=290 -> net tax 870 (gross was 900).
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"net-quote"
|
|
||||||
(cart-quote-net gctx cart ruleset (list))
|
|
||||||
{:codes (list "TEN") :subtotal 9000 :discount 300 :total 9570 :tax 870})
|
|
||||||
|
|
||||||
;; same cart through the gross policy taxes 900 (the documented default)
|
|
||||||
(commerce-test
|
|
||||||
"gross-quote-for-contrast"
|
|
||||||
(quote-tax (cart-quote gctx cart ruleset (list)))
|
|
||||||
900)
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"net-tax-lower"
|
|
||||||
(quote-tax (cart-quote-net gctx cart ruleset (list)))
|
|
||||||
870)
|
|
||||||
|
|
||||||
;; --- no discount: net policy == gross policy ---
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"no-discount-net-equals-gross"
|
|
||||||
(=
|
|
||||||
(cart-quote-net gctx cart (list) (list))
|
|
||||||
(cart-quote gctx cart (list) (list)))
|
|
||||||
true)
|
|
||||||
|
|
||||||
;; --- empty cart ---
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"net-empty"
|
|
||||||
(cart-quote-net gctx empty-cart ruleset (list))
|
|
||||||
{:codes (list) :subtotal 0 :discount 0 :total 0 :tax 0})
|
|
||||||
@@ -1,74 +0,0 @@
|
|||||||
;; lib/commerce/tests/order.sx — order lifecycle as a flow-on-sx flow.
|
|
||||||
;; Uses (commerce-test name got expected) provided by conformance.sh.
|
|
||||||
;; Builds the (expensive) flow env once; all assertions share it.
|
|
||||||
|
|
||||||
(define env (order-make-env))
|
|
||||||
(define b (persist/mem-backend))
|
|
||||||
(define q1 {:codes (list) :subtotal 1000 :discount 0 :total 1200 :tax 200})
|
|
||||||
|
|
||||||
;; --- happy path: begin suspends at payment ---
|
|
||||||
|
|
||||||
(define id1 (order-begin! env b "O1" 100 q1))
|
|
||||||
|
|
||||||
(commerce-test "begin-status-reserved" (order-status b "O1") :reserved)
|
|
||||||
(commerce-test "begin-waiting-payment" (order-flow-waiting env id1) "payment")
|
|
||||||
(commerce-test "begin-not-yet-paid" (order-paid b "O1") 0)
|
|
||||||
|
|
||||||
;; --- settle: payment webhook drives fulfilment ---
|
|
||||||
|
|
||||||
(define s1 (order-settle! env b id1 "O1" "ref-1" 102 1200))
|
|
||||||
|
|
||||||
(commerce-test "settle-result" s1 :settled)
|
|
||||||
(commerce-test "settle-status-fulfilled" (order-status b "O1") :fulfilled)
|
|
||||||
(commerce-test "settle-flow-done" (order-flow-status env id1) "done")
|
|
||||||
(commerce-test "settle-recon-ok" (order-recon b "O1") :ok)
|
|
||||||
(commerce-test "settle-event-count" (len (order-events b "O1")) 4)
|
|
||||||
|
|
||||||
;; --- webhook replay: a second settle is a no-op ---
|
|
||||||
|
|
||||||
(define s1b (order-settle! env b id1 "O1" "ref-1" 102 1200))
|
|
||||||
|
|
||||||
(commerce-test "replay-already-settled" s1b :already-settled)
|
|
||||||
(commerce-test
|
|
||||||
"replay-no-extra-events"
|
|
||||||
(len (order-events b "O1"))
|
|
||||||
4)
|
|
||||||
(commerce-test "replay-recon-still-ok" (order-recon b "O1") :ok)
|
|
||||||
|
|
||||||
;; --- a second order gets its own flow id and suspends independently ---
|
|
||||||
|
|
||||||
(define id2 (order-begin! env b "O2" 200 q1))
|
|
||||||
|
|
||||||
(commerce-test "second-distinct-id" (not (= id1 id2)) true)
|
|
||||||
(commerce-test
|
|
||||||
"second-waiting-payment"
|
|
||||||
(order-flow-waiting env id2)
|
|
||||||
"payment")
|
|
||||||
(commerce-test "first-unaffected" (order-status b "O1") :fulfilled)
|
|
||||||
|
|
||||||
;; --- durability: a suspended order survives a process restart ---
|
|
||||||
|
|
||||||
(define id3 (order-begin! env b "O3" 300 q1))
|
|
||||||
(commerce-test "pre-restart-waiting" (order-flow-waiting env id3) "payment")
|
|
||||||
|
|
||||||
(define _restart (order-flow-restart! env))
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"post-restart-still-waiting"
|
|
||||||
(order-flow-waiting env id3)
|
|
||||||
"payment")
|
|
||||||
(commerce-test "post-restart-ledger-intact" (order-status b "O3") :reserved)
|
|
||||||
|
|
||||||
(define s3 (order-settle! env b id3 "O3" "ref-3" 302 1200))
|
|
||||||
|
|
||||||
(commerce-test "post-restart-settled" s3 :settled)
|
|
||||||
(commerce-test "post-restart-status" (order-status b "O3") :fulfilled)
|
|
||||||
(commerce-test "post-restart-recon-ok" (order-recon b "O3") :ok)
|
|
||||||
(commerce-test "post-restart-flow-done" (order-flow-status env id3) "done")
|
|
||||||
|
|
||||||
;; --- payment-request envelope (provider-neutral) for the still-suspended O2 ---
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"pending-payments-lists-suspended"
|
|
||||||
(pending-payments env b :GBP "https://shop/return")
|
|
||||||
(list {:id id2 :request {:order "O2" :amount 1200 :return-url "https://shop/return" :currency :GBP}}))
|
|
||||||
@@ -1,43 +0,0 @@
|
|||||||
;; lib/commerce/tests/payment.sx — provider-neutral payment-request envelope.
|
|
||||||
;; Uses (commerce-test name got expected) provided by conformance.sh.
|
|
||||||
;; Envelope construction is ledger-only (no flow env); pending-payments (which
|
|
||||||
;; needs the flow env) is exercised in the order suite.
|
|
||||||
|
|
||||||
(define q1 {:codes (list) :subtotal 1000 :discount 0 :total 1200 :tax 200})
|
|
||||||
(define q2 {:codes (list) :subtotal 5000 :discount 500 :total 4500 :tax 0})
|
|
||||||
|
|
||||||
(define b (persist/mem-backend))
|
|
||||||
(define _c1 (order-create b "P1" 1 q1))
|
|
||||||
(define _c2 (order-create b "P2" 1 q2))
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"envelope"
|
|
||||||
(payment-request b "P1" :GBP "https://shop/return")
|
|
||||||
{:order "P1" :amount 1200 :return-url "https://shop/return" :currency :GBP})
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"envelope-amount"
|
|
||||||
(payment-request-amount (payment-request b "P1" :GBP "x"))
|
|
||||||
1200)
|
|
||||||
(commerce-test
|
|
||||||
"envelope-currency"
|
|
||||||
(payment-request-currency (payment-request b "P1" :GBP "x"))
|
|
||||||
:GBP)
|
|
||||||
(commerce-test
|
|
||||||
"envelope-order"
|
|
||||||
(payment-request-order (payment-request b "P1" :GBP "x"))
|
|
||||||
"P1")
|
|
||||||
(commerce-test
|
|
||||||
"envelope-return-url"
|
|
||||||
(payment-request-return-url (payment-request b "P1" :GBP "https://r"))
|
|
||||||
"https://r")
|
|
||||||
|
|
||||||
;; amount tracks the ledger total, currency is per-call (provider/instance config)
|
|
||||||
(commerce-test
|
|
||||||
"envelope-amount-2"
|
|
||||||
(payment-request-amount (payment-request b "P2" :EUR "x"))
|
|
||||||
4500)
|
|
||||||
(commerce-test
|
|
||||||
"envelope-currency-2"
|
|
||||||
(payment-request-currency (payment-request b "P2" :EUR "x"))
|
|
||||||
:EUR)
|
|
||||||
@@ -1,100 +0,0 @@
|
|||||||
;; lib/commerce/tests/price.sx — subtotal + jurisdiction-relational tax.
|
|
||||||
;; Uses (commerce-test name got expected) provided by conformance.sh.
|
|
||||||
|
|
||||||
(define
|
|
||||||
pcat
|
|
||||||
(make-catalog
|
|
||||||
(list
|
|
||||||
(list "widget" 1000 :standard)
|
|
||||||
(list "book" 800 :zero-rated)
|
|
||||||
(list "tea" 1000 :reduced))
|
|
||||||
(list
|
|
||||||
(list "widget" :small -200)
|
|
||||||
(list "widget" :large 500))
|
|
||||||
(list)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
rules
|
|
||||||
(list
|
|
||||||
(list :uk :standard :guest 2000)
|
|
||||||
(list :uk :reduced :guest 500)
|
|
||||||
(list :uk :zero-rated :guest 0)
|
|
||||||
(list :uk :standard :member 1000)
|
|
||||||
(list :ie :standard :guest 2300)))
|
|
||||||
|
|
||||||
(define gctx (make-pricing-context pcat rules :uk :guest))
|
|
||||||
(define mctx (make-pricing-context pcat rules :uk :member))
|
|
||||||
|
|
||||||
;; --- unit + line pricing ---
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"unit-price-variant"
|
|
||||||
(line-unit-price pcat "widget" :small)
|
|
||||||
800)
|
|
||||||
(commerce-test
|
|
||||||
"unit-price-no-variant"
|
|
||||||
(line-unit-price pcat "widget" :none)
|
|
||||||
1000)
|
|
||||||
(commerce-test "unit-price-unknown" (line-unit-price pcat "ghost" :none) nil)
|
|
||||||
(commerce-test
|
|
||||||
"line-extended"
|
|
||||||
(line-extended pcat (list "widget" :small 2))
|
|
||||||
1600)
|
|
||||||
|
|
||||||
;; --- subtotal ---
|
|
||||||
|
|
||||||
(define
|
|
||||||
cart1
|
|
||||||
(list (list "widget" :small 2) (list "book" :none 1)))
|
|
||||||
|
|
||||||
(commerce-test "subtotal" (cart-subtotal pcat cart1) 2400)
|
|
||||||
(commerce-test "subtotal-empty" (cart-subtotal pcat empty-cart) 0)
|
|
||||||
|
|
||||||
;; --- tax rate lookup (relational, both directions) ---
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"rate-forward"
|
|
||||||
(rate-bps rules :uk :standard :guest)
|
|
||||||
2000)
|
|
||||||
(commerce-test
|
|
||||||
"rate-missing"
|
|
||||||
(rate-bps rules :fr :standard :guest)
|
|
||||||
0)
|
|
||||||
(commerce-test
|
|
||||||
"rate-juris-by-bps-backward"
|
|
||||||
(run* j (fresh (cust) (taxo rules j :standard cust 2300)))
|
|
||||||
(list :ie))
|
|
||||||
(commerce-test
|
|
||||||
"rate-customer-by-bps-backward"
|
|
||||||
(run* cust (taxo rules :uk :standard cust 1000))
|
|
||||||
(list :member))
|
|
||||||
|
|
||||||
;; --- apply-bps rounding (half up, integer only) ---
|
|
||||||
|
|
||||||
(commerce-test "bps-exact" (apply-bps 1600 2000) 320)
|
|
||||||
(commerce-test "bps-round-up" (apply-bps 799 2000) 160)
|
|
||||||
(commerce-test "bps-zero" (apply-bps 800 0) 0)
|
|
||||||
|
|
||||||
;; --- line + cart tax ---
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"line-tax-standard"
|
|
||||||
(line-tax gctx (list "widget" :small 2))
|
|
||||||
320)
|
|
||||||
(commerce-test
|
|
||||||
"line-tax-zero-rated"
|
|
||||||
(line-tax gctx (list "book" :none 1))
|
|
||||||
0)
|
|
||||||
(commerce-test
|
|
||||||
"line-tax-member"
|
|
||||||
(line-tax mctx (list "widget" :small 2))
|
|
||||||
160)
|
|
||||||
(commerce-test "cart-tax-guest" (cart-tax gctx cart1) 320)
|
|
||||||
|
|
||||||
;; --- total dict (deterministic) ---
|
|
||||||
|
|
||||||
(commerce-test "total-guest" (cart-total gctx cart1) {:subtotal 2400 :discounts 0 :total 2720 :tax 320})
|
|
||||||
|
|
||||||
(commerce-test "total-member" (cart-total mctx cart1) {:subtotal 2400 :discounts 0 :total 2560 :tax 160})
|
|
||||||
|
|
||||||
(commerce-test "total-empty" (cart-total gctx empty-cart) {:subtotal 0 :discounts 0 :total 0 :tax 0})
|
|
||||||
@@ -1,142 +0,0 @@
|
|||||||
;; lib/commerce/tests/promo.sx — promo rules + relational enumeration.
|
|
||||||
;; Uses (commerce-test name got expected) provided by conformance.sh.
|
|
||||||
|
|
||||||
(define
|
|
||||||
pcat
|
|
||||||
(make-catalog
|
|
||||||
(list
|
|
||||||
(list "widget" 1000 :standard)
|
|
||||||
(list "book" 800 :zero-rated)
|
|
||||||
(list "tea" 1000 :reduced))
|
|
||||||
(list)
|
|
||||||
(list)))
|
|
||||||
|
|
||||||
(define gctx (make-pricing-context pcat (list) :uk :guest))
|
|
||||||
(define mctx (make-pricing-context pcat (list) :uk :member))
|
|
||||||
|
|
||||||
(define
|
|
||||||
cart
|
|
||||||
(list
|
|
||||||
(list "widget" :none 3)
|
|
||||||
(list "book" :none 1)
|
|
||||||
(list "tea" :none 6)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
ruleset
|
|
||||||
(list
|
|
||||||
(list :percent "TEN" :standard 1000)
|
|
||||||
(list :fixed "FIVER" 5000 500)
|
|
||||||
(list :bundle "B3T" "tea" 3)
|
|
||||||
(list :member "MEM" :standard 1500)))
|
|
||||||
|
|
||||||
;; --- per-type amounts ---
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"percent-amount"
|
|
||||||
(promo-amount gctx cart (list :percent "TEN" :standard 1000))
|
|
||||||
300)
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"fixed-amount-met"
|
|
||||||
(promo-amount gctx cart (list :fixed "FIVER" 5000 500))
|
|
||||||
500)
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"fixed-amount-not-met"
|
|
||||||
(promo-amount
|
|
||||||
gctx
|
|
||||||
(list (list "widget" :none 1))
|
|
||||||
(list :fixed "FIVER" 5000 500))
|
|
||||||
0)
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"fixed-amount-capped"
|
|
||||||
(promo-amount
|
|
||||||
gctx
|
|
||||||
(list (list "book" :none 1))
|
|
||||||
(list :fixed "BIG" 0 9999))
|
|
||||||
800)
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"bundle-amount"
|
|
||||||
(promo-amount gctx cart (list :bundle "B3T" "tea" 3))
|
|
||||||
2000)
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"member-amount-guest"
|
|
||||||
(promo-amount gctx cart (list :member "MEM" :standard 1500))
|
|
||||||
0)
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"member-amount-member"
|
|
||||||
(promo-amount mctx cart (list :member "MEM" :standard 1500))
|
|
||||||
450)
|
|
||||||
|
|
||||||
;; --- relational enumeration: forward ---
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"discounto-all-guest"
|
|
||||||
(run*
|
|
||||||
pair
|
|
||||||
(fresh
|
|
||||||
(code amount)
|
|
||||||
(promo-discounto gctx cart ruleset code amount)
|
|
||||||
(== pair (list code amount))))
|
|
||||||
(list
|
|
||||||
(list "TEN" 300)
|
|
||||||
(list "FIVER" 500)
|
|
||||||
(list "B3T" 2000)
|
|
||||||
(list "MEM" 0)))
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"applicable-guest"
|
|
||||||
(applicable-promos gctx cart ruleset)
|
|
||||||
(list
|
|
||||||
(list "TEN" 300)
|
|
||||||
(list "FIVER" 500)
|
|
||||||
(list "B3T" 2000)))
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"applicable-member"
|
|
||||||
(applicable-promos mctx cart ruleset)
|
|
||||||
(list
|
|
||||||
(list "TEN" 300)
|
|
||||||
(list "FIVER" 500)
|
|
||||||
(list "B3T" 2000)
|
|
||||||
(list "MEM" 450)))
|
|
||||||
|
|
||||||
;; --- relational enumeration: backward (the showcase) ---
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"code-by-discount-2000"
|
|
||||||
(run* code (promo-applieso gctx cart ruleset code 2000))
|
|
||||||
(list "B3T"))
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"code-by-discount-500"
|
|
||||||
(run* code (promo-applieso gctx cart ruleset code 500))
|
|
||||||
(list "FIVER"))
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"code-by-discount-none"
|
|
||||||
(run* code (promo-applieso gctx cart ruleset code 9999))
|
|
||||||
(list))
|
|
||||||
|
|
||||||
;; --- deterministic helpers ---
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"amount-for-ten"
|
|
||||||
(promo-amount-for gctx cart ruleset "TEN")
|
|
||||||
300)
|
|
||||||
(commerce-test
|
|
||||||
"amount-for-mem-guest"
|
|
||||||
(promo-amount-for gctx cart ruleset "MEM")
|
|
||||||
0)
|
|
||||||
(commerce-test
|
|
||||||
"amount-for-mem-member"
|
|
||||||
(promo-amount-for mctx cart ruleset "MEM")
|
|
||||||
450)
|
|
||||||
(commerce-test
|
|
||||||
"amount-for-absent"
|
|
||||||
(promo-amount-for gctx cart ruleset "NOPE")
|
|
||||||
0)
|
|
||||||
@@ -1,108 +0,0 @@
|
|||||||
;; lib/commerce/tests/quote.sx — composed priced quote (price+promo+stacking).
|
|
||||||
;; Uses (commerce-test name got expected) provided by conformance.sh.
|
|
||||||
|
|
||||||
(define
|
|
||||||
pcat
|
|
||||||
(make-catalog
|
|
||||||
(list
|
|
||||||
(list "widget" 1000 :standard)
|
|
||||||
(list "book" 800 :zero-rated)
|
|
||||||
(list "tea" 1000 :reduced))
|
|
||||||
(list)
|
|
||||||
(list)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
tax-rules
|
|
||||||
(list
|
|
||||||
(list :uk :standard :guest 2000)
|
|
||||||
(list :uk :reduced :guest 500)
|
|
||||||
(list :uk :zero-rated :guest 0)
|
|
||||||
(list :uk :standard :member 2000)
|
|
||||||
(list :uk :reduced :member 500)
|
|
||||||
(list :uk :zero-rated :member 0)))
|
|
||||||
|
|
||||||
(define gctx (make-pricing-context pcat tax-rules :uk :guest))
|
|
||||||
(define mctx (make-pricing-context pcat tax-rules :uk :member))
|
|
||||||
|
|
||||||
(define
|
|
||||||
cart
|
|
||||||
(list
|
|
||||||
(list "widget" :none 3)
|
|
||||||
(list "book" :none 1)
|
|
||||||
(list "tea" :none 6)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
ruleset
|
|
||||||
(list
|
|
||||||
(list :percent "TEN" :standard 1000)
|
|
||||||
(list :percent "TWENTY" :standard 2000)
|
|
||||||
(list :fixed "FIVER" 5000 500)
|
|
||||||
(list :bundle "B3T" "tea" 3)
|
|
||||||
(list :member "MEM" :standard 2500)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
exclusions
|
|
||||||
(list (list "TEN" "TWENTY") (list "TEN" "MEM") (list "TWENTY" "MEM")))
|
|
||||||
|
|
||||||
;; subtotal: 3000 + 800 + 6000 = 9800
|
|
||||||
;; tax (gross): widget 600 + tea 300 + book 0 = 900
|
|
||||||
;; guest discount: TWENTY 600 + FIVER 500 + B3T 2000 = 3100
|
|
||||||
;; guest total: 9800 - 3100 + 900 = 7600
|
|
||||||
|
|
||||||
(define gq (cart-quote gctx cart ruleset exclusions))
|
|
||||||
|
|
||||||
(commerce-test "quote-subtotal" (quote-subtotal gq) 9800)
|
|
||||||
(commerce-test "quote-tax" (quote-tax gq) 900)
|
|
||||||
(commerce-test "quote-discount-guest" (quote-discount gq) 3100)
|
|
||||||
(commerce-test "quote-total-guest" (quote-total gq) 7600)
|
|
||||||
(commerce-test
|
|
||||||
"quote-codes-guest"
|
|
||||||
(quote-codes gq)
|
|
||||||
(list "TWENTY" "FIVER" "B3T"))
|
|
||||||
|
|
||||||
(commerce-test "quote-full-guest" gq {:codes (list "TWENTY" "FIVER" "B3T") :subtotal 9800 :discount 3100 :total 7600 :tax 900})
|
|
||||||
|
|
||||||
;; member discount: MEM 750 + FIVER 500 + B3T 2000 = 3250
|
|
||||||
;; member total: 9800 - 3250 + 900 = 7450
|
|
||||||
(define mq (cart-quote mctx cart ruleset exclusions))
|
|
||||||
|
|
||||||
(commerce-test "quote-discount-member" (quote-discount mq) 3250)
|
|
||||||
(commerce-test "quote-total-member" (quote-total mq) 7450)
|
|
||||||
(commerce-test
|
|
||||||
"quote-codes-member"
|
|
||||||
(quote-codes mq)
|
|
||||||
(list "FIVER" "B3T" "MEM"))
|
|
||||||
|
|
||||||
;; --- determinism: same inputs, identical quote ---
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"quote-deterministic"
|
|
||||||
(=
|
|
||||||
(cart-quote gctx cart ruleset exclusions)
|
|
||||||
(cart-quote gctx cart ruleset exclusions))
|
|
||||||
true)
|
|
||||||
|
|
||||||
;; --- no promos: discount 0, total = subtotal + tax ---
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"quote-no-promos"
|
|
||||||
(cart-quote gctx cart (list) (list))
|
|
||||||
{:codes (list) :subtotal 9800 :discount 0 :total 10700 :tax 900})
|
|
||||||
|
|
||||||
;; --- empty cart ---
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"quote-empty"
|
|
||||||
(cart-quote gctx empty-cart ruleset exclusions)
|
|
||||||
{:codes (list) :subtotal 0 :discount 0 :total 0 :tax 0})
|
|
||||||
|
|
||||||
;; --- session convenience ---
|
|
||||||
|
|
||||||
(define
|
|
||||||
sess
|
|
||||||
(commerce-add (commerce-session gctx) "widget" :none 3))
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"session-quote"
|
|
||||||
(quote-total (session-quote sess ruleset exclusions))
|
|
||||||
3000)
|
|
||||||
@@ -1,109 +0,0 @@
|
|||||||
;; lib/commerce/tests/recon.sx — reconciliation as relational ledger queries.
|
|
||||||
;; Uses (commerce-test name got expected) provided by conformance.sh.
|
|
||||||
|
|
||||||
(define q1 {:codes (list) :subtotal 1000 :discount 0 :total 1200 :tax 200})
|
|
||||||
|
|
||||||
(define b (persist/mem-backend))
|
|
||||||
|
|
||||||
;; OK1 — clean payment
|
|
||||||
(define _ok (order-create b "OK1" 1 q1))
|
|
||||||
(define _okp (order-pay b "OK1" "ok-ref" 2 1200))
|
|
||||||
|
|
||||||
;; OVER1 — double charge under two different refs
|
|
||||||
(define _ov (order-create b "OVER1" 1 q1))
|
|
||||||
(define _ova (order-pay b "OVER1" "ov-a" 2 1200))
|
|
||||||
(define _ovb (order-pay b "OVER1" "ov-b" 3 1200))
|
|
||||||
|
|
||||||
;; UNDER1 — short payment
|
|
||||||
(define _un (order-create b "UNDER1" 1 q1))
|
|
||||||
(define _unp (order-pay b "UNDER1" "un-ref" 2 900))
|
|
||||||
|
|
||||||
;; PART1 — paid in full, then partially refunded
|
|
||||||
(define _pa (order-create b "PART1" 1 q1))
|
|
||||||
(define _pap (order-pay b "PART1" "pa-ref" 2 1200))
|
|
||||||
(define _par (order-refund b "PART1" "pa-rf" 3 200))
|
|
||||||
|
|
||||||
;; REPLAY1 — webhook fires twice with the same ref (idempotent)
|
|
||||||
(define _rp (order-create b "REPLAY1" 1 q1))
|
|
||||||
(define _rpa (order-pay b "REPLAY1" "rp-ref" 2 1200))
|
|
||||||
(define _rpb (order-pay b "REPLAY1" "rp-ref" 2 1200))
|
|
||||||
|
|
||||||
;; PEND1 — created, not yet paid
|
|
||||||
(define _pe (order-create b "PEND1" 1 q1))
|
|
||||||
|
|
||||||
;; --- summaries ---
|
|
||||||
|
|
||||||
(commerce-test "summary-count" (len (ledger-summaries b)) 6)
|
|
||||||
(commerce-test
|
|
||||||
"summary-ok1"
|
|
||||||
(order-summary b "order/OK1")
|
|
||||||
(list "order/OK1" 1200 1200 0 1200 :ok))
|
|
||||||
(commerce-test
|
|
||||||
"summary-part1"
|
|
||||||
(order-summary b "order/PART1")
|
|
||||||
(list "order/PART1" 1200 1200 200 1000 :underpaid))
|
|
||||||
|
|
||||||
;; --- forward status query ---
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"status-forward-ok"
|
|
||||||
(run* st (recon-statuso (ledger-summaries b) "order/OK1" st))
|
|
||||||
(list :ok))
|
|
||||||
|
|
||||||
;; --- backward status queries (the showcase) ---
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"settled"
|
|
||||||
(sort (settled-orders b))
|
|
||||||
(sort (list "order/OK1" "order/REPLAY1")))
|
|
||||||
(commerce-test "overpaid" (overpaid-orders b) (list "order/OVER1"))
|
|
||||||
(commerce-test
|
|
||||||
"underpaid"
|
|
||||||
(sort (underpaid-orders b))
|
|
||||||
(sort (list "order/UNDER1" "order/PART1")))
|
|
||||||
(commerce-test "unpaid" (unpaid-orders b) (list "order/PEND1"))
|
|
||||||
(commerce-test
|
|
||||||
"mismatched"
|
|
||||||
(sort (mismatched-orders b))
|
|
||||||
(sort (list "order/OVER1" "order/UNDER1" "order/PART1")))
|
|
||||||
|
|
||||||
;; --- backward net-amount query ---
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"net-1200"
|
|
||||||
(sort (orders-with-net b 1200))
|
|
||||||
(sort (list "order/OK1" "order/REPLAY1")))
|
|
||||||
(commerce-test
|
|
||||||
"net-2400"
|
|
||||||
(orders-with-net b 2400)
|
|
||||||
(list "order/OVER1"))
|
|
||||||
(commerce-test
|
|
||||||
"net-900"
|
|
||||||
(orders-with-net b 900)
|
|
||||||
(list "order/UNDER1"))
|
|
||||||
|
|
||||||
;; --- discrepancy: +1200 (over) - 300 (under) - 200 (refund) = 700 ---
|
|
||||||
|
|
||||||
(commerce-test "discrepancy" (ledger-discrepancy b) 700)
|
|
||||||
|
|
||||||
;; --- double-charge guard ---
|
|
||||||
|
|
||||||
(commerce-test "double-charge-detected" (order-recon b "OVER1") :overpaid)
|
|
||||||
(commerce-test "double-charge-amount" (order-paid b "OVER1") 2400)
|
|
||||||
|
|
||||||
;; --- partial refund ---
|
|
||||||
|
|
||||||
(commerce-test "partial-refund-net" (order-recon b "PART1") :underpaid)
|
|
||||||
(commerce-test
|
|
||||||
"partial-refund-amount"
|
|
||||||
(order-refunded-amount-of (order-events b "PART1"))
|
|
||||||
200)
|
|
||||||
|
|
||||||
;; --- webhook replay: same ref twice records once ---
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"replay-single-event"
|
|
||||||
(len (order-events b "REPLAY1"))
|
|
||||||
2)
|
|
||||||
(commerce-test "replay-paid-once" (order-paid b "REPLAY1") 1200)
|
|
||||||
(commerce-test "replay-settled" (order-recon b "REPLAY1") :ok)
|
|
||||||
@@ -1,78 +0,0 @@
|
|||||||
;; lib/commerce/tests/refund.sx — refund lifecycle as a flow-on-sx flow.
|
|
||||||
;; Uses (commerce-test name got expected) provided by conformance.sh.
|
|
||||||
;; Builds the (expensive) flow env once; all assertions share it.
|
|
||||||
|
|
||||||
(define env (refund-make-env))
|
|
||||||
(define b (persist/mem-backend))
|
|
||||||
(define q1 {:codes (list) :subtotal 1000 :discount 0 :total 1200 :tax 200})
|
|
||||||
|
|
||||||
;; a paid, fulfilled order to refund (set up directly via the ledger)
|
|
||||||
(define _c (order-create b "O1" 1 q1))
|
|
||||||
(define _p (order-pay b "O1" "pay-1" 2 1200))
|
|
||||||
(commerce-test "setup-recon-ok" (order-recon b "O1") :ok)
|
|
||||||
|
|
||||||
;; --- happy path: request -> approve -> settle ---
|
|
||||||
|
|
||||||
(define rid (refund-begin! env b "O1" "rf-1" 10 500))
|
|
||||||
|
|
||||||
(commerce-test "begin-waiting-approve" (order-flow-waiting env rid) "approve")
|
|
||||||
(commerce-test
|
|
||||||
"begin-not-yet-refunded"
|
|
||||||
(order-refunded-amount-of (order-events b "O1"))
|
|
||||||
0)
|
|
||||||
(commerce-test "begin-recon-unchanged" (order-recon b "O1") :ok)
|
|
||||||
|
|
||||||
(define a1 (refund-approve! env rid))
|
|
||||||
(commerce-test "approve-result" a1 :approved)
|
|
||||||
(commerce-test "approve-waiting-settle" (order-flow-waiting env rid) "settle")
|
|
||||||
|
|
||||||
(define s1 (refund-settle! env b rid "O1" "rf-1" 11 500))
|
|
||||||
(commerce-test "settle-result" s1 :settled)
|
|
||||||
(commerce-test "settle-flow-done" (order-flow-status env rid) "done")
|
|
||||||
(commerce-test
|
|
||||||
"settle-refunded-amount"
|
|
||||||
(order-refunded-amount-of (order-events b "O1"))
|
|
||||||
500)
|
|
||||||
;; net 1200 - 500 = 700 < total 1200 -> underpaid (partial refund)
|
|
||||||
(commerce-test "settle-recon-underpaid" (order-recon b "O1") :underpaid)
|
|
||||||
|
|
||||||
;; --- idempotent settle: replayed provider callback is a no-op ---
|
|
||||||
|
|
||||||
(define s1b (refund-settle! env b rid "O1" "rf-1" 11 500))
|
|
||||||
(commerce-test "replay-already-settled" s1b :already-settled)
|
|
||||||
(commerce-test
|
|
||||||
"replay-refunded-once"
|
|
||||||
(order-refunded-amount-of (order-events b "O1"))
|
|
||||||
500)
|
|
||||||
|
|
||||||
;; --- reject path: approval denied, books untouched ---
|
|
||||||
|
|
||||||
(define _c2 (order-create b "O2" 1 q1))
|
|
||||||
(define _p2 (order-pay b "O2" "pay-2" 2 1200))
|
|
||||||
|
|
||||||
(define rid2 (refund-begin! env b "O2" "rf-2" 20 1200))
|
|
||||||
(commerce-test
|
|
||||||
"reject-waiting-approve"
|
|
||||||
(order-flow-waiting env rid2)
|
|
||||||
"approve")
|
|
||||||
|
|
||||||
(define j2 (refund-reject! env b "O2" rid2 21 "policy"))
|
|
||||||
(commerce-test "reject-result" j2 :rejected)
|
|
||||||
(commerce-test "reject-flow-not-waiting" (order-flow-waiting env rid2) nil)
|
|
||||||
(commerce-test
|
|
||||||
"reject-no-refund"
|
|
||||||
(order-refunded-amount-of (order-events b "O2"))
|
|
||||||
0)
|
|
||||||
(commerce-test "reject-recon-ok" (order-recon b "O2") :ok)
|
|
||||||
|
|
||||||
;; settling a rejected/cancelled refund does nothing
|
|
||||||
(define s2 (refund-settle! env b rid2 "O2" "rf-2" 22 1200))
|
|
||||||
(commerce-test "reject-then-settle-noop" s2 :already-settled)
|
|
||||||
(commerce-test
|
|
||||||
"reject-still-no-refund"
|
|
||||||
(order-refunded-amount-of (order-events b "O2"))
|
|
||||||
0)
|
|
||||||
|
|
||||||
;; --- distinct flow ids ---
|
|
||||||
|
|
||||||
(commerce-test "distinct-refund-ids" (not (= rid rid2)) true)
|
|
||||||
@@ -1,127 +0,0 @@
|
|||||||
;; lib/commerce/tests/stack.sx — stacking precedence, exclusivity, best price.
|
|
||||||
;; Uses (commerce-test name got expected) provided by conformance.sh.
|
|
||||||
|
|
||||||
(define
|
|
||||||
pcat
|
|
||||||
(make-catalog
|
|
||||||
(list
|
|
||||||
(list "widget" 1000 :standard)
|
|
||||||
(list "book" 800 :zero-rated)
|
|
||||||
(list "tea" 1000 :reduced))
|
|
||||||
(list)
|
|
||||||
(list)))
|
|
||||||
|
|
||||||
(define gctx (make-pricing-context pcat (list) :uk :guest))
|
|
||||||
(define mctx (make-pricing-context pcat (list) :uk :member))
|
|
||||||
|
|
||||||
(define
|
|
||||||
cart
|
|
||||||
(list
|
|
||||||
(list "widget" :none 3)
|
|
||||||
(list "book" :none 1)
|
|
||||||
(list "tea" :none 6)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
ruleset
|
|
||||||
(list
|
|
||||||
(list :percent "TEN" :standard 1000)
|
|
||||||
(list :percent "TWENTY" :standard 2000)
|
|
||||||
(list :fixed "FIVER" 5000 500)
|
|
||||||
(list :bundle "B3T" "tea" 3)
|
|
||||||
(list :member "MEM" :standard 2500)))
|
|
||||||
|
|
||||||
;; The three standard-class discounts are mutually exclusive.
|
|
||||||
(define
|
|
||||||
exclusions
|
|
||||||
(list (list "TEN" "TWENTY") (list "TEN" "MEM") (list "TWENTY" "MEM")))
|
|
||||||
|
|
||||||
;; --- exclusivity predicates ---
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"excluded-pair-direct"
|
|
||||||
(excluded-pair? exclusions "TEN" "TWENTY")
|
|
||||||
true)
|
|
||||||
(commerce-test
|
|
||||||
"excluded-pair-symmetric"
|
|
||||||
(excluded-pair? exclusions "TWENTY" "TEN")
|
|
||||||
true)
|
|
||||||
(commerce-test
|
|
||||||
"excluded-pair-none"
|
|
||||||
(excluded-pair? exclusions "TEN" "FIVER")
|
|
||||||
false)
|
|
||||||
(commerce-test
|
|
||||||
"compatible-yes"
|
|
||||||
(compatible? exclusions (list "FIVER" "B3T" "TWENTY"))
|
|
||||||
true)
|
|
||||||
(commerce-test
|
|
||||||
"compatible-no"
|
|
||||||
(compatible? exclusions (list "TEN" "TWENTY" "B3T"))
|
|
||||||
false)
|
|
||||||
|
|
||||||
;; --- powerset + valid stackings ---
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"powerset-size"
|
|
||||||
(len (powerset (list 1 2 3 4)))
|
|
||||||
16)
|
|
||||||
|
|
||||||
(define gappl (applicable-promos gctx cart ruleset))
|
|
||||||
|
|
||||||
(commerce-test "applicable-guest-count" (len gappl) 4)
|
|
||||||
|
|
||||||
;; 16 subsets minus the 4 containing both TEN and TWENTY = 12 legal.
|
|
||||||
(commerce-test
|
|
||||||
"valid-stackings-count"
|
|
||||||
(len (valid-stackings exclusions gappl))
|
|
||||||
12)
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"stacking-total"
|
|
||||||
(stacking-total (list (list "TWENTY" 600) (list "B3T" 2000)))
|
|
||||||
2600)
|
|
||||||
|
|
||||||
;; --- best price (deterministic selection) ---
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"best-discount-guest"
|
|
||||||
(best-promo-discount gctx cart ruleset exclusions)
|
|
||||||
3100)
|
|
||||||
(commerce-test
|
|
||||||
"best-codes-guest"
|
|
||||||
(best-promo-codes gctx cart ruleset exclusions)
|
|
||||||
(list "TWENTY" "FIVER" "B3T"))
|
|
||||||
|
|
||||||
;; exclusivity holds: the cheaper conflicting code is dropped.
|
|
||||||
(commerce-test
|
|
||||||
"best-excludes-ten"
|
|
||||||
(some
|
|
||||||
(fn (c) (= c "TEN"))
|
|
||||||
(best-promo-codes gctx cart ruleset exclusions))
|
|
||||||
false)
|
|
||||||
|
|
||||||
;; --- member vs guest ---
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"best-discount-member"
|
|
||||||
(best-promo-discount mctx cart ruleset exclusions)
|
|
||||||
3250)
|
|
||||||
(commerce-test
|
|
||||||
"best-codes-member"
|
|
||||||
(best-promo-codes mctx cart ruleset exclusions)
|
|
||||||
(list "FIVER" "B3T" "MEM"))
|
|
||||||
|
|
||||||
;; --- best price backward query (the showcase) ---
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"stacking-by-total-backward"
|
|
||||||
(run*
|
|
||||||
codes
|
|
||||||
(stacking-by-totalo (valid-stackings exclusions gappl) codes 3100))
|
|
||||||
(list (list "TWENTY" "FIVER" "B3T")))
|
|
||||||
|
|
||||||
;; --- edge: no applicable promos ---
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"best-empty"
|
|
||||||
(best-promo-discount gctx empty-cart ruleset exclusions)
|
|
||||||
0)
|
|
||||||
@@ -1,122 +0,0 @@
|
|||||||
;; lib/commerce/tests/stock.sx — stock-constrained reservation.
|
|
||||||
;; Uses (commerce-test name got expected) provided by conformance.sh.
|
|
||||||
|
|
||||||
(define
|
|
||||||
cat
|
|
||||||
(make-catalog
|
|
||||||
(list
|
|
||||||
(list "widget" 1000 :standard)
|
|
||||||
(list "gadget" 2500 :standard))
|
|
||||||
(list)
|
|
||||||
(list
|
|
||||||
(list "widget" :small 5)
|
|
||||||
(list "widget" :large 0)
|
|
||||||
(list "gadget" :std 12))))
|
|
||||||
|
|
||||||
;; --- availability ---
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"available-found"
|
|
||||||
(available-stock cat "widget" :small)
|
|
||||||
5)
|
|
||||||
(commerce-test
|
|
||||||
"available-zero"
|
|
||||||
(available-stock cat "widget" :large)
|
|
||||||
0)
|
|
||||||
(commerce-test
|
|
||||||
"available-absent"
|
|
||||||
(available-stock cat "widget" :none)
|
|
||||||
0)
|
|
||||||
|
|
||||||
;; --- per-line reservability ---
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"shortfall-fits"
|
|
||||||
(line-shortfall cat (list "widget" :small 5))
|
|
||||||
0)
|
|
||||||
(commerce-test
|
|
||||||
"shortfall-over"
|
|
||||||
(line-shortfall cat (list "widget" :small 8))
|
|
||||||
3)
|
|
||||||
(commerce-test
|
|
||||||
"reservable-yes"
|
|
||||||
(line-reservable? cat (list "gadget" :std 12))
|
|
||||||
true)
|
|
||||||
(commerce-test
|
|
||||||
"reservable-no"
|
|
||||||
(line-reservable? cat (list "widget" :large 1))
|
|
||||||
false)
|
|
||||||
|
|
||||||
;; --- cart-level reservation check ---
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"can-reserve-yes"
|
|
||||||
(can-reserve?
|
|
||||||
cat
|
|
||||||
(list (list "widget" :small 5) (list "gadget" :std 2)))
|
|
||||||
true)
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"can-reserve-no"
|
|
||||||
(can-reserve? cat (list (list "widget" :small 9)))
|
|
||||||
false)
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"shortfalls-detail"
|
|
||||||
(reservation-shortfalls
|
|
||||||
cat
|
|
||||||
(list (list "widget" :small 9) (list "gadget" :std 2)))
|
|
||||||
(list {:requested 9 :available 5 :sku "widget" :variant :small :short 4}))
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"reserve-check-ok"
|
|
||||||
(reserve-check cat (list (list "gadget" :std 1)))
|
|
||||||
:ok)
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"reserve-check-rejected"
|
|
||||||
(reserve-check cat (list (list "widget" :large 1)))
|
|
||||||
{:shortfalls (list {:requested 1 :available 0 :sku "widget" :variant :large :short 1}) :rejected :insufficient-stock})
|
|
||||||
|
|
||||||
;; --- reservation view: concurrent holds reduce availability ---
|
|
||||||
|
|
||||||
(define held (list (list "widget" :small 3)))
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"effective-after-hold"
|
|
||||||
(effective-available cat held "widget" :small)
|
|
||||||
2)
|
|
||||||
(commerce-test
|
|
||||||
"effective-other-unaffected"
|
|
||||||
(effective-available cat held "gadget" :std)
|
|
||||||
12)
|
|
||||||
(commerce-test
|
|
||||||
"reservable-with-fits"
|
|
||||||
(line-reservable-with? cat held (list "widget" :small 2))
|
|
||||||
true)
|
|
||||||
(commerce-test
|
|
||||||
"reservable-with-over"
|
|
||||||
(line-reservable-with? cat held (list "widget" :small 3))
|
|
||||||
false)
|
|
||||||
|
|
||||||
;; --- relational availability query (multidirectional) ---
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"sufficient-forward"
|
|
||||||
(run*
|
|
||||||
x
|
|
||||||
(fresh () (sufficient-stocko cat "widget" :small 5) (== x true)))
|
|
||||||
(list true))
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"sufficient-forward-over"
|
|
||||||
(run*
|
|
||||||
x
|
|
||||||
(fresh () (sufficient-stocko cat "widget" :small 6) (== x true)))
|
|
||||||
(list))
|
|
||||||
|
|
||||||
;; backward: which variants of widget can supply 1 unit?
|
|
||||||
(commerce-test
|
|
||||||
"variants-supplying-1"
|
|
||||||
(run* v (fresh (q) (stocko cat "widget" v q) (lteo-i 1 q)))
|
|
||||||
(list :small))
|
|
||||||
@@ -1,112 +0,0 @@
|
|||||||
;; lib/commerce/tests/window.sx — time-windowed promotions.
|
|
||||||
;; Uses (commerce-test name got expected) provided by conformance.sh.
|
|
||||||
|
|
||||||
(define
|
|
||||||
pcat
|
|
||||||
(make-catalog (list (list "widget" 1000 :standard)) (list) (list)))
|
|
||||||
|
|
||||||
(define gctx (make-pricing-context pcat (list) :uk :guest))
|
|
||||||
(define cart (list (list "widget" :none 3)))
|
|
||||||
|
|
||||||
(define ten (list :percent "TEN" :standard 1000))
|
|
||||||
(define twenty (list :percent "TWENTY" :standard 2000))
|
|
||||||
(define always (list :fixed "ALWAYS" 0 100))
|
|
||||||
|
|
||||||
(define
|
|
||||||
windowed
|
|
||||||
(list
|
|
||||||
(windowed-promo ten 100 200)
|
|
||||||
(windowed-promo twenty 150 300)
|
|
||||||
(windowed-promo always nil nil)))
|
|
||||||
|
|
||||||
(define exclusions (list (list "TEN" "TWENTY")))
|
|
||||||
|
|
||||||
;; --- wp-active? boundaries (inclusive) ---
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"active-at-from"
|
|
||||||
(wp-active? (windowed-promo ten 100 200) 100)
|
|
||||||
true)
|
|
||||||
(commerce-test
|
|
||||||
"active-at-until"
|
|
||||||
(wp-active? (windowed-promo ten 100 200) 200)
|
|
||||||
true)
|
|
||||||
(commerce-test
|
|
||||||
"inactive-before"
|
|
||||||
(wp-active? (windowed-promo ten 100 200) 99)
|
|
||||||
false)
|
|
||||||
(commerce-test
|
|
||||||
"inactive-after"
|
|
||||||
(wp-active? (windowed-promo ten 100 200) 201)
|
|
||||||
false)
|
|
||||||
(commerce-test
|
|
||||||
"open-ended-always"
|
|
||||||
(wp-active? (windowed-promo always nil nil) 99999)
|
|
||||||
true)
|
|
||||||
(commerce-test
|
|
||||||
"open-lower"
|
|
||||||
(wp-active? (windowed-promo ten nil 200) 1)
|
|
||||||
true)
|
|
||||||
(commerce-test
|
|
||||||
"open-upper"
|
|
||||||
(wp-active? (windowed-promo ten 100 nil) 99999)
|
|
||||||
true)
|
|
||||||
|
|
||||||
;; --- active-ruleset filtering ---
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"active-ruleset-120"
|
|
||||||
(active-ruleset windowed 120)
|
|
||||||
(list ten always))
|
|
||||||
(commerce-test
|
|
||||||
"active-ruleset-160"
|
|
||||||
(active-ruleset windowed 160)
|
|
||||||
(list ten twenty always))
|
|
||||||
(commerce-test
|
|
||||||
"active-ruleset-250"
|
|
||||||
(active-ruleset windowed 250)
|
|
||||||
(list twenty always))
|
|
||||||
(commerce-test
|
|
||||||
"active-ruleset-50"
|
|
||||||
(active-ruleset windowed 50)
|
|
||||||
(list always))
|
|
||||||
|
|
||||||
;; --- active-codes (backward query) ---
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"active-codes-120"
|
|
||||||
(active-codes windowed 120)
|
|
||||||
(list "TEN" "ALWAYS"))
|
|
||||||
(commerce-test
|
|
||||||
"active-codes-160"
|
|
||||||
(active-codes windowed 160)
|
|
||||||
(list "TEN" "TWENTY" "ALWAYS"))
|
|
||||||
(commerce-test
|
|
||||||
"active-codes-50"
|
|
||||||
(active-codes windowed 50)
|
|
||||||
(list "ALWAYS"))
|
|
||||||
|
|
||||||
;; --- windowed-quote: discount changes with time (deterministic) ---
|
|
||||||
;; subtotal 3000, no tax. TEN=300, TWENTY=600, ALWAYS=100; TEN/TWENTY exclusive.
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"quote-50"
|
|
||||||
(quote-discount (windowed-quote gctx cart windowed exclusions 50))
|
|
||||||
100)
|
|
||||||
(commerce-test
|
|
||||||
"quote-120"
|
|
||||||
(quote-discount (windowed-quote gctx cart windowed exclusions 120))
|
|
||||||
400)
|
|
||||||
(commerce-test
|
|
||||||
"quote-160"
|
|
||||||
(quote-discount (windowed-quote gctx cart windowed exclusions 160))
|
|
||||||
700)
|
|
||||||
(commerce-test
|
|
||||||
"quote-250"
|
|
||||||
(quote-discount (windowed-quote gctx cart windowed exclusions 250))
|
|
||||||
700)
|
|
||||||
|
|
||||||
(commerce-test
|
|
||||||
"quote-total-160"
|
|
||||||
(quote-total (windowed-quote gctx cart windowed exclusions 160))
|
|
||||||
2300)
|
|
||||||
@@ -1,55 +0,0 @@
|
|||||||
;; lib/commerce/window.sx — time-windowed promotions.
|
|
||||||
;;
|
|
||||||
;; A promo's validity window is kept SEPARATE from the promo tuple (so promo.sx
|
|
||||||
;; is untouched): a windowed promo is (list promo from until) with inclusive
|
|
||||||
;; integer timestamps (same time model as the ledger `at`). nil from = no lower
|
|
||||||
;; bound; nil until = open-ended.
|
|
||||||
;;
|
|
||||||
;; `active-ruleset` filters a windowed ruleset to the plain promos live at a
|
|
||||||
;; given time, which feeds straight into promo/stack/quote — so a datetime-aware
|
|
||||||
;; quote is just the existing pipeline over the active set. Deterministic: the
|
|
||||||
;; quote is a pure function of (ctx, cart, windowed-ruleset, exclusions, at).
|
|
||||||
|
|
||||||
(define windowed-promo (fn (promo from until) (list promo from until)))
|
|
||||||
|
|
||||||
(define wp-promo (fn (wp) (nth wp 0)))
|
|
||||||
(define wp-from (fn (wp) (nth wp 1)))
|
|
||||||
(define wp-until (fn (wp) (nth wp 2)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
wp-active?
|
|
||||||
(fn
|
|
||||||
(wp at)
|
|
||||||
(let
|
|
||||||
((from (wp-from wp)) (until (wp-until wp)))
|
|
||||||
(and (or (nil? from) (>= at from)) (or (nil? until) (<= at until))))))
|
|
||||||
|
|
||||||
;; Plain promo tuples live at time `at` — feed into cart-quote / best-promo-*.
|
|
||||||
(define
|
|
||||||
active-ruleset
|
|
||||||
(fn
|
|
||||||
(windowed at)
|
|
||||||
(map wp-promo (filter (fn (wp) (wp-active? wp at)) windowed))))
|
|
||||||
|
|
||||||
;; Relation: which promo codes are active at `at`? (backward query)
|
|
||||||
(define
|
|
||||||
active-promoo
|
|
||||||
(fn
|
|
||||||
(windowed at code)
|
|
||||||
(fresh
|
|
||||||
(wp)
|
|
||||||
(membero wp windowed)
|
|
||||||
(project
|
|
||||||
(wp)
|
|
||||||
(if (wp-active? wp at) (== code (promo-code (wp-promo wp))) fail)))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
active-codes
|
|
||||||
(fn (windowed at) (run* code (active-promoo windowed at code))))
|
|
||||||
|
|
||||||
;; Datetime-aware quote: the existing pipeline over the time-active ruleset.
|
|
||||||
(define
|
|
||||||
windowed-quote
|
|
||||||
(fn
|
|
||||||
(ctx cart windowed exclusions at)
|
|
||||||
(cart-quote ctx cart (active-ruleset windowed at) exclusions)))
|
|
||||||
@@ -1,67 +0,0 @@
|
|||||||
# Common-Lisp-on-SX conformance config — sourced by lib/guest/conformance.sh.
|
|
||||||
#
|
|
||||||
# CL suites run their tests at *load* time, mutating per-suite global counters
|
|
||||||
# (different variable names per suite), and each suite needs a different
|
|
||||||
# preload chain. Both are expressed via the extended MODE=counters SUITES
|
|
||||||
# format: "name:file:pass-var:fail-var:extra-preload ...".
|
|
||||||
|
|
||||||
LANG_NAME=common-lisp
|
|
||||||
MODE=counters
|
|
||||||
# No global counter defaults — every suite names its own pair below.
|
|
||||||
COUNTERS_PASS=
|
|
||||||
COUNTERS_FAIL=
|
|
||||||
TIMEOUT_PER_SUITE=180
|
|
||||||
|
|
||||||
# Base preloads common to every suite (loaded before each suite's own chain).
|
|
||||||
PRELOADS=(
|
|
||||||
spec/stdlib.sx
|
|
||||||
lib/guest/prefix.sx
|
|
||||||
)
|
|
||||||
|
|
||||||
# name:file:pass-var:fail-var:extra-preloads(space-separated)
|
|
||||||
SUITES=(
|
|
||||||
"read:lib/common-lisp/tests/read.sx:cl-test-pass:cl-test-fail:lib/common-lisp/reader.sx"
|
|
||||||
"lambda:lib/common-lisp/tests/lambda.sx:cl-test-pass:cl-test-fail:lib/common-lisp/reader.sx lib/common-lisp/parser.sx"
|
|
||||||
"eval:lib/common-lisp/tests/eval.sx:cl-test-pass:cl-test-fail:lib/common-lisp/reader.sx lib/common-lisp/parser.sx lib/common-lisp/eval.sx"
|
|
||||||
"conditions:lib/common-lisp/tests/conditions.sx:passed:failed:lib/common-lisp/runtime.sx"
|
|
||||||
"restart-demo:lib/common-lisp/tests/programs/restart-demo.sx:demo-passed:demo-failed:lib/common-lisp/runtime.sx"
|
|
||||||
"parse-recover:lib/common-lisp/tests/programs/parse-recover.sx:parse-passed:parse-failed:lib/common-lisp/runtime.sx"
|
|
||||||
"interactive-debugger:lib/common-lisp/tests/programs/interactive-debugger.sx:debugger-passed:debugger-failed:lib/common-lisp/runtime.sx"
|
|
||||||
"clos:lib/common-lisp/tests/clos.sx:passed:failed:lib/common-lisp/runtime.sx lib/common-lisp/clos.sx"
|
|
||||||
"geometry:lib/common-lisp/tests/programs/geometry.sx:geo-passed:geo-failed:lib/common-lisp/runtime.sx lib/common-lisp/clos.sx"
|
|
||||||
"mop-trace:lib/common-lisp/tests/programs/mop-trace.sx:mop-passed:mop-failed:lib/common-lisp/runtime.sx lib/common-lisp/clos.sx"
|
|
||||||
"macros:lib/common-lisp/tests/macros.sx:macro-passed:macro-failed:lib/common-lisp/reader.sx lib/common-lisp/parser.sx lib/common-lisp/eval.sx lib/common-lisp/loop.sx"
|
|
||||||
"stdlib:lib/common-lisp/tests/stdlib.sx:stdlib-passed:stdlib-failed:lib/common-lisp/reader.sx lib/common-lisp/parser.sx lib/common-lisp/eval.sx"
|
|
||||||
)
|
|
||||||
|
|
||||||
# Preserve the historical scoreboard schema (total_pass/total_fail, suites with
|
|
||||||
# name/pass/fail) so any consumer of lib/common-lisp/scoreboard.json keeps working.
|
|
||||||
emit_scoreboard_json() {
|
|
||||||
local n=${#GC_NAMES[@]} i
|
|
||||||
printf '{\n'
|
|
||||||
printf ' "generated": "%s",\n' "$(date -u +%Y-%m-%dT%H:%M:%SZ)"
|
|
||||||
printf ' "total_pass": %d,\n' "$GC_TOTAL_PASS"
|
|
||||||
printf ' "total_fail": %d,\n' "$GC_TOTAL_FAIL"
|
|
||||||
printf ' "suites": [\n'
|
|
||||||
for ((i=0; i<n; i++)); do
|
|
||||||
[ "$i" -gt 0 ] && printf ',\n'
|
|
||||||
printf ' {"name": "%s", "pass": %d, "fail": %d}' \
|
|
||||||
"${GC_NAMES[$i]}" "${GC_PASS[$i]}" "${GC_FAIL[$i]}"
|
|
||||||
done
|
|
||||||
printf '\n ]\n'
|
|
||||||
printf '}\n'
|
|
||||||
}
|
|
||||||
|
|
||||||
emit_scoreboard_md() {
|
|
||||||
local n=${#GC_NAMES[@]} i p f status
|
|
||||||
printf '# Common Lisp on SX — Scoreboard\n\n'
|
|
||||||
printf '_Generated: %s_\n\n' "$(date -u '+%Y-%m-%d %H:%M UTC')"
|
|
||||||
printf '| Suite | Pass | Fail | Status |\n'
|
|
||||||
printf '|-------|------|------|--------|\n'
|
|
||||||
for ((i=0; i<n; i++)); do
|
|
||||||
p="${GC_PASS[$i]}"; f="${GC_FAIL[$i]}"
|
|
||||||
if [ "$f" = "0" ] && [ "${p:-0}" -gt 0 ] 2>/dev/null; then status="pass"; else status="FAIL"; fi
|
|
||||||
printf '| %s | %s | %s | %s |\n' "${GC_NAMES[$i]}" "$p" "$f" "$status"
|
|
||||||
done
|
|
||||||
printf '\n**Total: %d passed, %d failed**\n' "$GC_TOTAL_PASS" "$GC_TOTAL_FAIL"
|
|
||||||
}
|
|
||||||
@@ -1,3 +1,161 @@
|
|||||||
#!/usr/bin/env bash
|
#!/usr/bin/env bash
|
||||||
# Thin wrapper — see lib/guest/conformance.sh and lib/common-lisp/conformance.conf.
|
# lib/common-lisp/conformance.sh — CL-on-SX conformance test runner
|
||||||
exec bash "$(dirname "$0")/../guest/conformance.sh" "$(dirname "$0")/conformance.conf" "$@"
|
#
|
||||||
|
# Runs all Common Lisp test suites and writes scoreboard.json + scoreboard.md.
|
||||||
|
#
|
||||||
|
# Usage:
|
||||||
|
# bash lib/common-lisp/conformance.sh
|
||||||
|
# bash lib/common-lisp/conformance.sh -v
|
||||||
|
|
||||||
|
set -uo pipefail
|
||||||
|
cd "$(git rev-parse --show-toplevel)"
|
||||||
|
|
||||||
|
SX_SERVER="${SX_SERVER:-hosts/ocaml/_build/default/bin/sx_server.exe}"
|
||||||
|
if [ ! -x "$SX_SERVER" ]; then
|
||||||
|
SX_SERVER="/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe"
|
||||||
|
fi
|
||||||
|
if [ ! -x "$SX_SERVER" ]; then
|
||||||
|
echo "ERROR: sx_server.exe not found."
|
||||||
|
exit 1
|
||||||
|
fi
|
||||||
|
|
||||||
|
VERBOSE="${1:-}"
|
||||||
|
TOTAL_PASS=0; TOTAL_FAIL=0
|
||||||
|
SUITE_NAMES=()
|
||||||
|
SUITE_PASS=()
|
||||||
|
SUITE_FAIL=()
|
||||||
|
|
||||||
|
# run_suite NAME "file1 file2 ..." PASS_VAR FAIL_VAR FAILURES_VAR
|
||||||
|
run_suite() {
|
||||||
|
local name="$1" load_files="$2" pass_var="$3" fail_var="$4" failures_var="$5"
|
||||||
|
local TMP; TMP=$(mktemp)
|
||||||
|
{
|
||||||
|
printf '(epoch 1)\n(load "spec/stdlib.sx")\n(load "lib/guest/prefix.sx")\n'
|
||||||
|
local i=2
|
||||||
|
for f in $load_files; do
|
||||||
|
printf '(epoch %d)\n(load "%s")\n' "$i" "$f"
|
||||||
|
i=$((i+1))
|
||||||
|
done
|
||||||
|
printf '(epoch 100)\n(eval "%s")\n' "$pass_var"
|
||||||
|
printf '(epoch 101)\n(eval "%s")\n' "$fail_var"
|
||||||
|
} > "$TMP"
|
||||||
|
local OUT; OUT=$(timeout 30 "$SX_SERVER" < "$TMP" 2>/dev/null)
|
||||||
|
rm -f "$TMP"
|
||||||
|
local P F
|
||||||
|
P=$(echo "$OUT" | grep -A1 "^(ok-len 100 " | tail -1 | tr -d ' ()' || true)
|
||||||
|
F=$(echo "$OUT" | grep -A1 "^(ok-len 101 " | tail -1 | tr -d ' ()' || true)
|
||||||
|
# Also try plain (ok 100 N) format
|
||||||
|
[ -z "$P" ] && P=$(echo "$OUT" | grep "^(ok 100 " | awk '{print $3}' | tr -d ')' || true)
|
||||||
|
[ -z "$F" ] && F=$(echo "$OUT" | grep "^(ok 101 " | awk '{print $3}' | tr -d ')' || true)
|
||||||
|
[ -z "$P" ] && P=0; [ -z "$F" ] && F=0
|
||||||
|
SUITE_NAMES+=("$name")
|
||||||
|
SUITE_PASS+=("$P")
|
||||||
|
SUITE_FAIL+=("$F")
|
||||||
|
TOTAL_PASS=$((TOTAL_PASS + P))
|
||||||
|
TOTAL_FAIL=$((TOTAL_FAIL + F))
|
||||||
|
if [ "$F" = "0" ] && [ "${P:-0}" -gt 0 ] 2>/dev/null; then
|
||||||
|
echo " PASS $name ($P tests)"
|
||||||
|
else
|
||||||
|
echo " FAIL $name ($P passed, $F failed)"
|
||||||
|
fi
|
||||||
|
}
|
||||||
|
|
||||||
|
echo "=== Common Lisp on SX — Conformance Run ==="
|
||||||
|
echo ""
|
||||||
|
|
||||||
|
run_suite "Phase 1: tokenizer/reader" \
|
||||||
|
"lib/common-lisp/reader.sx lib/common-lisp/tests/read.sx" \
|
||||||
|
"cl-test-pass" "cl-test-fail" "cl-test-fails"
|
||||||
|
|
||||||
|
run_suite "Phase 1: parser/lambda-lists" \
|
||||||
|
"lib/common-lisp/reader.sx lib/common-lisp/parser.sx lib/common-lisp/tests/lambda.sx" \
|
||||||
|
"cl-test-pass" "cl-test-fail" "cl-test-fails"
|
||||||
|
|
||||||
|
run_suite "Phase 2: evaluator" \
|
||||||
|
"lib/common-lisp/reader.sx lib/common-lisp/parser.sx lib/common-lisp/eval.sx lib/common-lisp/tests/eval.sx" \
|
||||||
|
"cl-test-pass" "cl-test-fail" "cl-test-fails"
|
||||||
|
|
||||||
|
run_suite "Phase 3: condition system" \
|
||||||
|
"lib/common-lisp/runtime.sx lib/common-lisp/tests/conditions.sx" \
|
||||||
|
"passed" "failed" "failures"
|
||||||
|
|
||||||
|
run_suite "Phase 3: restart-demo" \
|
||||||
|
"lib/common-lisp/runtime.sx lib/common-lisp/tests/programs/restart-demo.sx" \
|
||||||
|
"demo-passed" "demo-failed" "demo-failures"
|
||||||
|
|
||||||
|
run_suite "Phase 3: parse-recover" \
|
||||||
|
"lib/common-lisp/runtime.sx lib/common-lisp/tests/programs/parse-recover.sx" \
|
||||||
|
"parse-passed" "parse-failed" "parse-failures"
|
||||||
|
|
||||||
|
run_suite "Phase 3: interactive-debugger" \
|
||||||
|
"lib/common-lisp/runtime.sx lib/common-lisp/tests/programs/interactive-debugger.sx" \
|
||||||
|
"debugger-passed" "debugger-failed" "debugger-failures"
|
||||||
|
|
||||||
|
run_suite "Phase 4: CLOS" \
|
||||||
|
"lib/common-lisp/runtime.sx lib/common-lisp/clos.sx lib/common-lisp/tests/clos.sx" \
|
||||||
|
"passed" "failed" "failures"
|
||||||
|
|
||||||
|
run_suite "Phase 4: geometry" \
|
||||||
|
"lib/common-lisp/runtime.sx lib/common-lisp/clos.sx lib/common-lisp/tests/programs/geometry.sx" \
|
||||||
|
"geo-passed" "geo-failed" "geo-failures"
|
||||||
|
|
||||||
|
run_suite "Phase 4: mop-trace" \
|
||||||
|
"lib/common-lisp/runtime.sx lib/common-lisp/clos.sx lib/common-lisp/tests/programs/mop-trace.sx" \
|
||||||
|
"mop-passed" "mop-failed" "mop-failures"
|
||||||
|
|
||||||
|
run_suite "Phase 5: macros+LOOP" \
|
||||||
|
"lib/common-lisp/reader.sx lib/common-lisp/parser.sx lib/common-lisp/eval.sx lib/common-lisp/loop.sx lib/common-lisp/tests/macros.sx" \
|
||||||
|
"macro-passed" "macro-failed" "macro-failures"
|
||||||
|
|
||||||
|
run_suite "Phase 6: stdlib" \
|
||||||
|
"lib/common-lisp/reader.sx lib/common-lisp/parser.sx lib/common-lisp/eval.sx lib/common-lisp/tests/stdlib.sx" \
|
||||||
|
"stdlib-passed" "stdlib-failed" "stdlib-failures"
|
||||||
|
|
||||||
|
echo ""
|
||||||
|
echo "=== Total: $TOTAL_PASS passed, $TOTAL_FAIL failed ==="
|
||||||
|
|
||||||
|
# ── write scoreboard.json ─────────────────────────────────────────────────
|
||||||
|
|
||||||
|
SCORE_DIR="lib/common-lisp"
|
||||||
|
JSON="$SCORE_DIR/scoreboard.json"
|
||||||
|
{
|
||||||
|
printf '{\n'
|
||||||
|
printf ' "generated": "%s",\n' "$(date -u +%Y-%m-%dT%H:%M:%SZ)"
|
||||||
|
printf ' "total_pass": %d,\n' "$TOTAL_PASS"
|
||||||
|
printf ' "total_fail": %d,\n' "$TOTAL_FAIL"
|
||||||
|
printf ' "suites": [\n'
|
||||||
|
first=true
|
||||||
|
for i in "${!SUITE_NAMES[@]}"; do
|
||||||
|
if [ "$first" = "true" ]; then first=false; else printf ',\n'; fi
|
||||||
|
printf ' {"name": "%s", "pass": %d, "fail": %d}' \
|
||||||
|
"${SUITE_NAMES[$i]}" "${SUITE_PASS[$i]}" "${SUITE_FAIL[$i]}"
|
||||||
|
done
|
||||||
|
printf '\n ]\n'
|
||||||
|
printf '}\n'
|
||||||
|
} > "$JSON"
|
||||||
|
|
||||||
|
# ── write scoreboard.md ───────────────────────────────────────────────────
|
||||||
|
|
||||||
|
MD="$SCORE_DIR/scoreboard.md"
|
||||||
|
{
|
||||||
|
printf '# Common Lisp on SX — Scoreboard\n\n'
|
||||||
|
printf '_Generated: %s_\n\n' "$(date -u '+%Y-%m-%d %H:%M UTC')"
|
||||||
|
printf '| Suite | Pass | Fail | Status |\n'
|
||||||
|
printf '|-------|------|------|--------|\n'
|
||||||
|
for i in "${!SUITE_NAMES[@]}"; do
|
||||||
|
p="${SUITE_PASS[$i]}" f="${SUITE_FAIL[$i]}"
|
||||||
|
status=""
|
||||||
|
if [ "$f" = "0" ] && [ "${p:-0}" -gt 0 ] 2>/dev/null; then
|
||||||
|
status="pass"
|
||||||
|
else
|
||||||
|
status="FAIL"
|
||||||
|
fi
|
||||||
|
printf '| %s | %s | %s | %s |\n' "${SUITE_NAMES[$i]}" "$p" "$f" "$status"
|
||||||
|
done
|
||||||
|
printf '\n**Total: %d passed, %d failed**\n' "$TOTAL_PASS" "$TOTAL_FAIL"
|
||||||
|
} > "$MD"
|
||||||
|
|
||||||
|
echo ""
|
||||||
|
echo "Scoreboard written to $JSON and $MD"
|
||||||
|
|
||||||
|
[ "$TOTAL_FAIL" -eq 0 ]
|
||||||
|
|||||||
@@ -1,19 +1,19 @@
|
|||||||
{
|
{
|
||||||
"generated": "2026-06-07T09:35:38Z",
|
"generated": "2026-05-06T22:55:42Z",
|
||||||
"total_pass": 487,
|
"total_pass": 518,
|
||||||
"total_fail": 0,
|
"total_fail": 0,
|
||||||
"suites": [
|
"suites": [
|
||||||
{"name": "read", "pass": 79, "fail": 0},
|
{"name": "Phase 1: tokenizer/reader", "pass": 79, "fail": 0},
|
||||||
{"name": "lambda", "pass": 31, "fail": 0},
|
{"name": "Phase 1: parser/lambda-lists", "pass": 31, "fail": 0},
|
||||||
{"name": "eval", "pass": 182, "fail": 0},
|
{"name": "Phase 2: evaluator", "pass": 182, "fail": 0},
|
||||||
{"name": "conditions", "pass": 59, "fail": 0},
|
{"name": "Phase 3: condition system", "pass": 59, "fail": 0},
|
||||||
{"name": "restart-demo", "pass": 7, "fail": 0},
|
{"name": "Phase 3: restart-demo", "pass": 7, "fail": 0},
|
||||||
{"name": "parse-recover", "pass": 6, "fail": 0},
|
{"name": "Phase 3: parse-recover", "pass": 6, "fail": 0},
|
||||||
{"name": "interactive-debugger", "pass": 7, "fail": 0},
|
{"name": "Phase 3: interactive-debugger", "pass": 7, "fail": 0},
|
||||||
{"name": "clos", "pass": 35, "fail": 0},
|
{"name": "Phase 4: CLOS", "pass": 41, "fail": 0},
|
||||||
{"name": "geometry", "pass": 0, "fail": 0},
|
{"name": "Phase 4: geometry", "pass": 12, "fail": 0},
|
||||||
{"name": "mop-trace", "pass": 0, "fail": 0},
|
{"name": "Phase 4: mop-trace", "pass": 13, "fail": 0},
|
||||||
{"name": "macros", "pass": 27, "fail": 0},
|
{"name": "Phase 5: macros+LOOP", "pass": 27, "fail": 0},
|
||||||
{"name": "stdlib", "pass": 54, "fail": 0}
|
{"name": "Phase 6: stdlib", "pass": 54, "fail": 0}
|
||||||
]
|
]
|
||||||
}
|
}
|
||||||
|
|||||||
@@ -1,20 +1,20 @@
|
|||||||
# Common Lisp on SX — Scoreboard
|
# Common Lisp on SX — Scoreboard
|
||||||
|
|
||||||
_Generated: 2026-06-07 09:35 UTC_
|
_Generated: 2026-05-06 22:55 UTC_
|
||||||
|
|
||||||
| Suite | Pass | Fail | Status |
|
| Suite | Pass | Fail | Status |
|
||||||
|-------|------|------|--------|
|
|-------|------|------|--------|
|
||||||
| read | 79 | 0 | pass |
|
| Phase 1: tokenizer/reader | 79 | 0 | pass |
|
||||||
| lambda | 31 | 0 | pass |
|
| Phase 1: parser/lambda-lists | 31 | 0 | pass |
|
||||||
| eval | 182 | 0 | pass |
|
| Phase 2: evaluator | 182 | 0 | pass |
|
||||||
| conditions | 59 | 0 | pass |
|
| Phase 3: condition system | 59 | 0 | pass |
|
||||||
| restart-demo | 7 | 0 | pass |
|
| Phase 3: restart-demo | 7 | 0 | pass |
|
||||||
| parse-recover | 6 | 0 | pass |
|
| Phase 3: parse-recover | 6 | 0 | pass |
|
||||||
| interactive-debugger | 7 | 0 | pass |
|
| Phase 3: interactive-debugger | 7 | 0 | pass |
|
||||||
| clos | 35 | 0 | pass |
|
| Phase 4: CLOS | 41 | 0 | pass |
|
||||||
| geometry | 0 | 0 | FAIL |
|
| Phase 4: geometry | 12 | 0 | pass |
|
||||||
| mop-trace | 0 | 0 | FAIL |
|
| Phase 4: mop-trace | 13 | 0 | pass |
|
||||||
| macros | 27 | 0 | pass |
|
| Phase 5: macros+LOOP | 27 | 0 | pass |
|
||||||
| stdlib | 54 | 0 | pass |
|
| Phase 6: stdlib | 54 | 0 | pass |
|
||||||
|
|
||||||
**Total: 487 passed, 0 failed**
|
**Total: 518 passed, 0 failed**
|
||||||
|
|||||||
45
lib/content/block-path.sx
Normal file
45
lib/content/block-path.sx
Normal file
@@ -0,0 +1,45 @@
|
|||||||
|
;; content-on-sx — locate a block in the tree (ancestor section path).
|
||||||
|
;;
|
||||||
|
;; The read-side companion to doc-find-deep (which returns the block) and the
|
||||||
|
;; move/reparent ops (which relocate it): content/block-path returns the list of
|
||||||
|
;; ancestor section ids, root-first, leading to a block id — i.e. where the
|
||||||
|
;; block sits in the tree. A top-level block has an empty path; a block one
|
||||||
|
;; section deep has a one-element path; a missing id returns nil (distinct from
|
||||||
|
;; the empty-list path of a present top-level block). content/block-depth is the
|
||||||
|
;; path length (0 = top level, -1 = absent). Useful for breadcrumbs and for
|
||||||
|
;; scoping an edit to a block's enclosing section. Pure traversal; descends into
|
||||||
|
;; any block carrying a children list, like the rest of the tree helpers.
|
||||||
|
;;
|
||||||
|
;; Requires (loaded by harness): block.sx, doc.sx.
|
||||||
|
|
||||||
|
(define
|
||||||
|
bp-in-blocks
|
||||||
|
(fn
|
||||||
|
(blocks id trail)
|
||||||
|
(if
|
||||||
|
(= (len blocks) 0)
|
||||||
|
nil
|
||||||
|
(let
|
||||||
|
((b (first blocks)))
|
||||||
|
(if
|
||||||
|
(= (blk-id b) id)
|
||||||
|
trail
|
||||||
|
(let
|
||||||
|
((ch (st-iv-get b "children")))
|
||||||
|
(let
|
||||||
|
((found (if (list? ch) (bp-in-blocks ch id (append trail (list (blk-id b)))) nil)))
|
||||||
|
(if (= found nil) (bp-in-blocks (rest blocks) id trail) found))))))))
|
||||||
|
|
||||||
|
;; ancestor section ids (root-first) for `id`, or nil if the block is absent.
|
||||||
|
(define
|
||||||
|
content/block-path
|
||||||
|
(fn (doc id) (bp-in-blocks (doc-blocks doc) id (list))))
|
||||||
|
|
||||||
|
;; depth of `id`: 0 at top level, n nested n sections deep, -1 if absent.
|
||||||
|
(define
|
||||||
|
content/block-depth
|
||||||
|
(fn
|
||||||
|
(doc id)
|
||||||
|
(let
|
||||||
|
((p (content/block-path doc id)))
|
||||||
|
(if (= p nil) -1 (len p)))))
|
||||||
@@ -15,7 +15,7 @@ if [ ! -x "$SX_SERVER" ]; then
|
|||||||
fi
|
fi
|
||||||
fi
|
fi
|
||||||
|
|
||||||
SUITES=(block doc render api meta page page-full markdown text section compose tree-edit move clone query toc anchor outline flatten transform normalize find-replace stats summary index table callout media data wire validate store snapshot crdt crdt-tree crdt-blocks crdt-store sync md-import md-doc fed)
|
SUITES=(block doc render api meta page page-full markdown runs text section compose tree-edit move block-path clone query toc anchor outline flatten transform normalize find-replace stats summary index table callout media data wire validate sanitize store snapshot crdt crdt-tree crdt-blocks crdt-store sync md-import md-doc fed)
|
||||||
|
|
||||||
OUT_JSON="lib/content/scoreboard.json"
|
OUT_JSON="lib/content/scoreboard.json"
|
||||||
OUT_MD="lib/content/scoreboard.md"
|
OUT_MD="lib/content/scoreboard.md"
|
||||||
@@ -48,6 +48,7 @@ run_suite() {
|
|||||||
(load "lib/content/compose.sx")
|
(load "lib/content/compose.sx")
|
||||||
(load "lib/content/tree-edit.sx")
|
(load "lib/content/tree-edit.sx")
|
||||||
(load "lib/content/move.sx")
|
(load "lib/content/move.sx")
|
||||||
|
(load "lib/content/block-path.sx")
|
||||||
(load "lib/content/clone.sx")
|
(load "lib/content/clone.sx")
|
||||||
(load "lib/content/query.sx")
|
(load "lib/content/query.sx")
|
||||||
(load "lib/content/toc.sx")
|
(load "lib/content/toc.sx")
|
||||||
@@ -68,7 +69,9 @@ run_suite() {
|
|||||||
(load "lib/content/page.sx")
|
(load "lib/content/page.sx")
|
||||||
(load "lib/content/page-full.sx")
|
(load "lib/content/page-full.sx")
|
||||||
(load "lib/content/markdown.sx")
|
(load "lib/content/markdown.sx")
|
||||||
|
(load "lib/content/runs.sx")
|
||||||
(load "lib/content/validate.sx")
|
(load "lib/content/validate.sx")
|
||||||
|
(load "lib/content/sanitize.sx")
|
||||||
(load "lib/content/store.sx")
|
(load "lib/content/store.sx")
|
||||||
(load "lib/content/snapshot.sx")
|
(load "lib/content/snapshot.sx")
|
||||||
(load "lib/content/crdt.sx")
|
(load "lib/content/crdt.sx")
|
||||||
|
|||||||
@@ -10,6 +10,11 @@
|
|||||||
;; via content/find-replace and a word count over asText stay consistent.
|
;; via content/find-replace and a word count over asText stay consistent.
|
||||||
;; Immutable; case-sensitive.
|
;; Immutable; case-sensitive.
|
||||||
;;
|
;;
|
||||||
|
;; A text field may be a plain string OR a list of rich-text runs (Phase 5,
|
||||||
|
;; run = (text marks href)). fr-rep-text rewrites per run, preserving each run's
|
||||||
|
;; marks/href; a match that physically straddles two runs is not joined (the
|
||||||
|
;; replacement would have no single mark set) — each run is rewritten in place.
|
||||||
|
;;
|
||||||
;; Requires (loaded by harness): block.sx, transform.sx (content/map-blocks),
|
;; Requires (loaded by harness): block.sx, transform.sx (content/map-blocks),
|
||||||
;; table.sx (CtTable ivars).
|
;; table.sx (CtTable ivars).
|
||||||
|
|
||||||
@@ -24,6 +29,23 @@
|
|||||||
|
|
||||||
(define fr-rep (fn (s from to) (replace (str s) from to)))
|
(define fr-rep (fn (s from to) (replace (str s) from to)))
|
||||||
|
|
||||||
|
;; rewrite a text-bearing field that is either a plain string or a runs list
|
||||||
|
(define
|
||||||
|
fr-rep-text
|
||||||
|
(fn
|
||||||
|
(v from to)
|
||||||
|
(if
|
||||||
|
(list? v)
|
||||||
|
(map
|
||||||
|
(fn
|
||||||
|
(r)
|
||||||
|
(list
|
||||||
|
(fr-rep (nth r 0) from to)
|
||||||
|
(nth r 1)
|
||||||
|
(nth r 2)))
|
||||||
|
v)
|
||||||
|
(fr-rep v from to))))
|
||||||
|
|
||||||
;; Blocks whose prose content find/replace rewrites (matches asText's set).
|
;; Blocks whose prose content find/replace rewrites (matches asText's set).
|
||||||
(define
|
(define
|
||||||
fr-has-text?
|
fr-has-text?
|
||||||
@@ -66,7 +88,7 @@
|
|||||||
(if (list? r) (map (fn (c) (fr-rep c from to)) r) r))
|
(if (list? r) (map (fn (c) (fr-rep c from to)) r) r))
|
||||||
rs))
|
rs))
|
||||||
b1))))
|
b1))))
|
||||||
(else (blk-set b "text" (fr-rep (blk-get b "text") from to)))))))
|
(else (blk-set b "text" (fr-rep-text (blk-get b "text") from to)))))))
|
||||||
|
|
||||||
(define
|
(define
|
||||||
content/find-replace
|
content/find-replace
|
||||||
|
|||||||
@@ -1,8 +1,13 @@
|
|||||||
;; content-on-sx — relative block reorder.
|
;; content-on-sx — block reorder + reparent.
|
||||||
;;
|
;;
|
||||||
;; Move a top-level block to just before / after another block by id — more
|
;; Relative reorder of top-level blocks (move-before/after/to-front/to-back by
|
||||||
;; ergonomic than the index-based doc-move. No-op if either id is missing.
|
;; id) plus TREE reparenting: move a block into a section (content/move-into) or
|
||||||
;; Immutable; composes the doc.sx list helpers.
|
;; promote a nested block back out to the top level (content/promote). Reparent
|
||||||
|
;; ops are tree-wide (the block may start anywhere) and cycle-safe — moving a
|
||||||
|
;; block into its own descendant is rejected (no-op), so a section can never
|
||||||
|
;; become its own ancestor. No-op if any id is missing. Immutable; composes the
|
||||||
|
;; doc.sx list + tree helpers (doc-find-deep / ct-find-id / ct-remove-id /
|
||||||
|
;; ct-replace-id / ct-insert-at).
|
||||||
;;
|
;;
|
||||||
;; Requires (loaded by harness): doc.sx.
|
;; Requires (loaded by harness): doc.sx.
|
||||||
|
|
||||||
@@ -67,3 +72,57 @@
|
|||||||
(doc-with-blocks
|
(doc-with-blocks
|
||||||
doc
|
doc
|
||||||
(append (ct-remove-id (doc-blocks doc) id) (list blk)))))))
|
(append (ct-remove-id (doc-blocks doc) id) (list blk)))))))
|
||||||
|
|
||||||
|
;; ── reparent (tree-wide) ──
|
||||||
|
;; move block `id` (from anywhere in the tree) to be a child of section
|
||||||
|
;; `section-id` at index `i`. No-op if either id is missing, if id = section-id,
|
||||||
|
;; or if section-id sits inside id's own subtree (would create a cycle).
|
||||||
|
(define
|
||||||
|
content/move-into
|
||||||
|
(fn
|
||||||
|
(doc id section-id i)
|
||||||
|
(let
|
||||||
|
((blk (doc-find-deep doc id)))
|
||||||
|
(if
|
||||||
|
(= blk nil)
|
||||||
|
doc
|
||||||
|
(if
|
||||||
|
(= (doc-find-deep doc section-id) nil)
|
||||||
|
doc
|
||||||
|
(if
|
||||||
|
(= id section-id)
|
||||||
|
doc
|
||||||
|
(if
|
||||||
|
(= (ct-find-id (list blk) section-id) nil)
|
||||||
|
(let
|
||||||
|
((without (ct-remove-id (doc-blocks doc) id)))
|
||||||
|
(doc-with-blocks
|
||||||
|
doc
|
||||||
|
(ct-replace-id
|
||||||
|
without
|
||||||
|
section-id
|
||||||
|
(fn
|
||||||
|
(sec)
|
||||||
|
(let
|
||||||
|
((ch (st-iv-get sec "children")))
|
||||||
|
(if
|
||||||
|
(list? ch)
|
||||||
|
(st-iv-set! sec "children" (ct-insert-at ch i blk))
|
||||||
|
sec))))))
|
||||||
|
doc)))))))
|
||||||
|
|
||||||
|
;; promote block `id` (wherever it sits) out to the end of the top level. If it
|
||||||
|
;; is already top-level this is a move-to-back. No-op if missing. A section keeps
|
||||||
|
;; its whole subtree.
|
||||||
|
(define
|
||||||
|
content/promote
|
||||||
|
(fn
|
||||||
|
(doc id)
|
||||||
|
(let
|
||||||
|
((blk (doc-find-deep doc id)))
|
||||||
|
(if
|
||||||
|
(= blk nil)
|
||||||
|
doc
|
||||||
|
(doc-with-blocks
|
||||||
|
doc
|
||||||
|
(append (ct-remove-id (doc-blocks doc) id) (list blk)))))))
|
||||||
|
|||||||
118
lib/content/runs.sx
Normal file
118
lib/content/runs.sx
Normal file
@@ -0,0 +1,118 @@
|
|||||||
|
;; content-on-sx — Phase 5: rich inline text (structured runs).
|
||||||
|
;;
|
||||||
|
;; A CtText's `text` ivar may be EITHER a plain string (backward compat) OR a
|
||||||
|
;; list of inline RUNS. A run is a 3-element list (text marks href):
|
||||||
|
;; text — a string
|
||||||
|
;; marks — a list of mark tokens, a subset of
|
||||||
|
;; :bold :italic :underline :strikethrough :code :subscript
|
||||||
|
;; :superscript :link (SX keywords evaluate to the strings the
|
||||||
|
;; Smalltalk renderer compares against; build them with keywords)
|
||||||
|
;; href — a string ("" when absent; the link target for a :link mark)
|
||||||
|
;;
|
||||||
|
;; Runs are a LIST, not a {:text :marks} dict, because rendering happens inside
|
||||||
|
;; the Smalltalk render methods (nested blocks dispatch asHTML/etc. via Smalltalk
|
||||||
|
;; message sends) and the Smalltalk-on-SX layer can iterate SX lists but cannot
|
||||||
|
;; read SX dict fields. Lists are Smalltalk-native, render under nesting, and
|
||||||
|
;; round-trip through data/wire for free.
|
||||||
|
;;
|
||||||
|
;; content-bootstrap-runs! OVERRIDES the render/markdown/text methods of CtText
|
||||||
|
;; and its subclasses (CtHeading/CtQuote rich; CtCode verbatim — runs render as
|
||||||
|
;; plain concatenated text) with run-aware versions that produce IDENTICAL output
|
||||||
|
;; for a plain-string body. Opt-in: call after the render/markdown/text
|
||||||
|
;; bootstraps; suites that don't call it are unaffected.
|
||||||
|
;;
|
||||||
|
;; Requires (loaded by harness): block.sx, render.sx, markdown.sx, text.sx.
|
||||||
|
|
||||||
|
;; ── SX-side run helpers ──
|
||||||
|
(define mk-run (fn (text marks href) (list text marks href)))
|
||||||
|
(define mk-run-plain (fn (text) (list text (list) "")))
|
||||||
|
(define run-text (fn (r) (nth r 0)))
|
||||||
|
(define run-marks (fn (r) (nth r 1)))
|
||||||
|
(define run-href (fn (r) (nth r 2)))
|
||||||
|
;; a CtText body is "rich" iff it is a runs list (vs a plain string)
|
||||||
|
(define runs? (fn (v) (list? v)))
|
||||||
|
;; build a CtText whose body is a list of runs
|
||||||
|
(define
|
||||||
|
mk-rich-text
|
||||||
|
(fn (id runs) (st-iv-set! (mk-text id "") "text" runs)))
|
||||||
|
|
||||||
|
(define
|
||||||
|
content-bootstrap-runs!
|
||||||
|
(fn
|
||||||
|
()
|
||||||
|
(begin
|
||||||
|
(ct-def-method!
|
||||||
|
"CtText"
|
||||||
|
"runHtml:"
|
||||||
|
"runHtml: run | frag marks href | frag := (run at: 1) htmlEscaped. marks := run at: 2. href := run at: 3. marks do: [:m | (m = 'bold') ifTrue: [frag := '<strong>' , frag , '</strong>']. (m = 'italic') ifTrue: [frag := '<em>' , frag , '</em>']. (m = 'underline') ifTrue: [frag := '<u>' , frag , '</u>']. (m = 'strikethrough') ifTrue: [frag := '<s>' , frag , '</s>']. (m = 'code') ifTrue: [frag := '<code>' , frag , '</code>']. (m = 'subscript') ifTrue: [frag := '<sub>' , frag , '</sub>']. (m = 'superscript') ifTrue: [frag := '<sup>' , frag , '</sup>']. (m = 'link') ifTrue: [frag := '<a href=\"' , href htmlEscaped , '\">' , frag , '</a>']]. ^ frag")
|
||||||
|
(ct-def-method!
|
||||||
|
"CtText"
|
||||||
|
"runSx:"
|
||||||
|
"runSx: run | frag marks href | frag := '\"' , (run at: 1) sxEscaped , '\"'. marks := run at: 2. href := run at: 3. marks do: [:m | (m = 'bold') ifTrue: [frag := '(strong ' , frag , ')']. (m = 'italic') ifTrue: [frag := '(em ' , frag , ')']. (m = 'underline') ifTrue: [frag := '(u ' , frag , ')']. (m = 'strikethrough') ifTrue: [frag := '(s ' , frag , ')']. (m = 'code') ifTrue: [frag := '(code ' , frag , ')']. (m = 'subscript') ifTrue: [frag := '(sub ' , frag , ')']. (m = 'superscript') ifTrue: [frag := '(sup ' , frag , ')']. (m = 'link') ifTrue: [frag := '(a :href \"' , href sxEscaped , '\" ' , frag , ')']]. ^ frag")
|
||||||
|
(ct-def-method!
|
||||||
|
"CtText"
|
||||||
|
"runMd:"
|
||||||
|
"runMd: run | frag marks href | frag := (run at: 1). marks := run at: 2. href := run at: 3. marks do: [:m | (m = 'bold') ifTrue: [frag := '**' , frag , '**']. (m = 'italic') ifTrue: [frag := '_' , frag , '_']. (m = 'strikethrough') ifTrue: [frag := '~~' , frag , '~~']. (m = 'code') ifTrue: [frag := '`' , frag , '`']. (m = 'underline') ifTrue: [frag := '<u>' , frag , '</u>']. (m = 'subscript') ifTrue: [frag := '<sub>' , frag , '</sub>']. (m = 'superscript') ifTrue: [frag := '<sup>' , frag , '</sup>']. (m = 'link') ifTrue: [frag := '[' , frag , '](' , href , ')']]. ^ frag")
|
||||||
|
(ct-def-method!
|
||||||
|
"CtText"
|
||||||
|
"inlineHtml"
|
||||||
|
"inlineHtml | out | (text class name = 'String') ifTrue: [^ text htmlEscaped]. out := ''. text do: [:run | out := out , (self runHtml: run)]. ^ out")
|
||||||
|
(ct-def-method!
|
||||||
|
"CtText"
|
||||||
|
"inlineSx"
|
||||||
|
"inlineSx | out | (text class name = 'String') ifTrue: [^ '\"' , text sxEscaped , '\"']. out := ''. text do: [:run | out := (out = '' ifTrue: [self runSx: run] ifFalse: [out , ' ' , (self runSx: run)])]. ^ out")
|
||||||
|
(ct-def-method!
|
||||||
|
"CtText"
|
||||||
|
"inlineMd"
|
||||||
|
"inlineMd | out | (text class name = 'String') ifTrue: [^ text]. out := ''. text do: [:run | out := out , (self runMd: run)]. ^ out")
|
||||||
|
(ct-def-method!
|
||||||
|
"CtText"
|
||||||
|
"inlineText"
|
||||||
|
"inlineText | out | (text class name = 'String') ifTrue: [^ text]. out := ''. text do: [:run | out := out , (run at: 1)]. ^ out")
|
||||||
|
(ct-def-method!
|
||||||
|
"CtText"
|
||||||
|
"asHTML"
|
||||||
|
"asHTML ^ '<p>' , self inlineHtml , '</p>'")
|
||||||
|
(ct-def-method! "CtText" "asSx" "asSx ^ '(p ' , self inlineSx , ')'")
|
||||||
|
(ct-def-method! "CtText" "asMarkdown:" "asMarkdown: nl ^ self inlineMd")
|
||||||
|
(ct-def-method! "CtText" "asText" "asText ^ self inlineText")
|
||||||
|
(ct-def-method!
|
||||||
|
"CtHeading"
|
||||||
|
"asHTML"
|
||||||
|
"asHTML | t | t := level printString. ^ '<h' , t , '>' , self inlineHtml , '</h' , t , '>'")
|
||||||
|
(ct-def-method!
|
||||||
|
"CtHeading"
|
||||||
|
"asSx"
|
||||||
|
"asSx | t | t := level printString. ^ '(h' , t , ' ' , self inlineSx , ')'")
|
||||||
|
(ct-def-method!
|
||||||
|
"CtHeading"
|
||||||
|
"asMarkdown:"
|
||||||
|
"asMarkdown: nl | h i | h := ''. i := 0. [i < level] whileTrue: [h := h , '#'. i := i + 1]. ^ h , ' ' , self inlineMd")
|
||||||
|
(ct-def-method! "CtHeading" "asText" "asText ^ self inlineText")
|
||||||
|
(ct-def-method!
|
||||||
|
"CtQuote"
|
||||||
|
"asHTML"
|
||||||
|
"asHTML ^ '<blockquote>' , self inlineHtml , '</blockquote>'")
|
||||||
|
(ct-def-method!
|
||||||
|
"CtQuote"
|
||||||
|
"asSx"
|
||||||
|
"asSx ^ '(blockquote ' , self inlineSx , ')'")
|
||||||
|
(ct-def-method!
|
||||||
|
"CtQuote"
|
||||||
|
"asMarkdown:"
|
||||||
|
"asMarkdown: nl ^ '> ' , self inlineMd")
|
||||||
|
(ct-def-method! "CtQuote" "asText" "asText ^ self inlineText")
|
||||||
|
(ct-def-method!
|
||||||
|
"CtCode"
|
||||||
|
"asHTML"
|
||||||
|
"asHTML ^ '<pre><code class=\"language-' , language htmlEscaped , '\">' , self inlineText htmlEscaped , '</code></pre>'")
|
||||||
|
(ct-def-method!
|
||||||
|
"CtCode"
|
||||||
|
"asSx"
|
||||||
|
"asSx ^ '(pre (code \"' , self inlineText sxEscaped , '\"))'")
|
||||||
|
(ct-def-method!
|
||||||
|
"CtCode"
|
||||||
|
"asMarkdown:"
|
||||||
|
"asMarkdown: nl ^ '```' , language , nl , self inlineText , nl , '```'")
|
||||||
|
(ct-def-method! "CtCode" "asText" "asText ^ self inlineText")
|
||||||
|
true)))
|
||||||
47
lib/content/sanitize.sx
Normal file
47
lib/content/sanitize.sx
Normal file
@@ -0,0 +1,47 @@
|
|||||||
|
;; content-on-sx — make a document render-safe by dropping invalid blocks.
|
||||||
|
;;
|
||||||
|
;; The enforcement counterpart to validate: where content/validate REPORTS id /
|
||||||
|
;; field issues, content/sanitize REMOVES the offending blocks so the result can
|
||||||
|
;; be rendered/merged without faulting on malformed input (federated or imported
|
||||||
|
;; documents that failed validation). Tree-wide: descends into sections, pruning
|
||||||
|
;; invalid descendants; a section whose own shell is valid is kept (even if it
|
||||||
|
;; ends up empty — that is normalize's job, not sanitize's), but a section whose
|
||||||
|
;; own check fails (e.g. children is not a list) is dropped whole.
|
||||||
|
;;
|
||||||
|
;; Reuses validate's per-block predicate (content/-block-issues), so the set of
|
||||||
|
;; "what is invalid" stays single-sourced and can't drift from content/validate.
|
||||||
|
;; sanitize addresses per-block id/field validity only; it does NOT resolve
|
||||||
|
;; duplicate ids (a cross-block concern with no single right answer), so a
|
||||||
|
;; sanitized doc is render-safe but not necessarily content/valid? if the input
|
||||||
|
;; carried duplicate ids. Immutable; returns a new document.
|
||||||
|
;;
|
||||||
|
;; Requires (loaded by harness): block.sx, doc.sx, validate.sx
|
||||||
|
;; (content/-block-issues).
|
||||||
|
|
||||||
|
(define
|
||||||
|
san-section?
|
||||||
|
(fn (b) (and (st-instance? b) (= (get b :class) "CtSection"))))
|
||||||
|
|
||||||
|
;; a block is render-safe when it has no id/field issues (validate's own checks)
|
||||||
|
(define san-ok? (fn (b) (= (len (content/-block-issues b)) 0)))
|
||||||
|
|
||||||
|
;; drop invalid blocks at this level; recurse into surviving sections so invalid
|
||||||
|
;; descendants are pruned too.
|
||||||
|
(define
|
||||||
|
san-blocks
|
||||||
|
(fn
|
||||||
|
(blocks)
|
||||||
|
(map
|
||||||
|
(fn
|
||||||
|
(b)
|
||||||
|
(if
|
||||||
|
(san-section? b)
|
||||||
|
(let
|
||||||
|
((ch (st-iv-get b "children")))
|
||||||
|
(if (list? ch) (st-iv-set! b "children" (san-blocks ch)) b))
|
||||||
|
b))
|
||||||
|
(filter san-ok? blocks))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
content/sanitize
|
||||||
|
(fn (doc) (doc-with-blocks doc (san-blocks (doc-blocks doc)))))
|
||||||
@@ -8,11 +8,13 @@
|
|||||||
"page": {"pass": 7, "fail": 0},
|
"page": {"pass": 7, "fail": 0},
|
||||||
"page-full": {"pass": 4, "fail": 0},
|
"page-full": {"pass": 4, "fail": 0},
|
||||||
"markdown": {"pass": 20, "fail": 0},
|
"markdown": {"pass": 20, "fail": 0},
|
||||||
|
"runs": {"pass": 36, "fail": 0},
|
||||||
"text": {"pass": 20, "fail": 0},
|
"text": {"pass": 20, "fail": 0},
|
||||||
"section": {"pass": 25, "fail": 0},
|
"section": {"pass": 25, "fail": 0},
|
||||||
"compose": {"pass": 17, "fail": 0},
|
"compose": {"pass": 17, "fail": 0},
|
||||||
"tree-edit": {"pass": 17, "fail": 0},
|
"tree-edit": {"pass": 17, "fail": 0},
|
||||||
"move": {"pass": 11, "fail": 0},
|
"move": {"pass": 24, "fail": 0},
|
||||||
|
"block-path": {"pass": 13, "fail": 0},
|
||||||
"clone": {"pass": 10, "fail": 0},
|
"clone": {"pass": 10, "fail": 0},
|
||||||
"query": {"pass": 20, "fail": 0},
|
"query": {"pass": 20, "fail": 0},
|
||||||
"toc": {"pass": 8, "fail": 0},
|
"toc": {"pass": 8, "fail": 0},
|
||||||
@@ -30,7 +32,8 @@
|
|||||||
"media": {"pass": 15, "fail": 0},
|
"media": {"pass": 15, "fail": 0},
|
||||||
"data": {"pass": 25, "fail": 0},
|
"data": {"pass": 25, "fail": 0},
|
||||||
"wire": {"pass": 11, "fail": 0},
|
"wire": {"pass": 11, "fail": 0},
|
||||||
"validate": {"pass": 23, "fail": 0},
|
"validate": {"pass": 32, "fail": 0},
|
||||||
|
"sanitize": {"pass": 12, "fail": 0},
|
||||||
"store": {"pass": 46, "fail": 0},
|
"store": {"pass": 46, "fail": 0},
|
||||||
"snapshot": {"pass": 20, "fail": 0},
|
"snapshot": {"pass": 20, "fail": 0},
|
||||||
"crdt": {"pass": 34, "fail": 0},
|
"crdt": {"pass": 34, "fail": 0},
|
||||||
@@ -42,7 +45,7 @@
|
|||||||
"md-doc": {"pass": 12, "fail": 0},
|
"md-doc": {"pass": 12, "fail": 0},
|
||||||
"fed": {"pass": 20, "fail": 0}
|
"fed": {"pass": 20, "fail": 0}
|
||||||
},
|
},
|
||||||
"total_pass": 778,
|
"total_pass": 861,
|
||||||
"total_fail": 0,
|
"total_fail": 0,
|
||||||
"total": 778
|
"total": 861
|
||||||
}
|
}
|
||||||
|
|||||||
@@ -12,11 +12,13 @@ _Generated by `lib/content/conformance.sh`_
|
|||||||
| page | 7 | 0 | 7 |
|
| page | 7 | 0 | 7 |
|
||||||
| page-full | 4 | 0 | 4 |
|
| page-full | 4 | 0 | 4 |
|
||||||
| markdown | 20 | 0 | 20 |
|
| markdown | 20 | 0 | 20 |
|
||||||
|
| runs | 36 | 0 | 36 |
|
||||||
| text | 20 | 0 | 20 |
|
| text | 20 | 0 | 20 |
|
||||||
| section | 25 | 0 | 25 |
|
| section | 25 | 0 | 25 |
|
||||||
| compose | 17 | 0 | 17 |
|
| compose | 17 | 0 | 17 |
|
||||||
| tree-edit | 17 | 0 | 17 |
|
| tree-edit | 17 | 0 | 17 |
|
||||||
| move | 11 | 0 | 11 |
|
| move | 24 | 0 | 24 |
|
||||||
|
| block-path | 13 | 0 | 13 |
|
||||||
| clone | 10 | 0 | 10 |
|
| clone | 10 | 0 | 10 |
|
||||||
| query | 20 | 0 | 20 |
|
| query | 20 | 0 | 20 |
|
||||||
| toc | 8 | 0 | 8 |
|
| toc | 8 | 0 | 8 |
|
||||||
@@ -34,7 +36,8 @@ _Generated by `lib/content/conformance.sh`_
|
|||||||
| media | 15 | 0 | 15 |
|
| media | 15 | 0 | 15 |
|
||||||
| data | 25 | 0 | 25 |
|
| data | 25 | 0 | 25 |
|
||||||
| wire | 11 | 0 | 11 |
|
| wire | 11 | 0 | 11 |
|
||||||
| validate | 23 | 0 | 23 |
|
| validate | 32 | 0 | 32 |
|
||||||
|
| sanitize | 12 | 0 | 12 |
|
||||||
| store | 46 | 0 | 46 |
|
| store | 46 | 0 | 46 |
|
||||||
| snapshot | 20 | 0 | 20 |
|
| snapshot | 20 | 0 | 20 |
|
||||||
| crdt | 34 | 0 | 34 |
|
| crdt | 34 | 0 | 34 |
|
||||||
@@ -45,4 +48,4 @@ _Generated by `lib/content/conformance.sh`_
|
|||||||
| md-import | 38 | 0 | 38 |
|
| md-import | 38 | 0 | 38 |
|
||||||
| md-doc | 12 | 0 | 12 |
|
| md-doc | 12 | 0 | 12 |
|
||||||
| fed | 20 | 0 | 20 |
|
| fed | 20 | 0 | 20 |
|
||||||
| **Total** | **778** | **0** | **778** |
|
| **Total** | **861** | **0** | **861** |
|
||||||
|
|||||||
59
lib/content/tests/block-path.sx
Normal file
59
lib/content/tests/block-path.sx
Normal file
@@ -0,0 +1,59 @@
|
|||||||
|
;; Extension — locate a block in the tree (ancestor section path).
|
||||||
|
|
||||||
|
(st-bootstrap-classes!)
|
||||||
|
(content/bootstrap!)
|
||||||
|
(content-bootstrap-section!)
|
||||||
|
|
||||||
|
;; doc: top-level "a", section "s" containing "x" and nested section "i"
|
||||||
|
;; containing "z".
|
||||||
|
(define
|
||||||
|
d
|
||||||
|
(doc-append
|
||||||
|
(doc-append (doc-empty "d") (mk-text "a" "A"))
|
||||||
|
(mk-section
|
||||||
|
"s"
|
||||||
|
(list (mk-text "x" "X") (mk-section "i" (list (mk-text "z" "Z")))))))
|
||||||
|
|
||||||
|
;; ── block-path ──
|
||||||
|
(content-test
|
||||||
|
"top-level block has empty path"
|
||||||
|
(content/block-path d "a")
|
||||||
|
(list))
|
||||||
|
(content-test "one-deep block path" (content/block-path d "x") (list "s"))
|
||||||
|
(content-test
|
||||||
|
"two-deep block path"
|
||||||
|
(content/block-path d "z")
|
||||||
|
(list "s" "i"))
|
||||||
|
(content-test "section's own path" (content/block-path d "i") (list "s"))
|
||||||
|
(content-test "missing id path nil" (content/block-path d "zzz") nil)
|
||||||
|
|
||||||
|
;; nil (absent) is distinct from () (present top-level)
|
||||||
|
(content-test
|
||||||
|
"absent vs top-level distinguishable"
|
||||||
|
(if (= (content/block-path d "a") nil) "nil" "list")
|
||||||
|
"list")
|
||||||
|
|
||||||
|
;; ── block-depth ──
|
||||||
|
(content-test "depth top-level" (content/block-depth d "a") 0)
|
||||||
|
(content-test "depth one" (content/block-depth d "x") 1)
|
||||||
|
(content-test "depth two" (content/block-depth d "z") 2)
|
||||||
|
(content-test "depth section" (content/block-depth d "i") 1)
|
||||||
|
(content-test "depth absent" (content/block-depth d "zzz") -1)
|
||||||
|
|
||||||
|
;; ── path tracks reparenting (composes with move.sx) ──
|
||||||
|
;; (rebuild expectation directly; move tested elsewhere)
|
||||||
|
(define
|
||||||
|
flat
|
||||||
|
(doc-append
|
||||||
|
(doc-append (doc-empty "d") (mk-section "sec" (list)))
|
||||||
|
(mk-text "p" "P")))
|
||||||
|
(content-test
|
||||||
|
"before: p at top level"
|
||||||
|
(content/block-depth flat "p")
|
||||||
|
0)
|
||||||
|
|
||||||
|
;; ── empty doc ──
|
||||||
|
(content-test
|
||||||
|
"empty doc path nil"
|
||||||
|
(content/block-path (doc-empty "e") "x")
|
||||||
|
nil)
|
||||||
@@ -1,7 +1,8 @@
|
|||||||
;; Extension — relative block reorder.
|
;; Extension — relative block reorder + tree reparent.
|
||||||
|
|
||||||
(st-bootstrap-classes!)
|
(st-bootstrap-classes!)
|
||||||
(content/bootstrap!)
|
(content/bootstrap!)
|
||||||
|
(content-bootstrap-section!)
|
||||||
|
|
||||||
(define
|
(define
|
||||||
d
|
d
|
||||||
@@ -61,3 +62,84 @@
|
|||||||
"render after move"
|
"render after move"
|
||||||
(asHTML (content/move-after d "a" "c"))
|
(asHTML (content/move-after d "a" "c"))
|
||||||
"<p>B</p><p>C</p><p>A</p>")
|
"<p>B</p><p>C</p><p>A</p>")
|
||||||
|
|
||||||
|
;; ── reparent: move a top-level block INTO a section ──
|
||||||
|
(define
|
||||||
|
nd
|
||||||
|
(doc-append
|
||||||
|
(doc-append (doc-empty "d") (mk-text "p" "P"))
|
||||||
|
(mk-section "s" (list (mk-text "x" "X")))))
|
||||||
|
(content-test
|
||||||
|
"move-into: block leaves top level"
|
||||||
|
(doc-ids (content/move-into nd "p" "s" 1))
|
||||||
|
(list "s"))
|
||||||
|
(content-test
|
||||||
|
"move-into: block lands in section at index"
|
||||||
|
(doc-tree-ids (content/move-into nd "p" "s" 1))
|
||||||
|
(list "s" "x" "p"))
|
||||||
|
(content-test
|
||||||
|
"move-into at front of section"
|
||||||
|
(doc-tree-ids (content/move-into nd "p" "s" 0))
|
||||||
|
(list "s" "p" "x"))
|
||||||
|
(content-test "move-into immutable" (doc-tree-ids nd) (list "p" "s" "x"))
|
||||||
|
|
||||||
|
;; ── reparent: move a NESTED block to a different section ──
|
||||||
|
(define
|
||||||
|
two
|
||||||
|
(doc-append
|
||||||
|
(doc-append (doc-empty "d") (mk-section "s1" (list (mk-text "n" "N"))))
|
||||||
|
(mk-section "s2" (list (mk-text "y" "Y")))))
|
||||||
|
(content-test
|
||||||
|
"move-into across sections"
|
||||||
|
(doc-tree-ids (content/move-into two "n" "s2" 1))
|
||||||
|
(list "s1" "s2" "y" "n"))
|
||||||
|
|
||||||
|
;; ── promote: nested block out to top level (appended last) ──
|
||||||
|
(content-test
|
||||||
|
"promote nested to top level"
|
||||||
|
(doc-tree-ids (content/promote two "n"))
|
||||||
|
(list "s1" "s2" "y" "n"))
|
||||||
|
(content-test
|
||||||
|
"promote leaves section empty shell"
|
||||||
|
(doc-ids (content/promote two "n"))
|
||||||
|
(list "s1" "s2" "n"))
|
||||||
|
(content-test
|
||||||
|
"promote a whole section keeps its subtree"
|
||||||
|
(doc-tree-ids
|
||||||
|
(content/promote
|
||||||
|
(doc-append
|
||||||
|
(doc-empty "d")
|
||||||
|
(mk-section "o" (list (mk-section "i" (list (mk-text "z" "Z"))))))
|
||||||
|
"i"))
|
||||||
|
(list "o" "i" "z"))
|
||||||
|
|
||||||
|
;; ── cycle guard: cannot move a section into its own descendant ──
|
||||||
|
(define
|
||||||
|
nest
|
||||||
|
(doc-append
|
||||||
|
(doc-empty "d")
|
||||||
|
(mk-section
|
||||||
|
"outer"
|
||||||
|
(list (mk-section "inner" (list (mk-text "t" "T")))))))
|
||||||
|
(content-test
|
||||||
|
"move section into its own child is a no-op"
|
||||||
|
(doc-tree-ids (content/move-into nest "outer" "inner" 0))
|
||||||
|
(list "outer" "inner" "t"))
|
||||||
|
(content-test
|
||||||
|
"move block into itself is a no-op"
|
||||||
|
(doc-tree-ids (content/move-into nest "inner" "inner" 0))
|
||||||
|
(list "outer" "inner" "t"))
|
||||||
|
|
||||||
|
;; ── reparent no-ops on missing ids ──
|
||||||
|
(content-test
|
||||||
|
"move-into missing block no-op"
|
||||||
|
(doc-tree-ids (content/move-into nd "zzz" "s" 0))
|
||||||
|
(list "p" "s" "x"))
|
||||||
|
(content-test
|
||||||
|
"move-into missing section no-op"
|
||||||
|
(doc-tree-ids (content/move-into nd "p" "zzz" 0))
|
||||||
|
(list "p" "s" "x"))
|
||||||
|
(content-test
|
||||||
|
"promote missing no-op"
|
||||||
|
(doc-tree-ids (content/promote nd "zzz"))
|
||||||
|
(list "p" "s" "x"))
|
||||||
|
|||||||
227
lib/content/tests/runs.sx
Normal file
227
lib/content/tests/runs.sx
Normal file
@@ -0,0 +1,227 @@
|
|||||||
|
;; Phase 5 — rich inline text (structured runs). Acceptance suite.
|
||||||
|
|
||||||
|
(st-bootstrap-classes!)
|
||||||
|
(content/bootstrap!)
|
||||||
|
(content-bootstrap-markdown!)
|
||||||
|
(content-bootstrap-text!)
|
||||||
|
(content-bootstrap-section!)
|
||||||
|
(content-bootstrap-runs!)
|
||||||
|
|
||||||
|
;; one-run helper: a CtText with a single marked run
|
||||||
|
(define
|
||||||
|
one
|
||||||
|
(fn (marks href) (mk-rich-text "p" (list (mk-run "x" marks href)))))
|
||||||
|
|
||||||
|
;; ── (1) four render modes ──
|
||||||
|
;; a paragraph mixing plain + bold + a link
|
||||||
|
(define
|
||||||
|
rd
|
||||||
|
(doc-append
|
||||||
|
(doc-empty "d")
|
||||||
|
(mk-rich-text
|
||||||
|
"p"
|
||||||
|
(list
|
||||||
|
(mk-run "the " (list) "")
|
||||||
|
(mk-run "cat" (list :bold) "")
|
||||||
|
(mk-run " and " (list) "")
|
||||||
|
(mk-run "dog" (list :italic :link) "/d")
|
||||||
|
(mk-run " sat" (list) "")))))
|
||||||
|
(define p (doc-find rd "p"))
|
||||||
|
(content-test
|
||||||
|
"asHTML rich"
|
||||||
|
(asHTML rd)
|
||||||
|
"<p>the <strong>cat</strong> and <a href=\"/d\"><em>dog</em></a> sat</p>")
|
||||||
|
(content-test
|
||||||
|
"asMarkdown rich"
|
||||||
|
(asMarkdown rd)
|
||||||
|
"the **cat** and [_dog_](/d) sat")
|
||||||
|
(content-test
|
||||||
|
"asSx rich"
|
||||||
|
(asSx rd)
|
||||||
|
"(article (p \"the \" (strong \"cat\") \" and \" (a :href \"/d\" (em \"dog\")) \" sat\"))")
|
||||||
|
(content-test
|
||||||
|
"asText rich is plain (no markup)"
|
||||||
|
(asText rd)
|
||||||
|
"the cat and dog sat")
|
||||||
|
|
||||||
|
;; every mark renders in HTML
|
||||||
|
(content-test
|
||||||
|
"mark bold html"
|
||||||
|
(asHTML (one (list :bold) ""))
|
||||||
|
"<p><strong>x</strong></p>")
|
||||||
|
(content-test
|
||||||
|
"mark italic html"
|
||||||
|
(asHTML (one (list :italic) ""))
|
||||||
|
"<p><em>x</em></p>")
|
||||||
|
(content-test
|
||||||
|
"mark underline html"
|
||||||
|
(asHTML (one (list :underline) ""))
|
||||||
|
"<p><u>x</u></p>")
|
||||||
|
(content-test
|
||||||
|
"mark strike html"
|
||||||
|
(asHTML (one (list :strikethrough) ""))
|
||||||
|
"<p><s>x</s></p>")
|
||||||
|
(content-test
|
||||||
|
"mark code html"
|
||||||
|
(asHTML (one (list :code) ""))
|
||||||
|
"<p><code>x</code></p>")
|
||||||
|
(content-test
|
||||||
|
"mark sub html"
|
||||||
|
(asHTML (one (list :subscript) ""))
|
||||||
|
"<p><sub>x</sub></p>")
|
||||||
|
(content-test
|
||||||
|
"mark sup html"
|
||||||
|
(asHTML (one (list :superscript) ""))
|
||||||
|
"<p><sup>x</sup></p>")
|
||||||
|
(content-test
|
||||||
|
"mark link html"
|
||||||
|
(asHTML (one (list :link) "/u"))
|
||||||
|
"<p><a href=\"/u\">x</a></p>")
|
||||||
|
|
||||||
|
;; markdown marks
|
||||||
|
(content-test "mark bold md" (asMarkdown (one (list :bold) "")) "**x**")
|
||||||
|
(content-test "mark italic md" (asMarkdown (one (list :italic) "")) "_x_")
|
||||||
|
(content-test
|
||||||
|
"mark strike md"
|
||||||
|
(asMarkdown (one (list :strikethrough) ""))
|
||||||
|
"~~x~~")
|
||||||
|
(content-test "mark code md" (asMarkdown (one (list :code) "")) "`x`")
|
||||||
|
(content-test "mark link md" (asMarkdown (one (list :link) "/u")) "[x](/u)")
|
||||||
|
(content-test
|
||||||
|
"mark underline md fallback"
|
||||||
|
(asMarkdown (one (list :underline) ""))
|
||||||
|
"<u>x</u>")
|
||||||
|
|
||||||
|
;; nested marks (bold+italic) — deterministic nesting order
|
||||||
|
(content-test
|
||||||
|
"nested marks html"
|
||||||
|
(asHTML (one (list :bold :italic) ""))
|
||||||
|
"<p><em><strong>x</strong></em></p>")
|
||||||
|
|
||||||
|
;; escaping still happens inside runs
|
||||||
|
(content-test
|
||||||
|
"run text escaped html"
|
||||||
|
(asHTML (mk-rich-text "p" (list (mk-run "a & b <c>" (list :bold) ""))))
|
||||||
|
"<p><strong>a & b <c></strong></p>")
|
||||||
|
|
||||||
|
;; rich heading + quote + code
|
||||||
|
(content-test
|
||||||
|
"rich heading html"
|
||||||
|
(asHTML
|
||||||
|
(st-iv-set!
|
||||||
|
(mk-heading "h" 2 "")
|
||||||
|
"text"
|
||||||
|
(list (mk-run "Big " (list) "") (mk-run "bold" (list :bold) ""))))
|
||||||
|
"<h2>Big <strong>bold</strong></h2>")
|
||||||
|
(content-test
|
||||||
|
"rich quote html"
|
||||||
|
(asHTML
|
||||||
|
(st-iv-set!
|
||||||
|
(mk-quote "q" "" "")
|
||||||
|
"text"
|
||||||
|
(list (mk-run "wise" (list :italic) ""))))
|
||||||
|
"<blockquote><em>wise</em></blockquote>")
|
||||||
|
;; code is verbatim — runs concatenate as plain text, marks ignored
|
||||||
|
(content-test
|
||||||
|
"code runs plain html"
|
||||||
|
(asHTML
|
||||||
|
(st-iv-set!
|
||||||
|
(mk-code "c" "py" "")
|
||||||
|
"text"
|
||||||
|
(list (mk-run "a=" (list :bold) "") (mk-run "1" (list) ""))))
|
||||||
|
"<pre><code class=\"language-py\">a=1</code></pre>")
|
||||||
|
|
||||||
|
;; ── (2) backward compat: plain-string CtText unchanged ──
|
||||||
|
(content-test
|
||||||
|
"plain html"
|
||||||
|
(asHTML (mk-text "q" "hi & <b>"))
|
||||||
|
"<p>hi & <b></p>")
|
||||||
|
(content-test "plain sx" (asSx (mk-text "q" "hi")) "(p \"hi\")")
|
||||||
|
(content-test "plain md" (asMarkdown (mk-text "q" "hi")) "hi")
|
||||||
|
(content-test "plain text" (asText (mk-text "q" "hi")) "hi")
|
||||||
|
(content-test
|
||||||
|
"plain heading html"
|
||||||
|
(asHTML (mk-heading "h" 3 "T"))
|
||||||
|
"<h3>T</h3>")
|
||||||
|
|
||||||
|
;; ── (3) find-replace across runs (per-run, marks preserved) ──
|
||||||
|
(define
|
||||||
|
frd
|
||||||
|
(doc-append
|
||||||
|
(doc-empty "d")
|
||||||
|
(mk-rich-text
|
||||||
|
"p"
|
||||||
|
(list
|
||||||
|
(mk-run "the Foo" (list :bold) "")
|
||||||
|
(mk-run " and Foo here" (list) "")))))
|
||||||
|
(define frr (content/find-replace frd "Foo" "Bar"))
|
||||||
|
(content-test
|
||||||
|
"find-replace rich plain text"
|
||||||
|
(asText frr)
|
||||||
|
"the Bar and Bar here")
|
||||||
|
(content-test
|
||||||
|
"find-replace rich preserves marks"
|
||||||
|
(asHTML frr)
|
||||||
|
"<p><strong>the Bar</strong> and Bar here</p>")
|
||||||
|
(content-test
|
||||||
|
"find-replace rich run0 still bold"
|
||||||
|
(nth (nth (blk-get (doc-find frr "p") "text") 0) 1)
|
||||||
|
(list "bold"))
|
||||||
|
|
||||||
|
;; ── (4) search-text via asText, across run boundary ──
|
||||||
|
;; "cat sat" spans run1 ("the cat") and run2 (" sat")
|
||||||
|
(define
|
||||||
|
sd
|
||||||
|
(doc-append
|
||||||
|
(doc-empty "d")
|
||||||
|
(mk-rich-text
|
||||||
|
"p"
|
||||||
|
(list (mk-run "the cat" (list :bold) "") (mk-run " sat" (list) "")))))
|
||||||
|
(content-test
|
||||||
|
"search finds substring across runs"
|
||||||
|
(content/search-text-ids sd "cat sat")
|
||||||
|
(list "p"))
|
||||||
|
(content-test "search miss" (content/search-text-ids sd "zzz") (list))
|
||||||
|
|
||||||
|
;; ── (5) CRDT invariant — runs are an opaque block-level value ──
|
||||||
|
(define ra (list (mk-run "x" (list :bold) "")))
|
||||||
|
(define rb (list (mk-run "y" (list :italic) "")))
|
||||||
|
(define
|
||||||
|
s1
|
||||||
|
(crdt-insert
|
||||||
|
(crdt-empty)
|
||||||
|
"p"
|
||||||
|
"text"
|
||||||
|
(crdt-pos 5 "a")
|
||||||
|
{:text ra}
|
||||||
|
1
|
||||||
|
"a"))
|
||||||
|
(define s2 (crdt-update s1 "p" "text" rb 2 "b"))
|
||||||
|
(content-test
|
||||||
|
"crdt merge commutes with runs"
|
||||||
|
(get (crdt-merge s1 s2) :elements)
|
||||||
|
(get (crdt-merge s2 s1) :elements))
|
||||||
|
(content-test
|
||||||
|
"crdt merge idempotent with runs"
|
||||||
|
(get (crdt-merge s2 s2) :elements)
|
||||||
|
(get s2 :elements))
|
||||||
|
;; LWW: later ts (rb, ts 2) wins; runs survive as the field value
|
||||||
|
(content-test
|
||||||
|
"crdt LWW keeps latest runs"
|
||||||
|
(asHTML
|
||||||
|
(crdt-element->block (get (get (crdt-merge s1 s2) :elements) "p")))
|
||||||
|
"<p><em>y</em></p>")
|
||||||
|
|
||||||
|
;; ── (6) data + wire round-trip runs losslessly ──
|
||||||
|
(content-test
|
||||||
|
"data round-trip rich html"
|
||||||
|
(asHTML (content/from-data (content/to-data rd)))
|
||||||
|
(asHTML rd))
|
||||||
|
(content-test
|
||||||
|
"data round-trip rich text"
|
||||||
|
(asText (content/from-data (content/to-data rd)))
|
||||||
|
"the cat and dog sat")
|
||||||
|
(content-test
|
||||||
|
"wire round-trip rich html"
|
||||||
|
(asHTML (content/from-wire (content/to-wire rd)))
|
||||||
|
(asHTML rd))
|
||||||
128
lib/content/tests/sanitize.sx
Normal file
128
lib/content/tests/sanitize.sx
Normal file
@@ -0,0 +1,128 @@
|
|||||||
|
;; Extension — make a document render-safe by dropping invalid blocks.
|
||||||
|
;; Counterpart to validate; reuses its per-block checks. Tree-wide.
|
||||||
|
|
||||||
|
(st-bootstrap-classes!)
|
||||||
|
(content-bootstrap-blocks!)
|
||||||
|
(content-bootstrap-doc!)
|
||||||
|
(content-bootstrap-section!)
|
||||||
|
|
||||||
|
;; ── a valid document is returned unchanged (same ids, tree order) ──
|
||||||
|
(define
|
||||||
|
good
|
||||||
|
(doc-append
|
||||||
|
(doc-append (doc-empty "d") (mk-heading "h" 1 "Title"))
|
||||||
|
(mk-text "p" "Body")))
|
||||||
|
(content-test
|
||||||
|
"valid doc keeps all blocks"
|
||||||
|
(doc-ids (content/sanitize good))
|
||||||
|
(list "h" "p"))
|
||||||
|
(content-test
|
||||||
|
"valid doc still valid after sanitize"
|
||||||
|
(content/valid? (content/sanitize good))
|
||||||
|
true)
|
||||||
|
|
||||||
|
;; ── a block with a bad field is dropped ──
|
||||||
|
(content-test
|
||||||
|
"bad-field block dropped"
|
||||||
|
(doc-ids
|
||||||
|
(content/sanitize
|
||||||
|
(doc-append
|
||||||
|
(doc-append (doc-empty "d") (mk-text "ok" "fine"))
|
||||||
|
(mk-heading "bad" "notnum" "T"))))
|
||||||
|
(list "ok"))
|
||||||
|
|
||||||
|
;; ── unknown block type dropped ──
|
||||||
|
(define raw (st-iv-set! (st-make-instance "CtBlock") "id" "z"))
|
||||||
|
(content-test
|
||||||
|
"unknown-type block dropped"
|
||||||
|
(doc-ids
|
||||||
|
(content/sanitize
|
||||||
|
(doc-append (doc-append (doc-empty "d") (mk-text "ok" "x")) raw)))
|
||||||
|
(list "ok"))
|
||||||
|
|
||||||
|
;; ── blank-id block dropped ──
|
||||||
|
(content-test
|
||||||
|
"blank-id block dropped"
|
||||||
|
(doc-ids
|
||||||
|
(content/sanitize
|
||||||
|
(doc-append
|
||||||
|
(doc-append (doc-empty "d") (mk-text "ok" "x"))
|
||||||
|
(mk-text "" "y"))))
|
||||||
|
(list "ok"))
|
||||||
|
|
||||||
|
;; ── result is render-safe: no id/field issues remain ──
|
||||||
|
(content-test
|
||||||
|
"sanitized has no field/id issues"
|
||||||
|
(len
|
||||||
|
(filter
|
||||||
|
(fn (i) (if (= (get i :kind) "field") true (= (get i :kind) "id")))
|
||||||
|
(content/validate
|
||||||
|
(content/sanitize
|
||||||
|
(doc-append
|
||||||
|
(doc-append (doc-empty "d") (mk-text "ok" "x"))
|
||||||
|
(mk-heading "bad" "notnum" "T"))))))
|
||||||
|
0)
|
||||||
|
|
||||||
|
;; ── immutability: original document untouched ──
|
||||||
|
(define
|
||||||
|
withbad
|
||||||
|
(doc-append
|
||||||
|
(doc-append (doc-empty "d") (mk-text "ok" "x"))
|
||||||
|
(mk-heading "bad" "notnum" "T")))
|
||||||
|
(define _ (content/sanitize withbad))
|
||||||
|
(content-test "original unchanged" (doc-ids withbad) (list "ok" "bad"))
|
||||||
|
|
||||||
|
;; ── tree-wide: invalid nested child pruned, valid sibling + section kept ──
|
||||||
|
(define
|
||||||
|
nested
|
||||||
|
(doc-append
|
||||||
|
(doc-empty "d")
|
||||||
|
(mk-section
|
||||||
|
"s"
|
||||||
|
(list (mk-text "good" "keep") (mk-heading "badc" "notnum" "X")))))
|
||||||
|
(content-test
|
||||||
|
"invalid nested child pruned, section kept"
|
||||||
|
(doc-tree-ids (content/sanitize nested))
|
||||||
|
(list "s" "good"))
|
||||||
|
|
||||||
|
;; ── a section whose own shell is invalid (children not a list) is dropped ──
|
||||||
|
(define
|
||||||
|
badsec
|
||||||
|
(doc-append
|
||||||
|
(doc-append (doc-empty "d") (mk-text "ok" "x"))
|
||||||
|
(st-iv-set! (mk-section "s" (list)) "children" "nope")))
|
||||||
|
(content-test
|
||||||
|
"invalid section shell dropped whole"
|
||||||
|
(doc-tree-ids (content/sanitize badsec))
|
||||||
|
(list "ok"))
|
||||||
|
|
||||||
|
;; ── a valid section that loses all children is kept (empty) — sanitize is not
|
||||||
|
;; normalize; it removes invalid, not empty ──
|
||||||
|
(define
|
||||||
|
allbadchildren
|
||||||
|
(doc-append
|
||||||
|
(doc-empty "d")
|
||||||
|
(mk-section "s" (list (mk-heading "b1" "x" "X") (mk-text "" "y")))))
|
||||||
|
(content-test
|
||||||
|
"section kept though emptied of invalid children"
|
||||||
|
(doc-tree-ids (content/sanitize allbadchildren))
|
||||||
|
(list "s"))
|
||||||
|
|
||||||
|
;; ── deeply nested: invalid block two levels down is pruned ──
|
||||||
|
(define
|
||||||
|
deep
|
||||||
|
(doc-append
|
||||||
|
(doc-empty "d")
|
||||||
|
(mk-section
|
||||||
|
"o"
|
||||||
|
(list (mk-section "i" (list (mk-text "dok" "x") (mk-text "" "bad")))))))
|
||||||
|
(content-test
|
||||||
|
"deep invalid pruned"
|
||||||
|
(doc-tree-ids (content/sanitize deep))
|
||||||
|
(list "o" "i" "dok"))
|
||||||
|
|
||||||
|
;; ── empty document sanitizes to empty ──
|
||||||
|
(content-test
|
||||||
|
"empty doc stays empty"
|
||||||
|
(doc-ids (content/sanitize (doc-empty "e")))
|
||||||
|
(list))
|
||||||
@@ -5,6 +5,7 @@
|
|||||||
(content-bootstrap-blocks!)
|
(content-bootstrap-blocks!)
|
||||||
(content-bootstrap-doc!)
|
(content-bootstrap-doc!)
|
||||||
(content-bootstrap-section!)
|
(content-bootstrap-section!)
|
||||||
|
(content-bootstrap-table!)
|
||||||
|
|
||||||
;; ── a fully valid document ──
|
;; ── a fully valid document ──
|
||||||
(define
|
(define
|
||||||
@@ -164,3 +165,62 @@
|
|||||||
(content/validate dup-tree)))
|
(content/validate dup-tree)))
|
||||||
1)
|
1)
|
||||||
(content-test "tree dup not valid" (content/valid? dup-tree) false)
|
(content-test "tree dup not valid" (content/valid? dup-tree) false)
|
||||||
|
|
||||||
|
;; ── collection blocks vetted ELEMENT-DEEP (items/cells must be strings) ──
|
||||||
|
;; A list whose items field is a list but holds a non-string would pass the old
|
||||||
|
;; "is a list" check yet crash asText/render — now caught.
|
||||||
|
(content-test
|
||||||
|
"list non-string item flagged"
|
||||||
|
(content/issue-kinds
|
||||||
|
(doc-append (doc-empty "d") (mk-list "l" true (list "a" 5))))
|
||||||
|
(list "field"))
|
||||||
|
(content-test
|
||||||
|
"list all-string items valid"
|
||||||
|
(content/valid?
|
||||||
|
(doc-append (doc-empty "d") (mk-list "l" false (list "a" "b" "c"))))
|
||||||
|
true)
|
||||||
|
(content-test
|
||||||
|
"list empty items valid"
|
||||||
|
(content/valid? (doc-append (doc-empty "d") (mk-list "l" true (list))))
|
||||||
|
true)
|
||||||
|
;; a malformed-list block reports exactly one element issue (not the is-a-list one)
|
||||||
|
(content-test
|
||||||
|
"list non-string item single issue"
|
||||||
|
(len
|
||||||
|
(content/validate
|
||||||
|
(doc-append
|
||||||
|
(doc-empty "d")
|
||||||
|
(mk-list "l" true (list 1 2)))))
|
||||||
|
1)
|
||||||
|
|
||||||
|
(content-test
|
||||||
|
"valid table ok"
|
||||||
|
(content/valid?
|
||||||
|
(doc-append
|
||||||
|
(doc-empty "d")
|
||||||
|
(mk-table "t" (list "H1" "H2") (list (list "a" "b") (list "c" "d")))))
|
||||||
|
true)
|
||||||
|
(content-test
|
||||||
|
"table empty rows valid"
|
||||||
|
(content/valid?
|
||||||
|
(doc-append (doc-empty "d") (mk-table "t" (list "H") (list))))
|
||||||
|
true)
|
||||||
|
(content-test
|
||||||
|
"table non-list row flagged"
|
||||||
|
(content/issue-kinds
|
||||||
|
(doc-append (doc-empty "d") (mk-table "t" (list "H") (list "notarow"))))
|
||||||
|
(list "field"))
|
||||||
|
(content-test
|
||||||
|
"table non-string cell flagged"
|
||||||
|
(content/issue-kinds
|
||||||
|
(doc-append
|
||||||
|
(doc-empty "d")
|
||||||
|
(mk-table "t" (list "H") (list (list "ok") (list 9)))))
|
||||||
|
(list "field"))
|
||||||
|
(content-test
|
||||||
|
"table non-string header flagged"
|
||||||
|
(content/issue-kinds
|
||||||
|
(doc-append
|
||||||
|
(doc-empty "d")
|
||||||
|
(mk-table "t" (list "H" 2) (list (list "a" "b")))))
|
||||||
|
(list "field"))
|
||||||
|
|||||||
@@ -6,6 +6,11 @@
|
|||||||
;; Tree detection is inline (class + st-iv-get) so this file needs no section.sx.
|
;; Tree detection is inline (class + st-iv-get) so this file needs no section.sx.
|
||||||
;; Dispatch on block type is a validation-boundary concern, not core behaviour.
|
;; Dispatch on block type is a validation-boundary concern, not core behaviour.
|
||||||
;;
|
;;
|
||||||
|
;; Collection blocks are vetted element-deep: list items must all be strings and
|
||||||
|
;; table rows must all be lists of strings — exactly what render/asText/
|
||||||
|
;; find-replace/search assume — so malformed nested collections are caught at the
|
||||||
|
;; boundary instead of crashing the render layer downstream.
|
||||||
|
;;
|
||||||
;; Requires (loaded by harness): block.sx, doc.sx.
|
;; Requires (loaded by harness): block.sx, doc.sx.
|
||||||
|
|
||||||
(define ct-issue (fn (id kind detail) {:id id :detail detail :kind kind}))
|
(define ct-issue (fn (id kind detail) {:id id :detail detail :kind kind}))
|
||||||
@@ -36,6 +41,28 @@
|
|||||||
|
|
||||||
(define ct-uniq (fn (xs) (ct-uniq-loop xs (list))))
|
(define ct-uniq (fn (xs) (ct-uniq-loop xs (list))))
|
||||||
|
|
||||||
|
;; every element a string? / every row a list of strings? (for collection blocks)
|
||||||
|
(define
|
||||||
|
ct-all-str?
|
||||||
|
(fn
|
||||||
|
(xs)
|
||||||
|
(if
|
||||||
|
(= (len xs) 0)
|
||||||
|
true
|
||||||
|
(if (string? (first xs)) (ct-all-str? (rest xs)) false))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
ct-all-rows?
|
||||||
|
(fn
|
||||||
|
(rows)
|
||||||
|
(if
|
||||||
|
(= (len rows) 0)
|
||||||
|
true
|
||||||
|
(if
|
||||||
|
(if (list? (first rows)) (ct-all-str? (first rows)) false)
|
||||||
|
(ct-all-rows? (rest rows))
|
||||||
|
false))))
|
||||||
|
|
||||||
;; ── tree flatten (descends into CtSection children; guards malformed children) ──
|
;; ── tree flatten (descends into CtSection children; guards malformed children) ──
|
||||||
(define
|
(define
|
||||||
ct-section-block?
|
ct-section-block?
|
||||||
@@ -136,30 +163,43 @@
|
|||||||
"embed provider must be a string")))
|
"embed provider must be a string")))
|
||||||
((= t "divider") (list))
|
((= t "divider") (list))
|
||||||
((= t "list")
|
((= t "list")
|
||||||
|
(let
|
||||||
|
((items (blk-get b "items")))
|
||||||
(append
|
(append
|
||||||
(ct-field-issue
|
(ct-field-issue
|
||||||
id
|
id
|
||||||
(boolean? (blk-get b "ordered"))
|
(boolean? (blk-get b "ordered"))
|
||||||
"list ordered must be a boolean")
|
"list ordered must be a boolean")
|
||||||
|
(append
|
||||||
|
(ct-field-issue id (list? items) "list items must be a list")
|
||||||
(ct-field-issue
|
(ct-field-issue
|
||||||
id
|
id
|
||||||
(list? (blk-get b "items"))
|
(if (list? items) (ct-all-str? items) true)
|
||||||
"list items must be a list")))
|
"list items must all be strings")))))
|
||||||
((= t "section")
|
((= t "section")
|
||||||
(ct-field-issue
|
(ct-field-issue
|
||||||
id
|
id
|
||||||
(list? (blk-get b "children"))
|
(list? (blk-get b "children"))
|
||||||
"section children must be a list"))
|
"section children must be a list"))
|
||||||
((= t "table")
|
((= t "table")
|
||||||
|
(let
|
||||||
|
((headers (blk-get b "headers")) (rows (blk-get b "rows")))
|
||||||
|
(append
|
||||||
(append
|
(append
|
||||||
(ct-field-issue
|
(ct-field-issue
|
||||||
id
|
id
|
||||||
(list? (blk-get b "headers"))
|
(list? headers)
|
||||||
"table headers must be a list")
|
"table headers must be a list")
|
||||||
(ct-field-issue
|
(ct-field-issue
|
||||||
id
|
id
|
||||||
(list? (blk-get b "rows"))
|
(if (list? headers) (ct-all-str? headers) true)
|
||||||
"table rows must be a list")))
|
"table headers must all be strings"))
|
||||||
|
(append
|
||||||
|
(ct-field-issue id (list? rows) "table rows must be a list")
|
||||||
|
(ct-field-issue
|
||||||
|
id
|
||||||
|
(if (list? rows) (ct-all-rows? rows) true)
|
||||||
|
"table rows must all be lists of strings")))))
|
||||||
((= t "callout")
|
((= t "callout")
|
||||||
(append
|
(append
|
||||||
(ct-field-issue
|
(ct-field-issue
|
||||||
|
|||||||
@@ -1,68 +0,0 @@
|
|||||||
# Erlang-on-SX conformance config — sourced by lib/guest/conformance.sh.
|
|
||||||
#
|
|
||||||
# Erlang's suites load into one session and each exposes a pass counter and a
|
|
||||||
# *count* (total) counter — not a fail counter. dict mode fits cleanly: each
|
|
||||||
# runner is a dict literal computing :failed as count - pass. (counters mode
|
|
||||||
# would misread the count counter as a fail counter.)
|
|
||||||
|
|
||||||
LANG_NAME=erlang
|
|
||||||
MODE=dict
|
|
||||||
|
|
||||||
PRELOADS=(
|
|
||||||
lib/erlang/tokenizer.sx
|
|
||||||
lib/erlang/parser.sx
|
|
||||||
lib/erlang/parser-core.sx
|
|
||||||
lib/erlang/parser-expr.sx
|
|
||||||
lib/erlang/parser-module.sx
|
|
||||||
lib/erlang/transpile.sx
|
|
||||||
lib/erlang/runtime.sx
|
|
||||||
lib/erlang/vm/dispatcher.sx
|
|
||||||
)
|
|
||||||
|
|
||||||
# name:file:(runner) — runner is a dict literal {:passed :failed :total}.
|
|
||||||
SUITES=(
|
|
||||||
"tokenize:lib/erlang/tests/tokenize.sx:{:passed er-test-pass :failed (- er-test-count er-test-pass) :total er-test-count}"
|
|
||||||
"parse:lib/erlang/tests/parse.sx:{:passed er-parse-test-pass :failed (- er-parse-test-count er-parse-test-pass) :total er-parse-test-count}"
|
|
||||||
"eval:lib/erlang/tests/eval.sx:{:passed er-eval-test-pass :failed (- er-eval-test-count er-eval-test-pass) :total er-eval-test-count}"
|
|
||||||
"runtime:lib/erlang/tests/runtime.sx:{:passed er-rt-test-pass :failed (- er-rt-test-count er-rt-test-pass) :total er-rt-test-count}"
|
|
||||||
"ring:lib/erlang/tests/programs/ring.sx:{:passed er-ring-test-pass :failed (- er-ring-test-count er-ring-test-pass) :total er-ring-test-count}"
|
|
||||||
"ping-pong:lib/erlang/tests/programs/ping_pong.sx:{:passed er-pp-test-pass :failed (- er-pp-test-count er-pp-test-pass) :total er-pp-test-count}"
|
|
||||||
"bank:lib/erlang/tests/programs/bank.sx:{:passed er-bank-test-pass :failed (- er-bank-test-count er-bank-test-pass) :total er-bank-test-count}"
|
|
||||||
"echo:lib/erlang/tests/programs/echo.sx:{:passed er-echo-test-pass :failed (- er-echo-test-count er-echo-test-pass) :total er-echo-test-count}"
|
|
||||||
"fib:lib/erlang/tests/programs/fib_server.sx:{:passed er-fib-test-pass :failed (- er-fib-test-count er-fib-test-pass) :total er-fib-test-count}"
|
|
||||||
"ffi:lib/erlang/tests/ffi.sx:{:passed er-ffi-test-pass :failed (- er-ffi-test-count er-ffi-test-pass) :total er-ffi-test-count}"
|
|
||||||
"vm:lib/erlang/tests/vm.sx:{:passed er-vm-test-pass :failed (- er-vm-test-count er-vm-test-pass) :total er-vm-test-count}"
|
|
||||||
)
|
|
||||||
|
|
||||||
# Preserve the historical scoreboard schema so consumers of
|
|
||||||
# lib/erlang/scoreboard.json keep working.
|
|
||||||
emit_scoreboard_json() {
|
|
||||||
local n=${#GC_NAMES[@]} i status
|
|
||||||
printf '{\n'
|
|
||||||
printf ' "language": "erlang",\n'
|
|
||||||
printf ' "total_pass": %d,\n' "$GC_TOTAL_PASS"
|
|
||||||
printf ' "total": %d,\n' "$GC_TOTAL"
|
|
||||||
printf ' "suites": ['
|
|
||||||
for ((i=0; i<n; i++)); do
|
|
||||||
[ "$i" -gt 0 ] && printf ','
|
|
||||||
status="ok"; [ "${GC_FAIL[$i]}" -gt 0 ] && status="fail"
|
|
||||||
printf '\n {"name":"%s","pass":%d,"total":%d,"status":"%s"}' \
|
|
||||||
"${GC_NAMES[$i]}" "${GC_PASS[$i]}" "${GC_TOTAL_S[$i]}" "$status"
|
|
||||||
done
|
|
||||||
printf '\n ]\n'
|
|
||||||
printf '}\n'
|
|
||||||
}
|
|
||||||
|
|
||||||
emit_scoreboard_md() {
|
|
||||||
local n=${#GC_NAMES[@]} i marker
|
|
||||||
printf '# Erlang-on-SX Scoreboard\n\n'
|
|
||||||
printf '**Total: %d / %d tests passing**\n\n' "$GC_TOTAL_PASS" "$GC_TOTAL"
|
|
||||||
printf '| | Suite | Pass | Total |\n'
|
|
||||||
printf '|---|---|---|---|\n'
|
|
||||||
for ((i=0; i<n; i++)); do
|
|
||||||
marker="✅"; [ "${GC_FAIL[$i]}" -gt 0 ] && marker="❌"
|
|
||||||
printf '| %s | %s | %d | %d |\n' \
|
|
||||||
"$marker" "${GC_NAMES[$i]}" "${GC_PASS[$i]}" "${GC_TOTAL_S[$i]}"
|
|
||||||
done
|
|
||||||
printf '\nGenerated by `lib/erlang/conformance.sh`.\n'
|
|
||||||
}
|
|
||||||
@@ -1,3 +1,162 @@
|
|||||||
#!/usr/bin/env bash
|
#!/usr/bin/env bash
|
||||||
# Thin wrapper — see lib/guest/conformance.sh and lib/erlang/conformance.conf.
|
# Erlang-on-SX conformance runner.
|
||||||
exec bash "$(dirname "$0")/../guest/conformance.sh" "$(dirname "$0")/conformance.conf" "$@"
|
#
|
||||||
|
# Loads every erlang test suite via the epoch protocol, collects
|
||||||
|
# pass/fail counts, and writes lib/erlang/scoreboard.json + .md.
|
||||||
|
#
|
||||||
|
# Usage:
|
||||||
|
# bash lib/erlang/conformance.sh # run all suites
|
||||||
|
# bash lib/erlang/conformance.sh -v # verbose per-suite
|
||||||
|
|
||||||
|
set -uo pipefail
|
||||||
|
cd "$(git rev-parse --show-toplevel)"
|
||||||
|
|
||||||
|
SX_SERVER="${SX_SERVER:-hosts/ocaml/_build/default/bin/sx_server.exe}"
|
||||||
|
if [ ! -x "$SX_SERVER" ]; then
|
||||||
|
SX_SERVER="/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe"
|
||||||
|
fi
|
||||||
|
if [ ! -x "$SX_SERVER" ]; then
|
||||||
|
echo "ERROR: sx_server.exe not found." >&2
|
||||||
|
exit 1
|
||||||
|
fi
|
||||||
|
|
||||||
|
VERBOSE="${1:-}"
|
||||||
|
TMPFILE=$(mktemp)
|
||||||
|
OUTFILE=$(mktemp)
|
||||||
|
trap "rm -f $TMPFILE $OUTFILE" EXIT
|
||||||
|
|
||||||
|
# Each suite: name | counter pass | counter total
|
||||||
|
SUITES=(
|
||||||
|
"tokenize|er-test-pass|er-test-count"
|
||||||
|
"parse|er-parse-test-pass|er-parse-test-count"
|
||||||
|
"eval|er-eval-test-pass|er-eval-test-count"
|
||||||
|
"runtime|er-rt-test-pass|er-rt-test-count"
|
||||||
|
"ring|er-ring-test-pass|er-ring-test-count"
|
||||||
|
"ping-pong|er-pp-test-pass|er-pp-test-count"
|
||||||
|
"bank|er-bank-test-pass|er-bank-test-count"
|
||||||
|
"echo|er-echo-test-pass|er-echo-test-count"
|
||||||
|
"fib|er-fib-test-pass|er-fib-test-count"
|
||||||
|
"ffi|er-ffi-test-pass|er-ffi-test-count"
|
||||||
|
"vm|er-vm-test-pass|er-vm-test-count"
|
||||||
|
)
|
||||||
|
|
||||||
|
cat > "$TMPFILE" << 'EPOCHS'
|
||||||
|
(epoch 1)
|
||||||
|
(load "lib/erlang/tokenizer.sx")
|
||||||
|
(load "lib/erlang/parser.sx")
|
||||||
|
(load "lib/erlang/parser-core.sx")
|
||||||
|
(load "lib/erlang/parser-expr.sx")
|
||||||
|
(load "lib/erlang/parser-module.sx")
|
||||||
|
(load "lib/erlang/transpile.sx")
|
||||||
|
(load "lib/erlang/runtime.sx")
|
||||||
|
(load "lib/erlang/tests/tokenize.sx")
|
||||||
|
(load "lib/erlang/tests/parse.sx")
|
||||||
|
(load "lib/erlang/tests/eval.sx")
|
||||||
|
(load "lib/erlang/tests/runtime.sx")
|
||||||
|
(load "lib/erlang/tests/programs/ring.sx")
|
||||||
|
(load "lib/erlang/tests/programs/ping_pong.sx")
|
||||||
|
(load "lib/erlang/tests/programs/bank.sx")
|
||||||
|
(load "lib/erlang/tests/programs/echo.sx")
|
||||||
|
(load "lib/erlang/tests/programs/fib_server.sx")
|
||||||
|
(load "lib/erlang/vm/dispatcher.sx")
|
||||||
|
(load "lib/erlang/tests/ffi.sx")
|
||||||
|
(load "lib/erlang/tests/vm.sx")
|
||||||
|
(epoch 100)
|
||||||
|
(eval "(list er-test-pass er-test-count)")
|
||||||
|
(epoch 101)
|
||||||
|
(eval "(list er-parse-test-pass er-parse-test-count)")
|
||||||
|
(epoch 102)
|
||||||
|
(eval "(list er-eval-test-pass er-eval-test-count)")
|
||||||
|
(epoch 103)
|
||||||
|
(eval "(list er-rt-test-pass er-rt-test-count)")
|
||||||
|
(epoch 104)
|
||||||
|
(eval "(list er-ring-test-pass er-ring-test-count)")
|
||||||
|
(epoch 105)
|
||||||
|
(eval "(list er-pp-test-pass er-pp-test-count)")
|
||||||
|
(epoch 106)
|
||||||
|
(eval "(list er-bank-test-pass er-bank-test-count)")
|
||||||
|
(epoch 107)
|
||||||
|
(eval "(list er-echo-test-pass er-echo-test-count)")
|
||||||
|
(epoch 108)
|
||||||
|
(eval "(list er-fib-test-pass er-fib-test-count)")
|
||||||
|
(epoch 109)
|
||||||
|
(eval "(list er-ffi-test-pass er-ffi-test-count)")
|
||||||
|
(epoch 110)
|
||||||
|
(eval "(list er-vm-test-pass er-vm-test-count)")
|
||||||
|
EPOCHS
|
||||||
|
|
||||||
|
timeout 600 "$SX_SERVER" < "$TMPFILE" > "$OUTFILE" 2>&1
|
||||||
|
|
||||||
|
# Parse "(N M)" from the line after each "(ok-len <epoch> ...)" marker.
|
||||||
|
parse_pair() {
|
||||||
|
local epoch="$1"
|
||||||
|
local line
|
||||||
|
line=$(grep -A1 "^(ok-len $epoch " "$OUTFILE" | tail -1)
|
||||||
|
echo "$line" | sed -E 's/[()]//g'
|
||||||
|
}
|
||||||
|
|
||||||
|
TOTAL_PASS=0
|
||||||
|
TOTAL_COUNT=0
|
||||||
|
JSON_SUITES=""
|
||||||
|
MD_ROWS=""
|
||||||
|
|
||||||
|
idx=0
|
||||||
|
for entry in "${SUITES[@]}"; do
|
||||||
|
name="${entry%%|*}"
|
||||||
|
epoch=$((100 + idx))
|
||||||
|
pair=$(parse_pair "$epoch")
|
||||||
|
pass=$(echo "$pair" | awk '{print $1}')
|
||||||
|
count=$(echo "$pair" | awk '{print $2}')
|
||||||
|
if [ -z "$pass" ] || [ -z "$count" ]; then
|
||||||
|
pass=0
|
||||||
|
count=0
|
||||||
|
fi
|
||||||
|
TOTAL_PASS=$((TOTAL_PASS + pass))
|
||||||
|
TOTAL_COUNT=$((TOTAL_COUNT + count))
|
||||||
|
status="ok"
|
||||||
|
marker="✅"
|
||||||
|
if [ "$pass" != "$count" ]; then
|
||||||
|
status="fail"
|
||||||
|
marker="❌"
|
||||||
|
fi
|
||||||
|
if [ "$VERBOSE" = "-v" ]; then
|
||||||
|
printf " %-12s %s/%s\n" "$name" "$pass" "$count"
|
||||||
|
fi
|
||||||
|
if [ -n "$JSON_SUITES" ]; then JSON_SUITES+=","; fi
|
||||||
|
JSON_SUITES+=$'\n '
|
||||||
|
JSON_SUITES+="{\"name\":\"$name\",\"pass\":$pass,\"total\":$count,\"status\":\"$status\"}"
|
||||||
|
MD_ROWS+="| $marker | $name | $pass | $count |"$'\n'
|
||||||
|
idx=$((idx + 1))
|
||||||
|
done
|
||||||
|
|
||||||
|
printf '\nErlang-on-SX conformance: %d / %d\n' "$TOTAL_PASS" "$TOTAL_COUNT"
|
||||||
|
|
||||||
|
# scoreboard.json
|
||||||
|
cat > lib/erlang/scoreboard.json <<JSON
|
||||||
|
{
|
||||||
|
"language": "erlang",
|
||||||
|
"total_pass": $TOTAL_PASS,
|
||||||
|
"total": $TOTAL_COUNT,
|
||||||
|
"suites": [$JSON_SUITES
|
||||||
|
]
|
||||||
|
}
|
||||||
|
JSON
|
||||||
|
|
||||||
|
# scoreboard.md
|
||||||
|
cat > lib/erlang/scoreboard.md <<MD
|
||||||
|
# Erlang-on-SX Scoreboard
|
||||||
|
|
||||||
|
**Total: ${TOTAL_PASS} / ${TOTAL_COUNT} tests passing**
|
||||||
|
|
||||||
|
| | Suite | Pass | Total |
|
||||||
|
|---|---|---|---|
|
||||||
|
$MD_ROWS
|
||||||
|
|
||||||
|
Generated by \`lib/erlang/conformance.sh\`.
|
||||||
|
MD
|
||||||
|
|
||||||
|
if [ "$TOTAL_PASS" -eq "$TOTAL_COUNT" ]; then
|
||||||
|
exit 0
|
||||||
|
else
|
||||||
|
exit 1
|
||||||
|
fi
|
||||||
|
|||||||
@@ -16,4 +16,5 @@
|
|||||||
| ✅ | ffi | 37 | 37 |
|
| ✅ | ffi | 37 | 37 |
|
||||||
| ✅ | vm | 78 | 78 |
|
| ✅ | vm | 78 | 78 |
|
||||||
|
|
||||||
|
|
||||||
Generated by `lib/erlang/conformance.sh`.
|
Generated by `lib/erlang/conformance.sh`.
|
||||||
|
|||||||
@@ -1485,15 +1485,9 @@
|
|||||||
(size (er-eval-binary-size (get seg :size) env)))
|
(size (er-eval-binary-size (get seg :size) env)))
|
||||||
(cond
|
(cond
|
||||||
(= spec "integer")
|
(= spec "integer")
|
||||||
(cond
|
|
||||||
(= (type-of val) "string")
|
|
||||||
(for-each
|
|
||||||
(fn (c) (er-emit-int! out (char->integer c) 8))
|
|
||||||
(string->list val))
|
|
||||||
:else
|
|
||||||
(let
|
(let
|
||||||
((bits (if (= size nil) 8 size)))
|
((bits (if (= size nil) 8 size)))
|
||||||
(er-emit-int! out val bits)))
|
(er-emit-int! out val bits))
|
||||||
(= spec "binary")
|
(= spec "binary")
|
||||||
(cond
|
(cond
|
||||||
(er-binary? val)
|
(er-binary? val)
|
||||||
|
|||||||
@@ -1,277 +0,0 @@
|
|||||||
;; lib/events/api.sx — public events surface over calendar + availability.
|
|
||||||
;;
|
|
||||||
;; A `store` is an immutable value holding scheduled events and (in-memory)
|
|
||||||
;; bookings:
|
|
||||||
;;
|
|
||||||
;; {:events (event ...) :bookings ((actor key) ...)}
|
|
||||||
;;
|
|
||||||
;; The in-memory `:bookings` list supports pure, value-level queries. The
|
|
||||||
;; DURABLE booking path (ev/*-occ! and ev/*-p) keeps bookings in persist
|
|
||||||
;; streams via booking.sx — capacity-safe, cancellable, replayable — and
|
|
||||||
;; derives availability from those streams. Use the persist path for real
|
|
||||||
;; bookings; the in-memory path for projections and tests.
|
|
||||||
;;
|
|
||||||
;; All queries are windowed: agenda/free/next-free expand recurring events into
|
|
||||||
;; concrete occurrences within an explicit (or derived) window before running
|
|
||||||
;; the Datalog availability rules.
|
|
||||||
|
|
||||||
(define ev/store (fn (events bookings) {:bookings bookings :events events}))
|
|
||||||
|
|
||||||
(define ev/empty (fn () (ev/store (list) (list))))
|
|
||||||
|
|
||||||
(define ev/events (fn (store) (get store :events)))
|
|
||||||
(define ev/bookings (fn (store) (get store :bookings)))
|
|
||||||
|
|
||||||
;; Add a (constructed) event to the store.
|
|
||||||
(define
|
|
||||||
ev/add-event
|
|
||||||
(fn
|
|
||||||
(store event)
|
|
||||||
(ev/store (cons event (ev/events store)) (ev/bookings store))))
|
|
||||||
|
|
||||||
;; Schedule a fresh event from parts, returning the updated store. rrule may be
|
|
||||||
;; nil for a one-off. (Booking is separate — see ev/book.)
|
|
||||||
(define
|
|
||||||
ev/schedule
|
|
||||||
(fn
|
|
||||||
(store id dtstart duration rrule capacity)
|
|
||||||
(ev/add-event store (ev-event id dtstart duration rrule capacity))))
|
|
||||||
|
|
||||||
;; Record that `actor` holds the occurrence with `key` (in-memory only — see
|
|
||||||
;; ev/book-occ! for the durable, capacity-safe path).
|
|
||||||
(define
|
|
||||||
ev/book
|
|
||||||
(fn
|
|
||||||
(store actor key)
|
|
||||||
(ev/store
|
|
||||||
(ev/events store)
|
|
||||||
(cons (list actor key) (ev/bookings store)))))
|
|
||||||
|
|
||||||
;; The event with `id`, or nil.
|
|
||||||
(define
|
|
||||||
ev/event-by-id
|
|
||||||
(fn
|
|
||||||
(store id)
|
|
||||||
(reduce
|
|
||||||
(fn
|
|
||||||
(found ev)
|
|
||||||
(if (nil? found) (if (= (get ev :id) id) ev found) found))
|
|
||||||
nil
|
|
||||||
(ev/events store))))
|
|
||||||
|
|
||||||
;; Capacity of the event an occurrence belongs to (0 if unknown).
|
|
||||||
(define
|
|
||||||
ev/capacity-of
|
|
||||||
(fn
|
|
||||||
(store occ)
|
|
||||||
(let
|
|
||||||
((ev (ev/event-by-id store (get occ :id))))
|
|
||||||
(if (nil? ev) 0 (get ev :capacity)))))
|
|
||||||
|
|
||||||
;; The maximum event duration in the store (0 when empty) — used to widen
|
|
||||||
;; expansion windows so any occurrence overlapping a query is captured.
|
|
||||||
(define
|
|
||||||
ev/store-max-duration
|
|
||||||
(fn
|
|
||||||
(store)
|
|
||||||
(reduce
|
|
||||||
(fn (m ev) (max m (get ev :duration)))
|
|
||||||
0
|
|
||||||
(ev/events store))))
|
|
||||||
|
|
||||||
;; All occurrences across all events within [ws, we), ascending by start.
|
|
||||||
(define
|
|
||||||
ev/agenda
|
|
||||||
(fn (store ws we) (ev-expand-all (ev/events store) ws we)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
ev-key-member?
|
|
||||||
(fn
|
|
||||||
(k keys)
|
|
||||||
(cond
|
|
||||||
((empty? keys) false)
|
|
||||||
((= k (first keys)) true)
|
|
||||||
(else (ev-key-member? k (rest keys))))))
|
|
||||||
|
|
||||||
;; Occurrence keys `actor` has booked (in-memory store).
|
|
||||||
(define
|
|
||||||
ev/actor-keys
|
|
||||||
(fn
|
|
||||||
(store actor)
|
|
||||||
(reduce
|
|
||||||
(fn
|
|
||||||
(acc b)
|
|
||||||
(if (= (first b) actor) (cons (first (rest b)) acc) acc))
|
|
||||||
(list)
|
|
||||||
(ev/bookings store))))
|
|
||||||
|
|
||||||
;; The agenda restricted to occurrences `actor` is booked into (in-memory).
|
|
||||||
(define
|
|
||||||
ev/agenda-for
|
|
||||||
(fn
|
|
||||||
(store actor ws we)
|
|
||||||
(let
|
|
||||||
((keys (ev/actor-keys store actor)))
|
|
||||||
(filter
|
|
||||||
(fn (o) (ev-key-member? (ev-occ-key o) keys))
|
|
||||||
(ev/agenda store ws we)))))
|
|
||||||
|
|
||||||
;; Build an availability db over occurrences expanded in [ws, we) using the
|
|
||||||
;; in-memory bookings.
|
|
||||||
(define
|
|
||||||
ev/avail-window-db
|
|
||||||
(fn
|
|
||||||
(store ws we)
|
|
||||||
(ev-avail-db (ev/agenda store ws we) (ev/bookings store))))
|
|
||||||
|
|
||||||
;; Is `actor` free across [qs, qe)? Expands a window wide enough (back by the
|
|
||||||
;; longest event) to capture any occurrence that could overlap.
|
|
||||||
(define
|
|
||||||
ev/free?
|
|
||||||
(fn
|
|
||||||
(store actor qs qe)
|
|
||||||
(ev-free?
|
|
||||||
(ev/avail-window-db store (- qs (ev/store-max-duration store)) qe)
|
|
||||||
actor
|
|
||||||
qs
|
|
||||||
qe)))
|
|
||||||
|
|
||||||
;; Earliest free slot of `duration` for `actor` in [after, horizon), or nil.
|
|
||||||
(define
|
|
||||||
ev/next-free
|
|
||||||
(fn
|
|
||||||
(store actor after duration horizon)
|
|
||||||
(ev-next-free
|
|
||||||
(ev/avail-window-db
|
|
||||||
store
|
|
||||||
(- after (ev/store-max-duration store))
|
|
||||||
horizon)
|
|
||||||
actor
|
|
||||||
after
|
|
||||||
duration
|
|
||||||
horizon)))
|
|
||||||
|
|
||||||
;; Overlapping double-bookings for `actor` among occurrences in [ws, we).
|
|
||||||
(define
|
|
||||||
ev/conflicts
|
|
||||||
(fn
|
|
||||||
(store actor ws we)
|
|
||||||
(ev-conflicts (ev/avail-window-db store ws we) actor)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
ev/has-conflict?
|
|
||||||
(fn
|
|
||||||
(store actor ws we)
|
|
||||||
(> (len (ev/conflicts store actor ws we)) 0)))
|
|
||||||
|
|
||||||
;; ---- durable, persist-backed booking path ----
|
|
||||||
;; These take a persist backend `b` (persist/open) plus the schedule `store`.
|
|
||||||
;; Bookings live in per-occurrence streams (booking.sx); availability is derived
|
|
||||||
;; by replaying those streams for the occurrences in the query window.
|
|
||||||
|
|
||||||
;; Durably book `actor` into occurrence `occ` (dict {:id :start :end}),
|
|
||||||
;; capacity-safe. Returns the booking.sx result (:booked / :full / :already).
|
|
||||||
(define
|
|
||||||
ev/book-occ!
|
|
||||||
(fn
|
|
||||||
(b store actor occ)
|
|
||||||
(ev/book! b (ev-occ-key occ) (ev/capacity-of store occ) actor)))
|
|
||||||
|
|
||||||
;; Durably cancel `actor`'s seat on `occ`, freeing capacity.
|
|
||||||
(define
|
|
||||||
ev/cancel-occ!
|
|
||||||
(fn (b store actor occ) (ev/cancel! b (ev-occ-key occ) actor)))
|
|
||||||
|
|
||||||
;; Live roster / seats-left for a specific occurrence from persist.
|
|
||||||
(define ev/roster-occ (fn (b occ) (ev/roster b (ev-occ-key occ))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
ev/seats-left-occ
|
|
||||||
(fn
|
|
||||||
(b store occ)
|
|
||||||
(ev/seats-left b (ev-occ-key occ) (ev/capacity-of store occ))))
|
|
||||||
|
|
||||||
;; Derive (actor key) booking pairs from the persist rosters of `occs`.
|
|
||||||
(define
|
|
||||||
ev/persist-bookings
|
|
||||||
(fn
|
|
||||||
(b occs)
|
|
||||||
(reduce
|
|
||||||
(fn
|
|
||||||
(acc occ)
|
|
||||||
(let
|
|
||||||
((key (ev-occ-key occ)))
|
|
||||||
(append
|
|
||||||
acc
|
|
||||||
(map (fn (actor) (list actor key)) (ev/roster b key)))))
|
|
||||||
(list)
|
|
||||||
occs)))
|
|
||||||
|
|
||||||
;; Availability db over [ws, we) with bookings sourced from persist streams.
|
|
||||||
(define
|
|
||||||
ev/avail-db-p
|
|
||||||
(fn
|
|
||||||
(b store ws we)
|
|
||||||
(let
|
|
||||||
((occs (ev/agenda store ws we)))
|
|
||||||
(ev-avail-db occs (ev/persist-bookings b occs)))))
|
|
||||||
|
|
||||||
;; Persist-backed availability queries (mirror the in-memory ev/free? etc).
|
|
||||||
(define
|
|
||||||
ev/free-p?
|
|
||||||
(fn
|
|
||||||
(b store actor qs qe)
|
|
||||||
(ev-free?
|
|
||||||
(ev/avail-db-p b store (- qs (ev/store-max-duration store)) qe)
|
|
||||||
actor
|
|
||||||
qs
|
|
||||||
qe)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
ev/next-free-p
|
|
||||||
(fn
|
|
||||||
(b store actor after duration horizon)
|
|
||||||
(ev-next-free
|
|
||||||
(ev/avail-db-p b store (- after (ev/store-max-duration store)) horizon)
|
|
||||||
actor
|
|
||||||
after
|
|
||||||
duration
|
|
||||||
horizon)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
ev/conflicts-p
|
|
||||||
(fn
|
|
||||||
(b store actor ws we)
|
|
||||||
(ev-conflicts (ev/avail-db-p b store ws we) actor)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
ev/has-conflict-p?
|
|
||||||
(fn
|
|
||||||
(b store actor ws we)
|
|
||||||
(> (len (ev/conflicts-p b store actor ws we)) 0)))
|
|
||||||
|
|
||||||
;; ---- conflict-checked booking ----
|
|
||||||
;; Capacity is per-event, but an attendee should not be double-booked against
|
|
||||||
;; THEMSELVES across different events. Would booking `actor` into `occ` overlap
|
|
||||||
;; an existing booking of theirs elsewhere? (Derived from persist availability;
|
|
||||||
;; an existing booking into `occ` itself is excluded — that's idempotent.)
|
|
||||||
(define
|
|
||||||
ev/would-time-conflict?
|
|
||||||
(fn
|
|
||||||
(b store actor occ)
|
|
||||||
(and
|
|
||||||
(not (ev-actor-booked? b (ev-occ-key occ) actor))
|
|
||||||
(not (ev/free-p? b store actor (get occ :start) (get occ :end))))))
|
|
||||||
|
|
||||||
;; Book `actor` into `occ` only if it doesn't clash with their other bookings.
|
|
||||||
;; Re-booking the same occurrence is idempotent (:already); a clash returns
|
|
||||||
;; :time-conflict; otherwise the normal ev/book-occ! result (:booked / :full).
|
|
||||||
(define
|
|
||||||
ev/book-checked!
|
|
||||||
(fn
|
|
||||||
(b store actor occ)
|
|
||||||
(cond
|
|
||||||
((ev-actor-booked? b (ev-occ-key occ) actor) (ev/book-occ! b store actor occ))
|
|
||||||
((ev/would-time-conflict? b store actor occ)
|
|
||||||
{:status :time-conflict :actor actor :occ-key (ev-occ-key occ)})
|
|
||||||
(else (ev/book-occ! b store actor occ)))))
|
|
||||||
@@ -1,177 +0,0 @@
|
|||||||
;; lib/events/availability.sx — free/busy + conflict detection on Datalog.
|
|
||||||
;;
|
|
||||||
;; Availability is per-actor and is forward-chained Datalog over two EDB
|
|
||||||
;; relations:
|
|
||||||
;;
|
|
||||||
;; (occurrence Key EventId Start End) ; an expanded calendar occurrence
|
|
||||||
;; (booking Actor Key) ; actor attends/holds that occurrence
|
|
||||||
;;
|
|
||||||
;; The derived relations are the whole policy:
|
|
||||||
;;
|
|
||||||
;; busy(A,S,E) — A is committed for [S,E) (a booked occurrence)
|
|
||||||
;; conflict(A,O1,O2) — A double-booked into two overlapping occurrences
|
|
||||||
;; busy_in(A,QS,QE) — A is busy somewhere inside query window [QS,QE)
|
|
||||||
;;
|
|
||||||
;; Intervals are half-open [Start,End) in epoch minutes (see calendar.sx), so
|
|
||||||
;; adjacent slots (E == next start) do NOT conflict. Conflict pairs are
|
|
||||||
;; canonical (O1 < O2 by key) so each overlap is reported once. The same `busy`
|
|
||||||
;; rule answers "is A free in [QS,QE)?" (busy_in is empty) and feeds "when is A
|
|
||||||
;; next free?" (ev-next-free probes candidate slots with the same rule).
|
|
||||||
|
|
||||||
;; A stable key for an occurrence dict {:id :start :end}.
|
|
||||||
(define ev-occ-key (fn (occ) (str (get occ :id) "@" (get occ :start))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
ev-occurrence-fact
|
|
||||||
(fn
|
|
||||||
(occ)
|
|
||||||
(list
|
|
||||||
(quote occurrence)
|
|
||||||
(ev-occ-key occ)
|
|
||||||
(get occ :id)
|
|
||||||
(get occ :start)
|
|
||||||
(get occ :end))))
|
|
||||||
|
|
||||||
(define ev-occurrence-facts (fn (occs) (map ev-occurrence-fact occs)))
|
|
||||||
|
|
||||||
(define ev-booking-fact (fn (actor key) (list (quote booking) actor key)))
|
|
||||||
|
|
||||||
(define ev-qwindow-fact (fn (qs qe) (list (quote qwindow) qs qe)))
|
|
||||||
|
|
||||||
;; Range restriction: each comparison's variables are bound by an earlier
|
|
||||||
;; positive literal (qwindow / busy precede the < tests). Conflict uses
|
|
||||||
;; (< O1 O2) on the keys so each overlapping pair is reported once.
|
|
||||||
(define
|
|
||||||
ev-avail-rules
|
|
||||||
(quote
|
|
||||||
((busy A S E <- (booking A O) (occurrence O _ S E))
|
|
||||||
(conflict
|
|
||||||
A
|
|
||||||
O1
|
|
||||||
O2
|
|
||||||
<-
|
|
||||||
(booking A O1)
|
|
||||||
(booking A O2)
|
|
||||||
(occurrence O1 _ S1 E1)
|
|
||||||
(occurrence O2 _ S2 E2)
|
|
||||||
(< O1 O2)
|
|
||||||
(< S1 E2)
|
|
||||||
(< S2 E1))
|
|
||||||
(busy_in A QS QE <- (qwindow QS QE) (busy A S E) (< S QE) (< QS E)))))
|
|
||||||
|
|
||||||
;; Build a Datalog db from EDB facts under the availability ruleset.
|
|
||||||
(define ev-build-avail (fn (facts) (dl-program-data facts ev-avail-rules)))
|
|
||||||
|
|
||||||
;; Convenience: build a db from occurrence dicts + booking pairs.
|
|
||||||
;; bookings is a list of (actor key) pairs.
|
|
||||||
(define
|
|
||||||
ev-avail-db
|
|
||||||
(fn
|
|
||||||
(occs bookings)
|
|
||||||
(ev-build-avail
|
|
||||||
(append
|
|
||||||
(ev-occurrence-facts occs)
|
|
||||||
(map
|
|
||||||
(fn (b) (ev-booking-fact (first b) (first (rest b))))
|
|
||||||
bookings)))))
|
|
||||||
|
|
||||||
;; Helper: insertion sort a list of (S E ...) lists ascending by S then E.
|
|
||||||
(define
|
|
||||||
ev-list-before?
|
|
||||||
(fn
|
|
||||||
(a b)
|
|
||||||
(cond
|
|
||||||
((< (first a) (first b)) true)
|
|
||||||
((> (first a) (first b)) false)
|
|
||||||
(else (< (first (rest a)) (first (rest b)))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
ev-list-insert
|
|
||||||
(fn
|
|
||||||
(x sorted)
|
|
||||||
(cond
|
|
||||||
((empty? sorted) (list x))
|
|
||||||
((ev-list-before? x (first sorted)) (cons x sorted))
|
|
||||||
(else (cons (first sorted) (ev-list-insert x (rest sorted)))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
ev-sort-lists
|
|
||||||
(fn (xs) (reduce (fn (acc x) (ev-list-insert x acc)) (list) xs)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
ev-dedup-sorted
|
|
||||||
(fn
|
|
||||||
(xs)
|
|
||||||
(cond
|
|
||||||
((empty? xs) xs)
|
|
||||||
((empty? (rest xs)) xs)
|
|
||||||
((= (first xs) (first (rest xs))) (ev-dedup-sorted (rest xs)))
|
|
||||||
(else (cons (first xs) (ev-dedup-sorted (rest xs)))))))
|
|
||||||
|
|
||||||
;; All busy intervals (list S E) for an actor, ascending by start.
|
|
||||||
(define
|
|
||||||
ev-busy
|
|
||||||
(fn
|
|
||||||
(db actor)
|
|
||||||
(let
|
|
||||||
((rows (dl-query db (list (quote busy) actor (quote S) (quote E)))))
|
|
||||||
(ev-sort-lists (map (fn (b) (list (get b :S) (get b :E))) rows)))))
|
|
||||||
|
|
||||||
;; Distinct conflicting occurrence-key pairs for an actor (each pair once).
|
|
||||||
(define
|
|
||||||
ev-conflicts
|
|
||||||
(fn
|
|
||||||
(db actor)
|
|
||||||
(dl-query db (list (quote conflict) actor (quote O1) (quote O2)))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
ev-has-conflict?
|
|
||||||
(fn (db actor) (> (len (ev-conflicts db actor)) 0)))
|
|
||||||
|
|
||||||
;; Is `actor` free across the whole window [qs,qe)? (no booked occurrence
|
|
||||||
;; overlaps it). Asserts a transient qwindow fact, queries, retracts.
|
|
||||||
(define
|
|
||||||
ev-free?
|
|
||||||
(fn
|
|
||||||
(db actor qs qe)
|
|
||||||
(do
|
|
||||||
(dl-assert! db (ev-qwindow-fact qs qe))
|
|
||||||
(let
|
|
||||||
((rows (dl-query db (list (quote busy_in) actor (quote QS) (quote QE)))))
|
|
||||||
(begin (dl-retract! db (ev-qwindow-fact qs qe)) (empty? rows))))))
|
|
||||||
|
|
||||||
;; ---- next-free slot search ----
|
|
||||||
;; The earliest start s >= `after` such that [s, s+duration) is entirely free
|
|
||||||
;; for `actor` and ends at or before `horizon`, or nil if none. The earliest
|
|
||||||
;; such slot must begin either at `after` or immediately after some busy
|
|
||||||
;; interval ends (classic interval packing), so those are the only candidates
|
|
||||||
;; we probe — each probe reuses the busy_in rule via ev-free?.
|
|
||||||
|
|
||||||
(define
|
|
||||||
ev-first-free
|
|
||||||
(fn
|
|
||||||
(db actor cands duration horizon)
|
|
||||||
(cond
|
|
||||||
((empty? cands) nil)
|
|
||||||
(else
|
|
||||||
(let
|
|
||||||
((s (first cands)))
|
|
||||||
(if
|
|
||||||
(and
|
|
||||||
(<= (+ s duration) horizon)
|
|
||||||
(ev-free? db actor s (+ s duration)))
|
|
||||||
s
|
|
||||||
(ev-first-free db actor (rest cands) duration horizon)))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
ev-next-free
|
|
||||||
(fn
|
|
||||||
(db actor after duration horizon)
|
|
||||||
(let
|
|
||||||
((ends (filter (fn (e) (>= e after)) (map (fn (iv) (first (rest iv))) (ev-busy db actor)))))
|
|
||||||
(ev-first-free
|
|
||||||
db
|
|
||||||
actor
|
|
||||||
(ev-dedup-sorted (sort (cons after ends)))
|
|
||||||
duration
|
|
||||||
horizon))))
|
|
||||||
@@ -1,102 +0,0 @@
|
|||||||
;; lib/events/booking-notify.sx — derive lifecycle notifications from the
|
|
||||||
;; booking stream, for delivery via notify.sx.
|
|
||||||
;;
|
|
||||||
;; Walking the append-only booking stream yields one notification per state
|
|
||||||
;; change, in order, classified by kind:
|
|
||||||
;;
|
|
||||||
;; :booked a confirmed booking
|
|
||||||
;; :promoted a booking for an actor who was on the waitlist (auto-promote)
|
|
||||||
;; :held a provisional hold (pending payment)
|
|
||||||
;; :confirmed a held seat became confirmed (payment succeeded)
|
|
||||||
;; :released a held seat was released (payment failed/expired)
|
|
||||||
;; :cancelled a seat was given up
|
|
||||||
;; :waitlisted an actor joined the waitlist
|
|
||||||
;;
|
|
||||||
;; Promotion is detected by folding the waitlist as we walk: a :booking for an
|
|
||||||
;; actor currently on the waitlist is a promotion, not a fresh booking.
|
|
||||||
;;
|
|
||||||
;; Each notification's id is occ-key/seq (the stream seq is unique and stable),
|
|
||||||
;; so re-deriving and re-delivering is idempotent — the notify transport dedups
|
|
||||||
;; on this id and never double-pings.
|
|
||||||
|
|
||||||
(define
|
|
||||||
ev-bn-kind
|
|
||||||
(fn
|
|
||||||
(typ promoted?)
|
|
||||||
(cond
|
|
||||||
((= typ :hold) :held)
|
|
||||||
((= typ :booking) (if promoted? :promoted :booked))
|
|
||||||
((= typ :confirm) :confirmed)
|
|
||||||
((= typ :cancel) :cancelled)
|
|
||||||
((= typ :release) :released)
|
|
||||||
((= typ :waitlist) :waitlisted)
|
|
||||||
(else nil))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
ev-bn-update-waiting
|
|
||||||
(fn
|
|
||||||
(typ actor waiting)
|
|
||||||
(cond
|
|
||||||
((= typ :waitlist)
|
|
||||||
(if
|
|
||||||
(ev-bk-member? actor waiting)
|
|
||||||
waiting
|
|
||||||
(ev-bk-append waiting actor)))
|
|
||||||
((= typ :unwaitlist) (ev-bk-remove waiting actor))
|
|
||||||
((= typ :booking) (ev-bk-remove waiting actor))
|
|
||||||
((= typ :hold) (ev-bk-remove waiting actor))
|
|
||||||
(else waiting))))
|
|
||||||
|
|
||||||
(define ev-bn-mk (fn (occ-key label actor kind seq) {:id (str occ-key "/" seq) :event label :kind kind :recipient actor :seq seq}))
|
|
||||||
|
|
||||||
(define
|
|
||||||
ev-bn-step
|
|
||||||
(fn
|
|
||||||
(occ-key label events waiting)
|
|
||||||
(if
|
|
||||||
(empty? events)
|
|
||||||
(list)
|
|
||||||
(let
|
|
||||||
((e (first events)))
|
|
||||||
(let
|
|
||||||
((typ (persist/event-type e))
|
|
||||||
(actor (get (persist/event-data e) :actor))
|
|
||||||
(seq (persist/event-seq e)))
|
|
||||||
(let
|
|
||||||
((promoted? (and (= typ :booking) (ev-bk-member? actor waiting))))
|
|
||||||
(let
|
|
||||||
((kind (ev-bn-kind typ promoted?))
|
|
||||||
(waiting2 (ev-bn-update-waiting typ actor waiting)))
|
|
||||||
(if
|
|
||||||
(nil? kind)
|
|
||||||
(ev-bn-step occ-key label (rest events) waiting2)
|
|
||||||
(cons
|
|
||||||
(ev-bn-mk occ-key label actor kind seq)
|
|
||||||
(ev-bn-step occ-key label (rest events) waiting2))))))))))
|
|
||||||
|
|
||||||
;; The ordered lifecycle notifications for an occurrence's bookings. `label` is
|
|
||||||
;; a human-facing event id carried on each notification.
|
|
||||||
(define
|
|
||||||
ev/booking-notifications
|
|
||||||
(fn
|
|
||||||
(b occ-key label)
|
|
||||||
(ev-bn-step
|
|
||||||
occ-key
|
|
||||||
label
|
|
||||||
(persist/read b (ev-booking-stream occ-key))
|
|
||||||
(list))))
|
|
||||||
|
|
||||||
;; Filter notifications to a single kind.
|
|
||||||
(define
|
|
||||||
ev/notify-of-kind
|
|
||||||
(fn (notifs kind) (filter (fn (n) (= (get n :kind) kind)) notifs)))
|
|
||||||
|
|
||||||
;; Project a notification to notify.sx's (id recipient body) wire shape.
|
|
||||||
(define
|
|
||||||
ev/booking-notify->msg
|
|
||||||
(fn
|
|
||||||
(n)
|
|
||||||
(list
|
|
||||||
(get n :id)
|
|
||||||
(get n :recipient)
|
|
||||||
(list :booking-event (get n :kind) (get n :event)))))
|
|
||||||
@@ -1,372 +0,0 @@
|
|||||||
;; lib/events/booking.sx — transactional, capacity-safe booking on persist.
|
|
||||||
;;
|
|
||||||
;; Each bookable occurrence has an append-only stream of booking events:
|
|
||||||
;;
|
|
||||||
;; :booking free booking — actor immediately holds a confirmed seat
|
|
||||||
;; :hold provisional hold — seat reserved while payment is pending
|
|
||||||
;; :confirm a held seat becomes confirmed (payment succeeded)
|
|
||||||
;; :release a held seat is abandoned (payment failed/expired) — seat freed
|
|
||||||
;; :cancel a held or confirmed seat is given up — seat freed
|
|
||||||
;;
|
|
||||||
;; The live state is the stream FOLDED in order into per-actor seat states
|
|
||||||
;; (:held / :confirmed); an actor in ANY state occupies a seat, so both held and
|
|
||||||
;; confirmed seats count toward capacity — a pending payment cannot be
|
|
||||||
;; oversold. A freed seat (release/cancel) reopens capacity.
|
|
||||||
;;
|
|
||||||
;; Capacity safety is the contract: two writers racing for the last seat must
|
|
||||||
;; NEVER both succeed. Seat-ACQUIRING writes (:booking, :hold) go through
|
|
||||||
;; persist's optimistic concurrency — `persist/append-expect` appends only if
|
|
||||||
;; the stream's last-seq still equals what the writer observed; else it returns
|
|
||||||
;; a conflict the writer retries. Seat-FREEING writes (:cancel, :release) and
|
|
||||||
;; the state transition (:confirm) never oversell, so they append directly.
|
|
||||||
|
|
||||||
(define ev-booking-stream (fn (occ-key) (str "booking:" occ-key)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
ev-bk-member?
|
|
||||||
(fn
|
|
||||||
(x xs)
|
|
||||||
(cond
|
|
||||||
((empty? xs) false)
|
|
||||||
((= x (first xs)) true)
|
|
||||||
(else (ev-bk-member? x (rest xs))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
ev-bk-index
|
|
||||||
(fn
|
|
||||||
(xs x i)
|
|
||||||
(cond
|
|
||||||
((empty? xs) -1)
|
|
||||||
((= (first xs) x) i)
|
|
||||||
(else (ev-bk-index (rest xs) x (+ i 1))))))
|
|
||||||
|
|
||||||
(define ev-bk-append (fn (xs a) (append xs (list a))))
|
|
||||||
(define ev-bk-remove (fn (xs a) (filter (fn (x) (not (= x a))) xs)))
|
|
||||||
|
|
||||||
;; ---- per-actor state association list: ((actor state) ...) in join order ----
|
|
||||||
|
|
||||||
(define
|
|
||||||
ev-state-has?
|
|
||||||
(fn
|
|
||||||
(states actor)
|
|
||||||
(cond
|
|
||||||
((empty? states) false)
|
|
||||||
((= (first (first states)) actor) true)
|
|
||||||
(else (ev-state-has? (rest states) actor)))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
ev-state-get
|
|
||||||
(fn
|
|
||||||
(states actor)
|
|
||||||
(cond
|
|
||||||
((empty? states) :none)
|
|
||||||
((= (first (first states)) actor) (first (rest (first states))))
|
|
||||||
(else (ev-state-get (rest states) actor)))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
ev-state-del
|
|
||||||
(fn (states actor) (filter (fn (p) (not (= (first p) actor))) states)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
ev-state-set
|
|
||||||
(fn
|
|
||||||
(states actor st)
|
|
||||||
(if
|
|
||||||
(ev-state-has? states actor)
|
|
||||||
(map (fn (p) (if (= (first p) actor) (list actor st) p)) states)
|
|
||||||
(append states (list (list actor st))))))
|
|
||||||
|
|
||||||
;; Fold the booking stream into per-actor seat states (join order preserved).
|
|
||||||
(define
|
|
||||||
ev-fold-states
|
|
||||||
(fn
|
|
||||||
(events)
|
|
||||||
(reduce
|
|
||||||
(fn
|
|
||||||
(acc e)
|
|
||||||
(let
|
|
||||||
((typ (persist/event-type e))
|
|
||||||
(actor (get (persist/event-data e) :actor)))
|
|
||||||
(cond
|
|
||||||
((= typ :booking) (ev-state-set acc actor :confirmed))
|
|
||||||
((= typ :hold) (ev-state-set acc actor :held))
|
|
||||||
((= typ :confirm)
|
|
||||||
(if
|
|
||||||
(ev-state-has? acc actor)
|
|
||||||
(ev-state-set acc actor :confirmed)
|
|
||||||
acc))
|
|
||||||
((= typ :cancel) (ev-state-del acc actor))
|
|
||||||
((= typ :release) (ev-state-del acc actor))
|
|
||||||
(else acc))))
|
|
||||||
(list)
|
|
||||||
events)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
ev-states-of
|
|
||||||
(fn
|
|
||||||
(b occ-key)
|
|
||||||
(ev-fold-states (persist/read b (ev-booking-stream occ-key)))))
|
|
||||||
|
|
||||||
;; Live roster (actors holding a seat — held or confirmed), oldest active first.
|
|
||||||
(define
|
|
||||||
ev-booked-actors
|
|
||||||
(fn (b occ-key) (map (fn (p) (first p)) (ev-states-of b occ-key))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
ev-actor-booked?
|
|
||||||
(fn (b occ-key actor) (ev-bk-member? actor (ev-booked-actors b occ-key))))
|
|
||||||
|
|
||||||
;; Live seat count (folded roster size — both held and confirmed seats).
|
|
||||||
(define
|
|
||||||
ev-booking-count
|
|
||||||
(fn (b occ-key) (len (ev-booked-actors b occ-key))))
|
|
||||||
|
|
||||||
;; Seat state for an actor: :held / :confirmed / :none.
|
|
||||||
(define
|
|
||||||
ev/seat-state
|
|
||||||
(fn (b occ-key actor) (ev-state-get (ev-states-of b occ-key) actor)))
|
|
||||||
|
|
||||||
;; 1-based seat number for an actor on the roster (0 if not booked).
|
|
||||||
(define
|
|
||||||
ev-seat-of
|
|
||||||
(fn
|
|
||||||
(actors actor)
|
|
||||||
(let
|
|
||||||
((i (ev-bk-index actors actor 0)))
|
|
||||||
(if (< i 0) 0 (+ i 1)))))
|
|
||||||
|
|
||||||
;; ---- seat-acquiring writes (capacity-guarded via append-expect) ----
|
|
||||||
|
|
||||||
;; One seat-acquiring attempt of `kind` (:booking or :hold) against an OBSERVED
|
|
||||||
;; snapshot (roster the writer saw + the last-seq). Returns :already / :full /
|
|
||||||
;; :conflict, or a success dict tagged with `ok-status`. :conflict means a
|
|
||||||
;; concurrent append landed since the snapshot — the caller must re-observe.
|
|
||||||
(define
|
|
||||||
ev-acquire-with-observed
|
|
||||||
(fn
|
|
||||||
(b occ-key capacity actor observed-actors expected kind ok-status)
|
|
||||||
(cond
|
|
||||||
((ev-bk-member? actor observed-actors) {:seat (ev-seat-of observed-actors actor) :actor actor :status :already})
|
|
||||||
((>= (len observed-actors) capacity) {:actor actor :capacity capacity :status :full})
|
|
||||||
(else
|
|
||||||
(let
|
|
||||||
((r (persist/append-expect b (ev-booking-stream occ-key) expected kind 0 {:actor actor})))
|
|
||||||
(if (persist/conflict? r) {:actual (persist/conflict-actual r) :actor actor :status :conflict} {:seat (+ (len observed-actors) 1) :actor actor :status ok-status}))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
ev-acquire!
|
|
||||||
(fn
|
|
||||||
(b occ-key capacity actor kind ok-status)
|
|
||||||
(let
|
|
||||||
((res (ev-acquire-with-observed b occ-key capacity actor (ev-booked-actors b occ-key) (persist/last-seq b (ev-booking-stream occ-key)) kind ok-status)))
|
|
||||||
(if
|
|
||||||
(= (get res :status) :conflict)
|
|
||||||
(ev-acquire! b occ-key capacity actor kind ok-status)
|
|
||||||
res))))
|
|
||||||
|
|
||||||
;; Capacity-safe confirmed booking (retrying on conflict).
|
|
||||||
(define
|
|
||||||
ev/book!
|
|
||||||
(fn
|
|
||||||
(b occ-key capacity actor)
|
|
||||||
(ev-acquire! b occ-key capacity actor :booking :booked)))
|
|
||||||
|
|
||||||
;; Capacity-safe provisional hold (retrying on conflict). The seat is reserved
|
|
||||||
;; (counts toward capacity) until confirmed or released.
|
|
||||||
(define
|
|
||||||
ev/hold!
|
|
||||||
(fn
|
|
||||||
(b occ-key capacity actor)
|
|
||||||
(ev-acquire! b occ-key capacity actor :hold :held)))
|
|
||||||
|
|
||||||
;; Test seam: one attempt against a caller-supplied snapshot (book or hold).
|
|
||||||
(define
|
|
||||||
ev/book-with-observed
|
|
||||||
(fn
|
|
||||||
(b occ-key capacity actor observed-actors expected)
|
|
||||||
(ev-acquire-with-observed
|
|
||||||
b
|
|
||||||
occ-key
|
|
||||||
capacity
|
|
||||||
actor
|
|
||||||
observed-actors
|
|
||||||
expected
|
|
||||||
:booking :booked)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
ev/hold-with-observed
|
|
||||||
(fn
|
|
||||||
(b occ-key capacity actor observed-actors expected)
|
|
||||||
(ev-acquire-with-observed
|
|
||||||
b
|
|
||||||
occ-key
|
|
||||||
capacity
|
|
||||||
actor
|
|
||||||
observed-actors
|
|
||||||
expected
|
|
||||||
:hold :held)))
|
|
||||||
|
|
||||||
;; ---- state transitions / seat-freeing writes (no oversell, append direct) ----
|
|
||||||
|
|
||||||
;; Confirm a held seat (payment succeeded). :confirmed on success,
|
|
||||||
;; :already-confirmed if it was confirmed, :not-held otherwise.
|
|
||||||
(define
|
|
||||||
ev/confirm!
|
|
||||||
(fn
|
|
||||||
(b occ-key actor)
|
|
||||||
(let
|
|
||||||
((st (ev/seat-state b occ-key actor)))
|
|
||||||
(cond
|
|
||||||
((= st :held)
|
|
||||||
(begin
|
|
||||||
(persist/append
|
|
||||||
b
|
|
||||||
(ev-booking-stream occ-key)
|
|
||||||
:confirm 0
|
|
||||||
{:actor actor})
|
|
||||||
{:actor actor :status :confirmed}))
|
|
||||||
((= st :confirmed) {:actor actor :status :already-confirmed})
|
|
||||||
(else {:actor actor :status :not-held})))))
|
|
||||||
|
|
||||||
;; Release a held seat (payment failed/expired), freeing it. Only valid for a
|
|
||||||
;; held seat — confirmed bookings are given up via ev/cancel!.
|
|
||||||
(define
|
|
||||||
ev/release!
|
|
||||||
(fn
|
|
||||||
(b occ-key actor)
|
|
||||||
(let
|
|
||||||
((st (ev/seat-state b occ-key actor)))
|
|
||||||
(if
|
|
||||||
(= st :held)
|
|
||||||
(begin
|
|
||||||
(persist/append
|
|
||||||
b
|
|
||||||
(ev-booking-stream occ-key)
|
|
||||||
:release 0
|
|
||||||
{:actor actor})
|
|
||||||
{:actor actor :status :released})
|
|
||||||
{:actor actor :status :not-held}))))
|
|
||||||
|
|
||||||
;; Cancel a held or confirmed seat, freeing it. :cancelled or :not-booked.
|
|
||||||
(define
|
|
||||||
ev/cancel!
|
|
||||||
(fn
|
|
||||||
(b occ-key actor)
|
|
||||||
(if
|
|
||||||
(ev-bk-member? actor (ev-booked-actors b occ-key))
|
|
||||||
(begin
|
|
||||||
(persist/append
|
|
||||||
b
|
|
||||||
(ev-booking-stream occ-key)
|
|
||||||
:cancel 0
|
|
||||||
{:actor actor})
|
|
||||||
{:actor actor :status :cancelled})
|
|
||||||
{:actor actor :status :not-booked})))
|
|
||||||
|
|
||||||
;; The roster as a plain list of actors (oldest active first).
|
|
||||||
(define ev/roster (fn (b occ-key) (ev-booked-actors b occ-key)))
|
|
||||||
|
|
||||||
;; Seats remaining for an occurrence of the given capacity.
|
|
||||||
(define
|
|
||||||
ev/seats-left
|
|
||||||
(fn
|
|
||||||
(b occ-key capacity)
|
|
||||||
(max 0 (- capacity (ev-booking-count b occ-key)))))
|
|
||||||
|
|
||||||
;; ---- waitlist ----
|
|
||||||
;; When an occurrence is full, actors join a FIFO waitlist (:waitlist /
|
|
||||||
;; :unwaitlist events on the same stream). Taking a seat (:booking / :hold)
|
|
||||||
;; removes an actor from the queue, so the waitlist fold is independent of the
|
|
||||||
;; seat fold. Cancelling/releasing a seat can auto-promote the head of the
|
|
||||||
;; queue (a :booking appended for them).
|
|
||||||
|
|
||||||
(define
|
|
||||||
ev-fold-waiting
|
|
||||||
(fn
|
|
||||||
(events)
|
|
||||||
(reduce
|
|
||||||
(fn
|
|
||||||
(acc e)
|
|
||||||
(let
|
|
||||||
((typ (persist/event-type e))
|
|
||||||
(actor (get (persist/event-data e) :actor)))
|
|
||||||
(cond
|
|
||||||
((= typ :waitlist) (if (ev-bk-member? actor acc) acc (ev-bk-append acc actor)))
|
|
||||||
((= typ :unwaitlist) (ev-bk-remove acc actor))
|
|
||||||
((= typ :booking) (ev-bk-remove acc actor))
|
|
||||||
((= typ :hold) (ev-bk-remove acc actor))
|
|
||||||
(else acc))))
|
|
||||||
(list)
|
|
||||||
events)))
|
|
||||||
|
|
||||||
;; The current waitlist queue (FIFO, oldest first).
|
|
||||||
(define
|
|
||||||
ev/waitlist
|
|
||||||
(fn (b occ-key) (ev-fold-waiting (persist/read b (ev-booking-stream occ-key)))))
|
|
||||||
|
|
||||||
;; 1-based queue position for an actor (0 if not waiting).
|
|
||||||
(define
|
|
||||||
ev/waitlist-position
|
|
||||||
(fn (b occ-key actor) (ev-seat-of (ev/waitlist b occ-key) actor)))
|
|
||||||
|
|
||||||
;; Book if a seat is free, else join the waitlist. Idempotent: already seated →
|
|
||||||
;; :already; already queued → :already-waiting.
|
|
||||||
(define
|
|
||||||
ev/waitlist!
|
|
||||||
(fn
|
|
||||||
(b occ-key capacity actor)
|
|
||||||
(let
|
|
||||||
((seats (ev-booked-actors b occ-key))
|
|
||||||
(waiting (ev/waitlist b occ-key)))
|
|
||||||
(cond
|
|
||||||
((ev-bk-member? actor seats)
|
|
||||||
{:status :already :seat (ev-seat-of seats actor) :actor actor})
|
|
||||||
((ev-bk-member? actor waiting)
|
|
||||||
{:status :already-waiting :position (ev-seat-of waiting actor) :actor actor})
|
|
||||||
(else
|
|
||||||
(let
|
|
||||||
((r (ev/book! b occ-key capacity actor)))
|
|
||||||
(if
|
|
||||||
(= (get r :status) :booked)
|
|
||||||
r
|
|
||||||
(begin
|
|
||||||
(persist/append b (ev-booking-stream occ-key) :waitlist 0 {:actor actor})
|
|
||||||
{:status :waitlisted
|
|
||||||
:position (+ (len waiting) 1)
|
|
||||||
:actor actor}))))))))
|
|
||||||
|
|
||||||
;; Leave the waitlist. :left or :not-waiting.
|
|
||||||
(define
|
|
||||||
ev/leave-waitlist!
|
|
||||||
(fn
|
|
||||||
(b occ-key actor)
|
|
||||||
(if
|
|
||||||
(ev-bk-member? actor (ev/waitlist b occ-key))
|
|
||||||
(begin
|
|
||||||
(persist/append b (ev-booking-stream occ-key) :unwaitlist 0 {:actor actor})
|
|
||||||
{:status :left :actor actor})
|
|
||||||
{:status :not-waiting :actor actor})))
|
|
||||||
|
|
||||||
;; Cancel a seat and, if that frees capacity, auto-promote the head of the
|
|
||||||
;; waitlist (a confirmed booking). Returns the cancel result plus :promoted
|
|
||||||
;; (the actor promoted, or nil).
|
|
||||||
(define
|
|
||||||
ev/cancel-promote!
|
|
||||||
(fn
|
|
||||||
(b occ-key capacity actor)
|
|
||||||
(let
|
|
||||||
((c (ev/cancel! b occ-key actor)))
|
|
||||||
(if
|
|
||||||
(= (get c :status) :cancelled)
|
|
||||||
(let
|
|
||||||
((waiting (ev/waitlist b occ-key))
|
|
||||||
(seats (ev-booked-actors b occ-key)))
|
|
||||||
(if
|
|
||||||
(and (not (empty? waiting)) (< (len seats) capacity))
|
|
||||||
(let
|
|
||||||
((promoted (first waiting)))
|
|
||||||
(begin
|
|
||||||
(persist/append b (ev-booking-stream occ-key) :booking 0 {:actor promoted})
|
|
||||||
{:status :cancelled :actor actor :promoted promoted}))
|
|
||||||
{:status :cancelled :actor actor :promoted nil}))
|
|
||||||
c))))
|
|
||||||
@@ -1,614 +0,0 @@
|
|||||||
;; lib/events/calendar.sx — civil date arithmetic + RRULE expansion in a window.
|
|
||||||
;;
|
|
||||||
;; Datetimes are integer "epoch minutes": days-since-1970-01-01 * 1440 plus
|
|
||||||
;; minute-of-day. Ordering, window bounds, and durations are plain integer
|
|
||||||
;; arithmetic. Civil <-> day-number conversion uses Howard Hinnant's algorithm
|
|
||||||
;; (exact, branch-free, correct for the proleptic Gregorian calendar).
|
|
||||||
;;
|
|
||||||
;; RRULE expansion is the bridge to Datalog: a recurring event expands to a
|
|
||||||
;; bounded list of occurrence dicts within an explicit (win-start, win-end)
|
|
||||||
;; window. Expansion is ALWAYS windowed — an RRULE without a window is an
|
|
||||||
;; infinite computation and is never permitted. Supported subset (RFC 5545):
|
|
||||||
;; FREQ=DAILY|WEEKLY|MONTHLY, INTERVAL, COUNT, UNTIL, BYDAY (weekly: weekday
|
|
||||||
;; numbers; monthly: {:ord N :wd W} ordinal weekdays), BYMONTHDAY (monthly,
|
|
||||||
;; negative = from month end). YEARLY and the rest are deferred.
|
|
||||||
|
|
||||||
;; ---- integer helpers ----
|
|
||||||
|
|
||||||
;; Floored integer division (modulo is already floored, so the remainder
|
|
||||||
;; subtraction makes the quotient exact and floor-correct for any sign).
|
|
||||||
(define ev-floor-div (fn (a b) (quotient (- a (modulo a b)) b)))
|
|
||||||
|
|
||||||
(define ev-or (fn (x d) (if (nil? x) d x)))
|
|
||||||
|
|
||||||
(define ev-filter-nil (fn (xs) (filter (fn (x) (not (nil? x))) xs)))
|
|
||||||
|
|
||||||
;; ---- civil date core (Hinnant) ----
|
|
||||||
|
|
||||||
;; Days since 1970-01-01 for civil (y, m, d). m in [1,12], d in [1,31].
|
|
||||||
(define
|
|
||||||
ev-days-from-civil
|
|
||||||
(fn
|
|
||||||
(y0 m d)
|
|
||||||
(let
|
|
||||||
((y (if (<= m 2) (- y0 1) y0)))
|
|
||||||
(let
|
|
||||||
((era (ev-floor-div (if (>= y 0) y (- y 399)) 400)))
|
|
||||||
(let
|
|
||||||
((yoe (- y (* era 400)))
|
|
||||||
(doy
|
|
||||||
(+
|
|
||||||
(ev-floor-div
|
|
||||||
(+
|
|
||||||
(*
|
|
||||||
153
|
|
||||||
(+ m (if (> m 2) -3 9)))
|
|
||||||
2)
|
|
||||||
5)
|
|
||||||
(- d 1))))
|
|
||||||
(let
|
|
||||||
((doe (+ (* yoe 365) (ev-floor-div yoe 4) (- (ev-floor-div yoe 100)) doy)))
|
|
||||||
(+ (* era 146097) doe -719468)))))))
|
|
||||||
|
|
||||||
;; Civil (y m d) list from a day-number.
|
|
||||||
(define
|
|
||||||
ev-civil-from-days
|
|
||||||
(fn
|
|
||||||
(z0)
|
|
||||||
(let
|
|
||||||
((z (+ z0 719468)))
|
|
||||||
(let
|
|
||||||
((era (ev-floor-div (if (>= z 0) z (- z 146096)) 146097)))
|
|
||||||
(let
|
|
||||||
((doe (- z (* era 146097))))
|
|
||||||
(let
|
|
||||||
((yoe (ev-floor-div (+ (- doe (ev-floor-div doe 1460)) (ev-floor-div doe 36524) (- (ev-floor-div doe 146096))) 365)))
|
|
||||||
(let
|
|
||||||
((y (+ yoe (* era 400)))
|
|
||||||
(doy
|
|
||||||
(-
|
|
||||||
doe
|
|
||||||
(+
|
|
||||||
(* 365 yoe)
|
|
||||||
(ev-floor-div yoe 4)
|
|
||||||
(- (ev-floor-div yoe 100))))))
|
|
||||||
(let
|
|
||||||
((mp (ev-floor-div (+ (* 5 doy) 2) 153)))
|
|
||||||
(let
|
|
||||||
((d (+ (- doy (ev-floor-div (+ (* 153 mp) 2) 5)) 1))
|
|
||||||
(m
|
|
||||||
(if
|
|
||||||
(< mp 10)
|
|
||||||
(+ mp 3)
|
|
||||||
(- mp 9))))
|
|
||||||
(list (if (<= m 2) (+ y 1) y) m d))))))))))
|
|
||||||
|
|
||||||
;; Weekday of a day-number: 0=Mon .. 6=Sun (1970-01-01 is Thursday = 3).
|
|
||||||
(define ev-weekday-of-days (fn (z) (modulo (+ z 3) 7)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
ev-days-in-month
|
|
||||||
(fn
|
|
||||||
(y m)
|
|
||||||
(-
|
|
||||||
(ev-days-from-civil
|
|
||||||
(if (= m 12) (+ y 1) y)
|
|
||||||
(if (= m 12) 1 (+ m 1))
|
|
||||||
1)
|
|
||||||
(ev-days-from-civil y m 1))))
|
|
||||||
|
|
||||||
;; Add k months to (y,m), returning (list y2 m2).
|
|
||||||
(define
|
|
||||||
ev-add-months
|
|
||||||
(fn
|
|
||||||
(y m k)
|
|
||||||
(let
|
|
||||||
((total (+ (* y 12) (- m 1) k)))
|
|
||||||
(list
|
|
||||||
(ev-floor-div total 12)
|
|
||||||
(+ (modulo total 12) 1)))))
|
|
||||||
|
|
||||||
;; ---- datetime (epoch minutes) ----
|
|
||||||
|
|
||||||
(define
|
|
||||||
ev-dt
|
|
||||||
(fn
|
|
||||||
(y m d hh mm)
|
|
||||||
(+ (* (ev-days-from-civil y m d) 1440) (* hh 60) mm)))
|
|
||||||
|
|
||||||
(define ev-date (fn (y m d) (ev-dt y m d 0 0)))
|
|
||||||
|
|
||||||
(define ev-dt->days (fn (t) (ev-floor-div t 1440)))
|
|
||||||
|
|
||||||
(define ev-dt->civil (fn (t) (ev-civil-from-days (ev-dt->days t))))
|
|
||||||
|
|
||||||
(define ev-dt-weekday (fn (t) (ev-weekday-of-days (ev-dt->days t))))
|
|
||||||
|
|
||||||
(define ev-dt-tod (fn (t) (modulo t 1440)))
|
|
||||||
|
|
||||||
(define ev-civ-y (fn (c) (first c)))
|
|
||||||
(define ev-civ-m (fn (c) (first (rest c))))
|
|
||||||
(define ev-civ-d (fn (c) (first (rest (rest c)))))
|
|
||||||
|
|
||||||
;; ---- event + occurrence constructors ----
|
|
||||||
|
|
||||||
;; rrule is nil (single event) or a dict:
|
|
||||||
;; {:freq :daily|:weekly|:monthly :interval N :count N|nil :until DT|nil
|
|
||||||
;; :byday ...|nil :bymonthday (list 15 -1)|nil}
|
|
||||||
;; weekly :byday -> (list 0 2 4) weekday numbers, 0=Mon
|
|
||||||
;; monthly :byday -> (list {:ord 2 :wd 1}) nth weekday (ord<0 from end)
|
|
||||||
;; monthly :bymonthday -> (list 15 -1) day of month (negative from end)
|
|
||||||
(define ev-event (fn (id dtstart duration rrule capacity) {:duration duration :id id :dtstart dtstart :capacity capacity :rrule rrule}))
|
|
||||||
|
|
||||||
;; Event with EXDATE/RDATE exceptions. exdate/rdate are lists of epoch-minute
|
|
||||||
;; starts to exclude from / add to the expansion (RFC 5545 VEVENT properties).
|
|
||||||
(define
|
|
||||||
ev-event-full
|
|
||||||
(fn
|
|
||||||
(id dtstart duration rrule capacity exdate rdate)
|
|
||||||
{:duration duration
|
|
||||||
:id id
|
|
||||||
:dtstart dtstart
|
|
||||||
:capacity capacity
|
|
||||||
:rrule rrule
|
|
||||||
:exdate exdate
|
|
||||||
:rdate rdate}))
|
|
||||||
|
|
||||||
(define ev-occ (fn (id start dur) {:id id :start start :end (+ start dur)}))
|
|
||||||
|
|
||||||
;; ---- DAILY expansion ----
|
|
||||||
;; occ starts at dtstart; n counts every generated occurrence (window-
|
|
||||||
;; independent, so COUNT/UNTIL bound the rule, not the view). Emits only
|
|
||||||
;; occurrences inside [win-start, win-end].
|
|
||||||
(define
|
|
||||||
ev-daily-loop
|
|
||||||
(fn
|
|
||||||
(id occ duration step count until dtstart win-start win-end acc n)
|
|
||||||
(cond
|
|
||||||
((> occ win-end) acc)
|
|
||||||
((and (not (nil? count)) (>= n count)) acc)
|
|
||||||
((and (not (nil? until)) (> occ until)) acc)
|
|
||||||
(else
|
|
||||||
(begin
|
|
||||||
(when (>= occ win-start) (append! acc (ev-occ id occ duration)))
|
|
||||||
(ev-daily-loop
|
|
||||||
id
|
|
||||||
(+ occ step)
|
|
||||||
duration
|
|
||||||
step
|
|
||||||
count
|
|
||||||
until
|
|
||||||
dtstart
|
|
||||||
win-start
|
|
||||||
win-end
|
|
||||||
acc
|
|
||||||
(+ n 1)))))))
|
|
||||||
|
|
||||||
;; ---- shared per-period emit ----
|
|
||||||
;; Walk a start-ascending list of candidate occurrence datetimes for one
|
|
||||||
;; period, generating (count toward COUNT) those >= dtstart within UNTIL, and
|
|
||||||
;; emitting those also inside the window. Returns the updated running n.
|
|
||||||
(define
|
|
||||||
ev-emit-occs
|
|
||||||
(fn
|
|
||||||
(id occs duration count until dtstart win-start win-end acc n)
|
|
||||||
(if
|
|
||||||
(empty? occs)
|
|
||||||
n
|
|
||||||
(let
|
|
||||||
((occ (first occs)))
|
|
||||||
(let
|
|
||||||
((generates? (and (>= occ dtstart) (or (nil? until) (<= occ until)) (or (nil? count) (< n count)))))
|
|
||||||
(begin
|
|
||||||
(when
|
|
||||||
(and generates? (>= occ win-start) (<= occ win-end))
|
|
||||||
(append! acc (ev-occ id occ duration)))
|
|
||||||
(ev-emit-occs
|
|
||||||
id
|
|
||||||
(rest occs)
|
|
||||||
duration
|
|
||||||
count
|
|
||||||
until
|
|
||||||
dtstart
|
|
||||||
win-start
|
|
||||||
win-end
|
|
||||||
acc
|
|
||||||
(if generates? (+ n 1) n))))))))
|
|
||||||
|
|
||||||
;; ---- WEEKLY expansion ----
|
|
||||||
;; Iterate week by week from the Monday of dtstart's week; within each active
|
|
||||||
;; week emit each BYDAY (sorted). n counts every generated occurrence.
|
|
||||||
|
|
||||||
(define
|
|
||||||
ev-week0-days
|
|
||||||
(fn (dtstart) (- (ev-dt->days dtstart) (ev-dt-weekday dtstart))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
ev-byday-default
|
|
||||||
(fn
|
|
||||||
(byday dtstart)
|
|
||||||
(if (nil? byday) (list (ev-dt-weekday dtstart)) (sort byday))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
ev-weekly-loop
|
|
||||||
(fn
|
|
||||||
(id
|
|
||||||
week-days
|
|
||||||
tod
|
|
||||||
duration
|
|
||||||
week-step
|
|
||||||
bd
|
|
||||||
count
|
|
||||||
until
|
|
||||||
dtstart
|
|
||||||
win-start
|
|
||||||
win-end
|
|
||||||
acc
|
|
||||||
n)
|
|
||||||
(let
|
|
||||||
((week-start-dt (* week-days 1440)))
|
|
||||||
(cond
|
|
||||||
((> week-start-dt win-end) acc)
|
|
||||||
((and (not (nil? count)) (>= n count)) acc)
|
|
||||||
(else
|
|
||||||
(let
|
|
||||||
((occs (map (fn (wd) (+ (* (+ week-days wd) 1440) tod)) bd)))
|
|
||||||
(let
|
|
||||||
((n2 (ev-emit-occs id occs duration count until dtstart win-start win-end acc n)))
|
|
||||||
(ev-weekly-loop
|
|
||||||
id
|
|
||||||
(+ week-days week-step)
|
|
||||||
tod
|
|
||||||
duration
|
|
||||||
week-step
|
|
||||||
bd
|
|
||||||
count
|
|
||||||
until
|
|
||||||
dtstart
|
|
||||||
win-start
|
|
||||||
win-end
|
|
||||||
acc
|
|
||||||
n2))))))))
|
|
||||||
|
|
||||||
;; ---- MONTHLY expansion ----
|
|
||||||
;; Iterate month by month from dtstart's month, stepping by INTERVAL months.
|
|
||||||
;; Candidate days per month come from BYMONTHDAY, then ordinal BYDAY, else the
|
|
||||||
;; day-of-month of dtstart (skipped in months too short to contain it).
|
|
||||||
|
|
||||||
;; Resolve a BYMONTHDAY value to a valid day-of-month, or nil.
|
|
||||||
(define
|
|
||||||
ev-resolve-monthday
|
|
||||||
(fn
|
|
||||||
(y m bmd)
|
|
||||||
(let
|
|
||||||
((dim (ev-days-in-month y m)))
|
|
||||||
(let
|
|
||||||
((day (if (< bmd 0) (+ dim 1 bmd) bmd)))
|
|
||||||
(if (and (>= day 1) (<= day dim)) day nil)))))
|
|
||||||
|
|
||||||
;; Resolve an ordinal weekday {:ord :wd} to a day-of-month, or nil.
|
|
||||||
(define
|
|
||||||
ev-resolve-nth-weekday
|
|
||||||
(fn
|
|
||||||
(y m ord wd)
|
|
||||||
(let
|
|
||||||
((dim (ev-days-in-month y m)))
|
|
||||||
(if
|
|
||||||
(> ord 0)
|
|
||||||
(let
|
|
||||||
((first-wd (ev-weekday-of-days (ev-days-from-civil y m 1))))
|
|
||||||
(let
|
|
||||||
((day (+ 1 (modulo (- wd first-wd) 7) (* (- ord 1) 7))))
|
|
||||||
(if (<= day dim) day nil)))
|
|
||||||
(let
|
|
||||||
((last-wd (ev-weekday-of-days (ev-days-from-civil y m dim))))
|
|
||||||
(let
|
|
||||||
((day (- dim (modulo (- last-wd wd) 7) (* (- (- ord) 1) 7))))
|
|
||||||
(if (>= day 1) day nil)))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
ev-month-candidates
|
|
||||||
(fn
|
|
||||||
(y m rrule dtstart)
|
|
||||||
(let
|
|
||||||
((bmd (get rrule :bymonthday)) (byday (get rrule :byday)))
|
|
||||||
(cond
|
|
||||||
((not (nil? bmd))
|
|
||||||
(ev-filter-nil (map (fn (d) (ev-resolve-monthday y m d)) bmd)))
|
|
||||||
((not (nil? byday))
|
|
||||||
(ev-filter-nil
|
|
||||||
(map
|
|
||||||
(fn
|
|
||||||
(e)
|
|
||||||
(ev-resolve-nth-weekday y m (get e :ord) (get e :wd)))
|
|
||||||
byday)))
|
|
||||||
(else
|
|
||||||
(ev-filter-nil
|
|
||||||
(list
|
|
||||||
(ev-resolve-monthday y m (ev-civ-d (ev-dt->civil dtstart))))))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
ev-monthly-loop
|
|
||||||
(fn
|
|
||||||
(id
|
|
||||||
y
|
|
||||||
m
|
|
||||||
rrule
|
|
||||||
duration
|
|
||||||
tod
|
|
||||||
interval
|
|
||||||
count
|
|
||||||
until
|
|
||||||
dtstart
|
|
||||||
win-start
|
|
||||||
win-end
|
|
||||||
acc
|
|
||||||
n)
|
|
||||||
(let
|
|
||||||
((month-start (ev-dt y m 1 0 0)))
|
|
||||||
(cond
|
|
||||||
((> month-start win-end) acc)
|
|
||||||
((and (not (nil? count)) (>= n count)) acc)
|
|
||||||
(else
|
|
||||||
(let
|
|
||||||
((days (sort (ev-month-candidates y m rrule dtstart))))
|
|
||||||
(let
|
|
||||||
((occs (map (fn (d) (+ (* (ev-days-from-civil y m d) 1440) tod)) days)))
|
|
||||||
(let
|
|
||||||
((n2 (ev-emit-occs id occs duration count until dtstart win-start win-end acc n))
|
|
||||||
(nm (ev-add-months y m interval)))
|
|
||||||
(ev-monthly-loop
|
|
||||||
id
|
|
||||||
(ev-civ-y nm)
|
|
||||||
(ev-civ-m nm)
|
|
||||||
rrule
|
|
||||||
duration
|
|
||||||
tod
|
|
||||||
interval
|
|
||||||
count
|
|
||||||
until
|
|
||||||
dtstart
|
|
||||||
win-start
|
|
||||||
win-end
|
|
||||||
acc
|
|
||||||
n2)))))))))
|
|
||||||
|
|
||||||
;; ---- top-level expansion ----
|
|
||||||
;; Raw expansion (RRULE / single event), before EXDATE/RDATE are applied.
|
|
||||||
;; Returns a list of occurrence dicts {:id :start :end} within the window.
|
|
||||||
(define
|
|
||||||
ev-expand-base
|
|
||||||
(fn
|
|
||||||
(event win-start win-end)
|
|
||||||
(let
|
|
||||||
((id (get event :id))
|
|
||||||
(dtstart (get event :dtstart))
|
|
||||||
(duration (get event :duration))
|
|
||||||
(rrule (get event :rrule)))
|
|
||||||
(if
|
|
||||||
(nil? rrule)
|
|
||||||
(if
|
|
||||||
(and (>= dtstart win-start) (<= dtstart win-end))
|
|
||||||
(list (ev-occ id dtstart duration))
|
|
||||||
(list))
|
|
||||||
(let
|
|
||||||
((freq (get rrule :freq))
|
|
||||||
(interval (ev-or (get rrule :interval) 1))
|
|
||||||
(count (get rrule :count))
|
|
||||||
(until (get rrule :until))
|
|
||||||
(byday (get rrule :byday))
|
|
||||||
(acc (list)))
|
|
||||||
(begin
|
|
||||||
(cond
|
|
||||||
((= freq :daily)
|
|
||||||
(ev-daily-loop
|
|
||||||
id
|
|
||||||
dtstart
|
|
||||||
duration
|
|
||||||
(* interval 1440)
|
|
||||||
count
|
|
||||||
until
|
|
||||||
dtstart
|
|
||||||
win-start
|
|
||||||
win-end
|
|
||||||
acc
|
|
||||||
0))
|
|
||||||
((= freq :weekly)
|
|
||||||
(ev-weekly-loop
|
|
||||||
id
|
|
||||||
(ev-week0-days dtstart)
|
|
||||||
(ev-dt-tod dtstart)
|
|
||||||
duration
|
|
||||||
(* interval 7)
|
|
||||||
(ev-byday-default byday dtstart)
|
|
||||||
count
|
|
||||||
until
|
|
||||||
dtstart
|
|
||||||
win-start
|
|
||||||
win-end
|
|
||||||
acc
|
|
||||||
0))
|
|
||||||
((= freq :monthly)
|
|
||||||
(let
|
|
||||||
((civ (ev-dt->civil dtstart)))
|
|
||||||
(ev-monthly-loop
|
|
||||||
id
|
|
||||||
(ev-civ-y civ)
|
|
||||||
(ev-civ-m civ)
|
|
||||||
rrule
|
|
||||||
duration
|
|
||||||
(ev-dt-tod dtstart)
|
|
||||||
interval
|
|
||||||
count
|
|
||||||
until
|
|
||||||
dtstart
|
|
||||||
win-start
|
|
||||||
win-end
|
|
||||||
acc
|
|
||||||
0)))
|
|
||||||
(else (error (str "ev-expand-base: unsupported freq: " freq))))
|
|
||||||
acc))))))
|
|
||||||
|
|
||||||
;; ---- EXDATE / RDATE (RFC 5545 exceptions) ----
|
|
||||||
;; Applied AFTER raw expansion: RDATE adds explicit occurrences within the
|
|
||||||
;; window, EXDATE removes occurrences whose start matches (EXDATE wins over
|
|
||||||
;; RDATE). Both are VEVENT-level: (get event :exdate) / (get event :rdate) are
|
|
||||||
;; lists of epoch-minute starts; nil for plain events.
|
|
||||||
|
|
||||||
(define
|
|
||||||
ev-num-member?
|
|
||||||
(fn
|
|
||||||
(n xs)
|
|
||||||
(cond
|
|
||||||
((empty? xs) false)
|
|
||||||
((= n (first xs)) true)
|
|
||||||
(else (ev-num-member? n (rest xs))))))
|
|
||||||
|
|
||||||
;; Drop duplicate-start occurrences from a start-sorted list (keep one).
|
|
||||||
(define
|
|
||||||
ev-dedupe-by-start
|
|
||||||
(fn
|
|
||||||
(occs)
|
|
||||||
(cond
|
|
||||||
((empty? occs) occs)
|
|
||||||
((empty? (rest occs)) occs)
|
|
||||||
((= (get (first occs) :start) (get (first (rest occs)) :start))
|
|
||||||
(ev-dedupe-by-start (rest occs)))
|
|
||||||
(else (cons (first occs) (ev-dedupe-by-start (rest occs)))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
ev-apply-exceptions
|
|
||||||
(fn
|
|
||||||
(event base win-start win-end)
|
|
||||||
(let
|
|
||||||
((id (get event :id))
|
|
||||||
(duration (get event :duration))
|
|
||||||
(exdate (ev-or (get event :exdate) (list)))
|
|
||||||
(rdate (ev-or (get event :rdate) (list))))
|
|
||||||
(let
|
|
||||||
((rdate-occs
|
|
||||||
(reduce
|
|
||||||
(fn
|
|
||||||
(acc d)
|
|
||||||
(if
|
|
||||||
(and (>= d win-start) (<= d win-end))
|
|
||||||
(cons (ev-occ id d duration) acc)
|
|
||||||
acc))
|
|
||||||
(list)
|
|
||||||
rdate)))
|
|
||||||
(let
|
|
||||||
((no-ex
|
|
||||||
(filter
|
|
||||||
(fn (o) (not (ev-num-member? (get o :start) exdate)))
|
|
||||||
(append base rdate-occs))))
|
|
||||||
(ev-dedupe-by-start (ev-sort-occs no-ex)))))))
|
|
||||||
|
|
||||||
;; ---- per-occurrence overrides (RFC 5545 RECURRENCE-ID) ----
|
|
||||||
;; A single instance of a recurring series can be detached and rescheduled. The
|
|
||||||
;; event carries :overrides — a list of (orig-start {:start :duration}) — keyed
|
|
||||||
;; by the occurrence's ORIGINAL start. Applied after EXDATE/RDATE. A moved
|
|
||||||
;; instance whose new start leaves the window is dropped from this window (the
|
|
||||||
;; original slot is vacated); an instance moved INTO the window from outside is
|
|
||||||
;; out of scope for a windowed expansion (known stub limitation).
|
|
||||||
|
|
||||||
(define
|
|
||||||
ev-assoc-lookup
|
|
||||||
(fn
|
|
||||||
(k pairs)
|
|
||||||
(cond
|
|
||||||
((empty? pairs) nil)
|
|
||||||
((= (first (first pairs)) k) (first (rest (first pairs))))
|
|
||||||
(else (ev-assoc-lookup k (rest pairs))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
ev-apply-overrides
|
|
||||||
(fn
|
|
||||||
(id base overrides)
|
|
||||||
(map
|
|
||||||
(fn
|
|
||||||
(o)
|
|
||||||
(let
|
|
||||||
((ov (ev-assoc-lookup (get o :start) overrides)))
|
|
||||||
(if (nil? ov) o (ev-occ id (get ov :start) (get ov :duration)))))
|
|
||||||
base)))
|
|
||||||
|
|
||||||
;; Add an override that reschedules the occurrence originally at `orig-start`
|
|
||||||
;; to `new-start` with `new-duration`.
|
|
||||||
(define
|
|
||||||
ev-with-override
|
|
||||||
(fn
|
|
||||||
(event orig-start new-start new-duration)
|
|
||||||
(assoc
|
|
||||||
event
|
|
||||||
:overrides
|
|
||||||
(cons
|
|
||||||
(list orig-start {:start new-start :duration new-duration})
|
|
||||||
(ev-or (get event :overrides) (list))))))
|
|
||||||
|
|
||||||
;; Naive (single time-domain) expansion: RRULE + EXDATE/RDATE + overrides.
|
|
||||||
(define
|
|
||||||
ev-expand-naive
|
|
||||||
(fn
|
|
||||||
(event win-start win-end)
|
|
||||||
(let
|
|
||||||
((excepted
|
|
||||||
(ev-apply-exceptions
|
|
||||||
event
|
|
||||||
(ev-expand-base event win-start win-end)
|
|
||||||
win-start
|
|
||||||
win-end))
|
|
||||||
(overrides (ev-or (get event :overrides) (list)))
|
|
||||||
(id (get event :id)))
|
|
||||||
(if
|
|
||||||
(empty? overrides)
|
|
||||||
excepted
|
|
||||||
(filter
|
|
||||||
(fn (o) (and (>= (get o :start) win-start) (<= (get o :start) win-end)))
|
|
||||||
(ev-sort-occs (ev-apply-overrides id excepted overrides)))))))
|
|
||||||
|
|
||||||
;; Public entry point. A tz-aware event (`:tz` set) expands in local wall-clock
|
|
||||||
;; time and converts each occurrence to UTC (ev-expand-tz, timezone.sx); a plain
|
|
||||||
;; event expands naively in a single time domain. The window is UTC either way.
|
|
||||||
(define
|
|
||||||
ev-expand
|
|
||||||
(fn
|
|
||||||
(event win-start win-end)
|
|
||||||
(let
|
|
||||||
((tz (get event :tz)))
|
|
||||||
(if
|
|
||||||
(nil? tz)
|
|
||||||
(ev-expand-naive event win-start win-end)
|
|
||||||
(ev-expand-tz event tz win-start win-end)))))
|
|
||||||
|
|
||||||
;; ---- multi-event expansion (sorted by start) ----
|
|
||||||
|
|
||||||
;; Insertion of one occurrence into a start-ascending list.
|
|
||||||
(define
|
|
||||||
ev-occ-insert
|
|
||||||
(fn
|
|
||||||
(o sorted)
|
|
||||||
(cond
|
|
||||||
((empty? sorted) (list o))
|
|
||||||
((<= (get o :start) (get (first sorted) :start)) (cons o sorted))
|
|
||||||
(else (cons (first sorted) (ev-occ-insert o (rest sorted)))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
ev-sort-occs
|
|
||||||
(fn (occs) (reduce (fn (acc o) (ev-occ-insert o acc)) (list) occs)))
|
|
||||||
|
|
||||||
;; Expand many events into one occurrence list, ascending by start.
|
|
||||||
(define
|
|
||||||
ev-expand-all
|
|
||||||
(fn
|
|
||||||
(events win-start win-end)
|
|
||||||
(let
|
|
||||||
((acc (list)))
|
|
||||||
(begin
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(ev)
|
|
||||||
(for-each
|
|
||||||
(fn (o) (append! acc o))
|
|
||||||
(ev-expand ev win-start win-end)))
|
|
||||||
events)
|
|
||||||
(ev-sort-occs acc)))))
|
|
||||||
@@ -1,61 +0,0 @@
|
|||||||
# events-on-sx conformance config — sourced by lib/guest/conformance.sh.
|
|
||||||
|
|
||||||
LANG_NAME=events
|
|
||||||
MODE=dict
|
|
||||||
SCOREBOARD_DIR=lib/events
|
|
||||||
|
|
||||||
PRELOADS=(
|
|
||||||
spec/stdlib.sx
|
|
||||||
lib/r7rs.sx
|
|
||||||
lib/datalog/tokenizer.sx
|
|
||||||
lib/datalog/parser.sx
|
|
||||||
lib/datalog/unify.sx
|
|
||||||
lib/datalog/db.sx
|
|
||||||
lib/datalog/builtins.sx
|
|
||||||
lib/datalog/aggregates.sx
|
|
||||||
lib/datalog/strata.sx
|
|
||||||
lib/datalog/eval.sx
|
|
||||||
lib/datalog/api.sx
|
|
||||||
lib/datalog/magic.sx
|
|
||||||
lib/events/calendar.sx
|
|
||||||
lib/events/timezone.sx
|
|
||||||
lib/events/availability.sx
|
|
||||||
lib/persist/event.sx
|
|
||||||
lib/persist/backend.sx
|
|
||||||
lib/persist/log.sx
|
|
||||||
lib/persist/kv.sx
|
|
||||||
lib/persist/concurrency.sx
|
|
||||||
lib/persist/api.sx
|
|
||||||
lib/events/booking.sx
|
|
||||||
lib/events/booking-notify.sx
|
|
||||||
lib/events/ticket.sx
|
|
||||||
lib/guest/lex.sx
|
|
||||||
lib/guest/reflective/env.sx
|
|
||||||
lib/guest/reflective/quoting.sx
|
|
||||||
lib/scheme/parser.sx
|
|
||||||
lib/scheme/eval.sx
|
|
||||||
lib/scheme/runtime.sx
|
|
||||||
lib/flow/spec.sx
|
|
||||||
lib/flow/store.sx
|
|
||||||
lib/flow/remote.sx
|
|
||||||
lib/flow/host.sx
|
|
||||||
lib/flow/api.sx
|
|
||||||
lib/events/notify.sx
|
|
||||||
lib/events/api.sx
|
|
||||||
lib/events/reminders.sx
|
|
||||||
lib/events/federation.sx
|
|
||||||
)
|
|
||||||
|
|
||||||
SUITES=(
|
|
||||||
"calendar:lib/events/tests/calendar.sx:(ev-calendar-tests-run!)"
|
|
||||||
"timezone:lib/events/tests/timezone.sx:(ev-timezone-tests-run!)"
|
|
||||||
"availability:lib/events/tests/availability.sx:(ev-availability-tests-run!)"
|
|
||||||
"api:lib/events/tests/api.sx:(ev-api-tests-run!)"
|
|
||||||
"booking:lib/events/tests/booking.sx:(ev-booking-tests-run!)"
|
|
||||||
"booking-notify:lib/events/tests/booking-notify.sx:(ev-booking-notify-tests-run!)"
|
|
||||||
"ticket:lib/events/tests/ticket.sx:(ev-ticket-tests-run!)"
|
|
||||||
"notify:lib/events/tests/notify.sx:(ev-notify-tests-run!)"
|
|
||||||
"reminders:lib/events/tests/reminders.sx:(ev-reminders-tests-run!)"
|
|
||||||
"federation:lib/events/tests/federation.sx:(ev-federation-tests-run!)"
|
|
||||||
"integration:lib/events/tests/integration.sx:(ev-integration-tests-run!)"
|
|
||||||
)
|
|
||||||
@@ -1,3 +0,0 @@
|
|||||||
#!/usr/bin/env bash
|
|
||||||
# Thin wrapper — see lib/guest/conformance.sh and lib/events/conformance.conf.
|
|
||||||
exec bash "$(dirname "$0")/../guest/conformance.sh" "$(dirname "$0")/conformance.conf" "$@"
|
|
||||||
@@ -1,232 +0,0 @@
|
|||||||
;; lib/events/federation.sx — cross-instance calendar federation (trust-gated).
|
|
||||||
;;
|
|
||||||
;; A peer is another events instance that publishes a schedule (an events
|
|
||||||
;; store). We merge a peer's agenda into ours ONLY if we trust it — trust is a
|
|
||||||
;; set of peer ids, re-checked on every merge, so revoking a peer takes effect
|
|
||||||
;; immediately. Merged occurrences carry :origin provenance (:local for ours, or
|
|
||||||
;; the peer id) so a consumer always knows where a slot came from.
|
|
||||||
;;
|
|
||||||
;; This is the trust-gated stub: peers publish plain schedules and we fold the
|
|
||||||
;; trusted ones into a single sorted agenda. Real transport (fed-sx / signed
|
|
||||||
;; fetch) slots in behind `ev/peer-agenda` without changing the merge.
|
|
||||||
;;
|
|
||||||
;; Federated FREE/BUSY follows the iCal model: a peer publishes BUSY intervals
|
|
||||||
;; for an actor (not event details — privacy-preserving), and we union local +
|
|
||||||
;; trusted-peer busy to answer "is this actor free?" across instances.
|
|
||||||
|
|
||||||
(define ev/peer (fn (id store) {:id id :busy (list) :store store}))
|
|
||||||
|
|
||||||
;; A peer that also publishes free/busy: `busy` is a list of
|
|
||||||
;; (actor ((start end) ...)) pairs.
|
|
||||||
(define ev/peer-with-busy (fn (id store busy) {:id id :busy busy :store store}))
|
|
||||||
|
|
||||||
(define ev/peer-id (fn (p) (get p :id)))
|
|
||||||
(define ev/peer-store (fn (p) (get p :store)))
|
|
||||||
(define ev/peer-busy-table (fn (p) (get p :busy)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
ev-fed-member?
|
|
||||||
(fn
|
|
||||||
(x xs)
|
|
||||||
(cond
|
|
||||||
((empty? xs) false)
|
|
||||||
((= x (first xs)) true)
|
|
||||||
(else (ev-fed-member? x (rest xs))))))
|
|
||||||
|
|
||||||
;; Do we trust this peer id? (trust is a list of trusted peer ids.)
|
|
||||||
(define ev/trusts? (fn (trust peer-id) (ev-fed-member? peer-id trust)))
|
|
||||||
|
|
||||||
;; The trusted subset of a peer list.
|
|
||||||
(define
|
|
||||||
ev/trusted-peers
|
|
||||||
(fn
|
|
||||||
(peers trust)
|
|
||||||
(filter (fn (p) (ev/trusts? trust (ev/peer-id p))) peers)))
|
|
||||||
|
|
||||||
;; Tag occurrences with provenance.
|
|
||||||
(define ev-tag-origin (fn (occs origin) (map (fn (o) {:id (get o :id) :start (get o :start) :end (get o :end) :origin origin}) occs)))
|
|
||||||
|
|
||||||
;; A peer's agenda over [ws, we), tagged with the peer's id as :origin.
|
|
||||||
(define
|
|
||||||
ev/peer-agenda
|
|
||||||
(fn
|
|
||||||
(peer ws we)
|
|
||||||
(ev-tag-origin (ev/agenda (ev/peer-store peer) ws we) (ev/peer-id peer))))
|
|
||||||
|
|
||||||
;; ---- merge (sorted by start, then origin for ties) ----
|
|
||||||
|
|
||||||
(define
|
|
||||||
ev-fed-before?
|
|
||||||
(fn
|
|
||||||
(a c)
|
|
||||||
(cond
|
|
||||||
((< (get a :start) (get c :start)) true)
|
|
||||||
((> (get a :start) (get c :start)) false)
|
|
||||||
(else (< (str (get a :origin)) (str (get c :origin)))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
ev-fed-insert
|
|
||||||
(fn
|
|
||||||
(x sorted)
|
|
||||||
(cond
|
|
||||||
((empty? sorted) (list x))
|
|
||||||
((ev-fed-before? x (first sorted)) (cons x sorted))
|
|
||||||
(else (cons (first sorted) (ev-fed-insert x (rest sorted)))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
ev-fed-sort
|
|
||||||
(fn (xs) (reduce (fn (acc x) (ev-fed-insert x acc)) (list) xs)))
|
|
||||||
|
|
||||||
;; Local agenda (origin :local) merged with every TRUSTED peer's agenda,
|
|
||||||
;; sorted by start. Untrusted peers contribute nothing.
|
|
||||||
(define
|
|
||||||
ev/federated-agenda
|
|
||||||
(fn
|
|
||||||
(local-store peers trust ws we)
|
|
||||||
(let
|
|
||||||
((acc (list)))
|
|
||||||
(begin
|
|
||||||
(for-each
|
|
||||||
(fn (o) (append! acc o))
|
|
||||||
(ev-tag-origin (ev/agenda local-store ws we) :local))
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(peer)
|
|
||||||
(when
|
|
||||||
(ev/trusts? trust (ev/peer-id peer))
|
|
||||||
(for-each
|
|
||||||
(fn (o) (append! acc o))
|
|
||||||
(ev/peer-agenda peer ws we))))
|
|
||||||
peers)
|
|
||||||
(ev-fed-sort acc)))))
|
|
||||||
|
|
||||||
;; Filter a federated agenda to occurrences from one origin.
|
|
||||||
(define
|
|
||||||
ev/from-origin
|
|
||||||
(fn
|
|
||||||
(agenda origin)
|
|
||||||
(filter (fn (o) (= (get o :origin) origin)) agenda)))
|
|
||||||
|
|
||||||
;; ---- federated free/busy ----
|
|
||||||
|
|
||||||
;; A peer's published busy intervals for `actor` ((start end) ...), or empty.
|
|
||||||
(define
|
|
||||||
ev/peer-busy
|
|
||||||
(fn
|
|
||||||
(peer actor)
|
|
||||||
(let
|
|
||||||
((row (ev-fed-assoc actor (ev/peer-busy-table peer))))
|
|
||||||
(if (nil? row) (list) (first (rest row))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
ev-fed-assoc
|
|
||||||
(fn
|
|
||||||
(k pairs)
|
|
||||||
(cond
|
|
||||||
((empty? pairs) nil)
|
|
||||||
((= (first (first pairs)) k) (first pairs))
|
|
||||||
(else (ev-fed-assoc k (rest pairs))))))
|
|
||||||
|
|
||||||
;; All busy intervals for `actor` across the LOCAL availability db plus every
|
|
||||||
;; TRUSTED peer's published free/busy, merged and sorted by start.
|
|
||||||
;; `local-db` is an availability db (see availability.sx ev-build-avail).
|
|
||||||
(define
|
|
||||||
ev/federated-busy
|
|
||||||
(fn
|
|
||||||
(local-db peers trust actor)
|
|
||||||
(let
|
|
||||||
((acc (list)))
|
|
||||||
(begin
|
|
||||||
(for-each (fn (iv) (append! acc iv)) (ev-busy local-db actor))
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(peer)
|
|
||||||
(when
|
|
||||||
(ev/trusts? trust (ev/peer-id peer))
|
|
||||||
(for-each
|
|
||||||
(fn (iv) (append! acc iv))
|
|
||||||
(ev/peer-busy peer actor))))
|
|
||||||
peers)
|
|
||||||
(ev-sort-lists acc)))))
|
|
||||||
|
|
||||||
;; Half-open overlap of interval (s e) with window [qs, qe).
|
|
||||||
(define
|
|
||||||
ev-fed-overlaps?
|
|
||||||
(fn (iv qs qe) (and (< (first iv) qe) (< qs (first (rest iv))))))
|
|
||||||
|
|
||||||
;; Is `actor` free across [qs, qe) considering local + trusted-peer busy?
|
|
||||||
(define
|
|
||||||
ev/federated-free?
|
|
||||||
(fn
|
|
||||||
(local-db peers trust actor qs qe)
|
|
||||||
(not
|
|
||||||
(some
|
|
||||||
(fn (iv) (ev-fed-overlaps? iv qs qe))
|
|
||||||
(ev/federated-busy local-db peers trust actor)))))
|
|
||||||
|
|
||||||
;; ---- injected transport (real fed-sx / signed fetch) ----
|
|
||||||
;; The in-process merge above expands a peer's local :store directly. In
|
|
||||||
;; production a peer's agenda arrives over a transport. `fetch` abstracts that:
|
|
||||||
;; (fetch peer-id ws we) -> {:status :ok :occurrences (...)} | {:status :error :reason ...}
|
|
||||||
;; The same merge works for any transport; an unreachable peer (:error) is
|
|
||||||
;; skipped (graceful degradation), never breaking the agenda.
|
|
||||||
|
|
||||||
(define
|
|
||||||
ev-find-peer
|
|
||||||
(fn
|
|
||||||
(peers pid)
|
|
||||||
(cond
|
|
||||||
((empty? peers) nil)
|
|
||||||
((= (ev/peer-id (first peers)) pid) (first peers))
|
|
||||||
(else (ev-find-peer (rest peers) pid)))))
|
|
||||||
|
|
||||||
;; In-process transport adapter: resolves a peer-id against a peer list and
|
|
||||||
;; expands its :store. Lets the in-process model run through the same `fetch`
|
|
||||||
;; interface a remote transport implements.
|
|
||||||
(define
|
|
||||||
ev/peer-fetch
|
|
||||||
(fn
|
|
||||||
(peers)
|
|
||||||
(fn
|
|
||||||
(pid ws we)
|
|
||||||
(let
|
|
||||||
((p (ev-find-peer peers pid)))
|
|
||||||
(if
|
|
||||||
(nil? p)
|
|
||||||
{:status :error :reason :unknown-peer}
|
|
||||||
{:status :ok :occurrences (ev/agenda (ev/peer-store p) ws we)})))))
|
|
||||||
|
|
||||||
;; Local agenda (:local) merged with each trusted peer's agenda fetched via the
|
|
||||||
;; injected `fetch` transport, sorted by start, tagged with :origin. Peers that
|
|
||||||
;; fail to fetch contribute nothing.
|
|
||||||
(define
|
|
||||||
ev/federated-agenda-via
|
|
||||||
(fn
|
|
||||||
(local-store trusted-ids ws we fetch)
|
|
||||||
(let
|
|
||||||
((acc (list)))
|
|
||||||
(begin
|
|
||||||
(for-each
|
|
||||||
(fn (o) (append! acc o))
|
|
||||||
(ev-tag-origin (ev/agenda local-store ws we) :local))
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(pid)
|
|
||||||
(let
|
|
||||||
((res (fetch pid ws we)))
|
|
||||||
(when
|
|
||||||
(= (get res :status) :ok)
|
|
||||||
(for-each
|
|
||||||
(fn (o) (append! acc o))
|
|
||||||
(ev-tag-origin (get res :occurrences) pid)))))
|
|
||||||
trusted-ids)
|
|
||||||
(ev-fed-sort acc)))))
|
|
||||||
|
|
||||||
;; Reachability report: ((peer-id :ok|:error) ...) for the trusted peers.
|
|
||||||
(define
|
|
||||||
ev/federation-status
|
|
||||||
(fn
|
|
||||||
(trusted-ids ws we fetch)
|
|
||||||
(map
|
|
||||||
(fn (pid) (list pid (get (fetch pid ws we) :status)))
|
|
||||||
trusted-ids)))
|
|
||||||
@@ -1,97 +0,0 @@
|
|||||||
;; lib/events/notify.sx — durable notification delivery flows over an injected
|
|
||||||
;; transport (lib/flow).
|
|
||||||
;;
|
|
||||||
;; Reminders and digests are durable `flow`s: a flow `request`s delivery (a
|
|
||||||
;; suspend point), the HOST performs the actual send via an injected `dispatch`
|
|
||||||
;; (the transport — email/push/etc.), and resumes the flow with the outcome.
|
|
||||||
;; Because flow uses deterministic replay, a completed delivery is never re-run
|
|
||||||
;; on recovery; the host owns IO and persistence.
|
|
||||||
;;
|
|
||||||
;; Delivery is AT-LEAST-ONCE with idempotency. Each message carries an id (the
|
|
||||||
;; idempotency key). Two protections stop double-delivery:
|
|
||||||
;; 1. The transport dedups by id — a re-send of a delivered id is a no-op
|
|
||||||
;; that still reports ok, so a retry never produces two pings.
|
|
||||||
;; 2. flow's replay log records each resolved request, so recovery replays the
|
|
||||||
;; logged outcome instead of re-issuing the send.
|
|
||||||
;;
|
|
||||||
;; Retry/backoff rides flow suspend/resume: each attempt issues a request with a
|
|
||||||
;; DISTINCT tag `(deliver <id> <n>)` — distinct tags keep deterministic replay
|
|
||||||
;; correct across retries. The dispatch returns (ok info) to finish or
|
|
||||||
;; (retry reason) to try again, bounded by `maxn` (then (failed id reason)).
|
|
||||||
;;
|
|
||||||
;; A message is a 3-element list (id recipient body). The transport is generic
|
|
||||||
;; and injected — when feed/notify lands, both consumers share one transport,
|
|
||||||
;; so this delivery core is a candidate for extraction to `delivery-on-sx`.
|
|
||||||
;;
|
|
||||||
;; The Scheme flow source below loads into a flow env (see lib/flow/api.sx).
|
|
||||||
;; `ev/notify-run` prepends it to a caller program and evaluates in the shared
|
|
||||||
;; flow env.
|
|
||||||
|
|
||||||
(define
|
|
||||||
ev-notify-flows-src
|
|
||||||
"(define (ev-msg-id m) (car m))\n (define (ev-msg-recipient m) (car (cdr m)))\n (define (ev-msg-body m) (car (cdr (cdr m))))\n (define (ev-mem x xs)\n (if (null? xs) #f (if (equal? x (car xs)) #t (ev-mem x (cdr xs)))))\n (define (ev-notify-attempt m n maxn)\n (let ((r (request (list (quote deliver) (ev-msg-id m) n) m)))\n (if (eq? (car r) (quote ok))\n (list (quote delivered) (ev-msg-id m) n)\n (if (>= n maxn)\n (list (quote failed) (ev-msg-id m) (car (cdr r)))\n (ev-notify-attempt m (+ n 1) maxn)))))\n (define (ev-deliver-reminder maxn)\n (flow-node (lambda (m) (ev-notify-attempt m 1 maxn))))\n (define (ev-digest-step ms maxn)\n (if (null? ms)\n (list)\n (cons (ev-notify-attempt (car ms) 1 maxn)\n (ev-digest-step (cdr ms) maxn))))\n (define (ev-deliver-digest maxn)\n (flow-node (lambda (ms) (ev-digest-step ms maxn))))")
|
|
||||||
|
|
||||||
;; Run a Scheme flow program with the notify flows preloaded, in the shared
|
|
||||||
;; flow env. Returns the program's value (SX-native).
|
|
||||||
(define
|
|
||||||
ev/notify-run
|
|
||||||
(fn (prog) (flow-run (str ev-notify-flows-src "\n" prog))))
|
|
||||||
|
|
||||||
;; ---- end-to-end delivery: SX messages -> the notify flow ----
|
|
||||||
;; Bridges the SX notification-derivation modules (reminders / booking-notify /
|
|
||||||
;; reschedule) to the durable delivery flow. An SX message (id recipient body)
|
|
||||||
;; is serialized to s-expression text and spliced into the Scheme program as
|
|
||||||
;; quoted data, then the digest flow delivers the batch over an injected
|
|
||||||
;; transport. Strings round-trip through the guest Scheme as {:scm-string ...}
|
|
||||||
;; boxes; results are unboxed back to plain SX.
|
|
||||||
|
|
||||||
;; A default transport (Scheme source): always reports delivered.
|
|
||||||
(define ev-notify-ok-transport "(lambda (k p) (list (quote ok) (quote sent)))")
|
|
||||||
|
|
||||||
(define
|
|
||||||
ev-notify-join
|
|
||||||
(fn
|
|
||||||
(parts sep)
|
|
||||||
(if
|
|
||||||
(empty? parts)
|
|
||||||
""
|
|
||||||
(reduce (fn (acc p) (str acc sep p)) (first parts) (rest parts)))))
|
|
||||||
|
|
||||||
(define ev-msg->quoted (fn (m) (str "(quote " (serialize m) ")")))
|
|
||||||
|
|
||||||
(define
|
|
||||||
ev-msgs->scheme
|
|
||||||
(fn
|
|
||||||
(msgs)
|
|
||||||
(str "(list " (ev-notify-join (map ev-msg->quoted msgs) " ") ")")))
|
|
||||||
|
|
||||||
(define
|
|
||||||
ev-unbox-str
|
|
||||||
(fn
|
|
||||||
(x)
|
|
||||||
(if (and (dict? x) (has-key? x :scm-string)) (get x :scm-string) x)))
|
|
||||||
|
|
||||||
(define
|
|
||||||
ev-unbox-result
|
|
||||||
(fn (r) (map (fn (item) (map ev-unbox-str item)) r)))
|
|
||||||
|
|
||||||
;; Deliver a list of SX messages through the digest flow over `transport-src`
|
|
||||||
;; (a Scheme (kind payload) -> (ok ..)|(retry reason) lambda source). `maxn`
|
|
||||||
;; bounds retries per message, `maxticks` bounds host service ticks. Returns the
|
|
||||||
;; per-message outcomes unboxed: (("delivered"|"failed" <id> <n-or-reason>) ...)
|
|
||||||
(define
|
|
||||||
ev/deliver-messages
|
|
||||||
(fn
|
|
||||||
(msgs transport-src maxn maxticks)
|
|
||||||
(ev-unbox-result
|
|
||||||
(ev/notify-run
|
|
||||||
(str
|
|
||||||
"(define msgs "
|
|
||||||
(ev-msgs->scheme msgs)
|
|
||||||
") (if (null? msgs) (list) (let ((s (flow/start (ev-deliver-digest "
|
|
||||||
maxn
|
|
||||||
") msgs))) (begin (flow-run-host "
|
|
||||||
transport-src
|
|
||||||
" "
|
|
||||||
maxticks
|
|
||||||
") (flow/result (car (cdr s))))))")))))
|
|
||||||
@@ -1,147 +0,0 @@
|
|||||||
;; lib/events/reminders.sx — derive reminder + digest messages from the agenda.
|
|
||||||
;;
|
|
||||||
;; Bridges the schedule (calendar) and the durable roster (booking on persist)
|
|
||||||
;; to the notification layer (notify.sx). For each booked attendee of each
|
|
||||||
;; upcoming occurrence we derive a reminder message that fires `lead` minutes
|
|
||||||
;; before the occurrence starts. Each message has a deterministic idempotency
|
|
||||||
;; key — occ-key / recipient / lead — so re-deriving over an overlapping window
|
|
||||||
;; never produces a duplicate ping (the notify transport dedups on this id).
|
|
||||||
;;
|
|
||||||
;; A reminder is a dict:
|
|
||||||
;; {:id :recipient :event :start :fire-at}
|
|
||||||
;; `ev/reminder->msg` projects it to notify's (id recipient body) wire shape.
|
|
||||||
|
|
||||||
;; Reminders for one occurrence: one per booked attendee (durable roster).
|
|
||||||
(define
|
|
||||||
ev/occurrence-reminders
|
|
||||||
(fn
|
|
||||||
(b occ lead)
|
|
||||||
(let
|
|
||||||
((occ-key (ev-occ-key occ))
|
|
||||||
(start (get occ :start))
|
|
||||||
(evid (get occ :id)))
|
|
||||||
(map (fn (actor) {:id (str occ-key "/" actor "/" lead) :event evid :start start :fire-at (- start lead) :recipient actor}) (ev/roster-occ b occ)))))
|
|
||||||
|
|
||||||
;; Insertion sort of reminder dicts ascending by :fire-at (then :id for ties).
|
|
||||||
(define
|
|
||||||
ev-rem-before?
|
|
||||||
(fn
|
|
||||||
(a c)
|
|
||||||
(cond
|
|
||||||
((< (get a :fire-at) (get c :fire-at)) true)
|
|
||||||
((> (get a :fire-at) (get c :fire-at)) false)
|
|
||||||
(else (< (get a :id) (get c :id))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
ev-rem-insert
|
|
||||||
(fn
|
|
||||||
(r sorted)
|
|
||||||
(cond
|
|
||||||
((empty? sorted) (list r))
|
|
||||||
((ev-rem-before? r (first sorted)) (cons r sorted))
|
|
||||||
(else (cons (first sorted) (ev-rem-insert r (rest sorted)))))))
|
|
||||||
|
|
||||||
(define
|
|
||||||
ev-rem-sort
|
|
||||||
(fn (rs) (reduce (fn (acc r) (ev-rem-insert r acc)) (list) rs)))
|
|
||||||
|
|
||||||
;; All reminders across the agenda in [ws, we), ascending by fire-at.
|
|
||||||
(define
|
|
||||||
ev/agenda-reminders
|
|
||||||
(fn
|
|
||||||
(b store ws we lead)
|
|
||||||
(let
|
|
||||||
((acc (list)))
|
|
||||||
(begin
|
|
||||||
(for-each
|
|
||||||
(fn
|
|
||||||
(occ)
|
|
||||||
(for-each
|
|
||||||
(fn (r) (append! acc r))
|
|
||||||
(ev/occurrence-reminders b occ lead)))
|
|
||||||
(ev/agenda store ws we))
|
|
||||||
(ev-rem-sort acc)))))
|
|
||||||
|
|
||||||
;; Reminders whose fire-at has arrived (fire-at <= now) — what a scheduler
|
|
||||||
;; should hand to the notify transport at time `now`.
|
|
||||||
(define
|
|
||||||
ev/due-reminders
|
|
||||||
(fn
|
|
||||||
(reminders now)
|
|
||||||
(filter (fn (r) (<= (get r :fire-at) now)) reminders)))
|
|
||||||
|
|
||||||
;; Project a reminder to notify's (id recipient body) wire shape.
|
|
||||||
(define
|
|
||||||
ev/reminder->msg
|
|
||||||
(fn
|
|
||||||
(r)
|
|
||||||
(list
|
|
||||||
(get r :id)
|
|
||||||
(get r :recipient)
|
|
||||||
(list :reminder (get r :event) (get r :start)))))
|
|
||||||
|
|
||||||
;; ---- digests ----
|
|
||||||
|
|
||||||
;; The occurrences `actor` is booked into (durable roster), within window.
|
|
||||||
(define
|
|
||||||
ev/agenda-for-p
|
|
||||||
(fn
|
|
||||||
(b store actor ws we)
|
|
||||||
(filter
|
|
||||||
(fn (occ) (ev-bk-member? actor (ev/roster-occ b occ)))
|
|
||||||
(ev/agenda store ws we))))
|
|
||||||
|
|
||||||
;; A single digest message summarising an actor's upcoming booked occurrences.
|
|
||||||
;; :items is ({:event :start} ...); empty when the actor has nothing booked.
|
|
||||||
(define ev/agenda-digest (fn (b store actor ws we) {:items (map (fn (occ) {:event (get occ :id) :start (get occ :start)}) (ev/agenda-for-p b store actor ws we)) :id (str actor "/digest/" ws "-" we) :recipient actor}))
|
|
||||||
|
|
||||||
;; ---- reschedule notifications ----
|
|
||||||
;; When an event carries per-occurrence overrides (ev-with-override), every
|
|
||||||
;; attendee booked at the ORIGINAL start should be told the new time. Bookings
|
|
||||||
;; were made against the original occ-key (id@orig-start), so we read that
|
|
||||||
;; roster. Idempotency key encodes the original key and the new start, so
|
|
||||||
;; re-deriving the same reschedule never double-notifies.
|
|
||||||
(define
|
|
||||||
ev/reschedule-notifications
|
|
||||||
(fn
|
|
||||||
(b event)
|
|
||||||
(let
|
|
||||||
((overrides (ev-or (get event :overrides) (list)))
|
|
||||||
(evid (get event :id))
|
|
||||||
(dur (get event :duration)))
|
|
||||||
(reduce
|
|
||||||
(fn
|
|
||||||
(acc entry)
|
|
||||||
(let
|
|
||||||
((orig-start (first entry))
|
|
||||||
(ov (first (rest entry))))
|
|
||||||
(let
|
|
||||||
((occ (ev-occ evid orig-start dur))
|
|
||||||
(new-start (get ov :start))
|
|
||||||
(new-duration (get ov :duration)))
|
|
||||||
(let
|
|
||||||
((key (ev-occ-key occ)))
|
|
||||||
(append
|
|
||||||
acc
|
|
||||||
(map
|
|
||||||
(fn
|
|
||||||
(actor)
|
|
||||||
{:id (str key "/reschedule/" new-start)
|
|
||||||
:recipient actor
|
|
||||||
:event evid
|
|
||||||
:old-start orig-start
|
|
||||||
:new-start new-start
|
|
||||||
:new-duration new-duration})
|
|
||||||
(ev/roster-occ b occ)))))))
|
|
||||||
(list)
|
|
||||||
overrides))))
|
|
||||||
|
|
||||||
;; Project a reschedule notification to notify's (id recipient body) shape.
|
|
||||||
(define
|
|
||||||
ev/reschedule-notify->msg
|
|
||||||
(fn
|
|
||||||
(r)
|
|
||||||
(list
|
|
||||||
(get r :id)
|
|
||||||
(get r :recipient)
|
|
||||||
(list :rescheduled (get r :event) (get r :old-start) (get r :new-start)))))
|
|
||||||
@@ -1,20 +0,0 @@
|
|||||||
{
|
|
||||||
"lang": "events",
|
|
||||||
"total_passed": 311,
|
|
||||||
"total_failed": 0,
|
|
||||||
"total": 311,
|
|
||||||
"suites": [
|
|
||||||
{"name":"calendar","passed":51,"failed":0,"total":51},
|
|
||||||
{"name":"timezone","passed":17,"failed":0,"total":17},
|
|
||||||
{"name":"availability","passed":22,"failed":0,"total":22},
|
|
||||||
{"name":"api","passed":32,"failed":0,"total":32},
|
|
||||||
{"name":"booking","passed":82,"failed":0,"total":82},
|
|
||||||
{"name":"booking-notify","passed":11,"failed":0,"total":11},
|
|
||||||
{"name":"ticket","passed":31,"failed":0,"total":31},
|
|
||||||
{"name":"notify","passed":7,"failed":0,"total":7},
|
|
||||||
{"name":"reminders","passed":21,"failed":0,"total":21},
|
|
||||||
{"name":"federation","passed":29,"failed":0,"total":29},
|
|
||||||
{"name":"integration","passed":8,"failed":0,"total":8}
|
|
||||||
],
|
|
||||||
"generated": "2026-06-07T13:59:09+00:00"
|
|
||||||
}
|
|
||||||
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue
Block a user