Compare commits
12 Commits
loops/drea
...
loops/cont
| Author | SHA1 | Date | |
|---|---|---|---|
| f68591456e | |||
| 160d0f2dd0 | |||
| e9316b37c2 | |||
| 29954689bc | |||
| f31c7a4002 | |||
| c5d9e1480d | |||
| c9a8f05244 | |||
| 9051f52f53 | |||
| 4d889716a3 | |||
| 2f626173d9 | |||
| 92c0c853a9 | |||
| 94b889c911 |
@@ -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);
|
||||
Dict d
|
||||
| _ ->
|
||||
let argsv = Sx_runtime.get_val request (String "args") in
|
||||
(match Sx_persist_store.handle_op op argsv with
|
||||
| Some resp -> resp
|
||||
| None ->
|
||||
let args = (match argsv with List l -> l | _ -> [argsv]) in
|
||||
io_request op args)
|
||||
let args = let a = Sx_runtime.get_val request (String "args") in
|
||||
(match a with List l -> l | _ -> [a]) in
|
||||
io_request op args
|
||||
in
|
||||
s := Sx_ref.cek_resume !s response;
|
||||
loop ()
|
||||
@@ -858,164 +855,6 @@ let setup_evaluator_bridge env =
|
||||
done;
|
||||
Nil
|
||||
| _ -> 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 ->
|
||||
match args with
|
||||
| [v] ->
|
||||
@@ -1701,12 +1540,7 @@ let rec dispatch env cmd =
|
||||
| Some path -> load_library_file path | None -> ());
|
||||
Nil
|
||||
end
|
||||
end else
|
||||
(* 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
|
||||
end else Nil (* non-import IO: resume with nil *) in
|
||||
s := Sx_ref.cek_resume !s response
|
||||
done;
|
||||
Sx_ref.cek_value !s
|
||||
@@ -4059,10 +3893,7 @@ let http_mode port =
|
||||
Dict d
|
||||
| "io-sleep" | "sleep" -> Nil
|
||||
| "import" -> Nil
|
||||
| _ ->
|
||||
(match Sx_persist_store.handle_op op args with
|
||||
| Some resp -> resp
|
||||
| None -> Nil));
|
||||
| _ -> Nil);
|
||||
(* Response cache — path → full HTTP response string.
|
||||
Populated during pre-warm, serves cached responses in <0.1ms.
|
||||
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
|
||||
# Thin wrapper — see lib/guest/conformance.sh and lib/common-lisp/conformance.conf.
|
||||
exec bash "$(dirname "$0")/../guest/conformance.sh" "$(dirname "$0")/conformance.conf" "$@"
|
||||
# lib/common-lisp/conformance.sh — CL-on-SX conformance test runner
|
||||
#
|
||||
# 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",
|
||||
"total_pass": 487,
|
||||
"generated": "2026-05-06T22:55:42Z",
|
||||
"total_pass": 518,
|
||||
"total_fail": 0,
|
||||
"suites": [
|
||||
{"name": "read", "pass": 79, "fail": 0},
|
||||
{"name": "lambda", "pass": 31, "fail": 0},
|
||||
{"name": "eval", "pass": 182, "fail": 0},
|
||||
{"name": "conditions", "pass": 59, "fail": 0},
|
||||
{"name": "restart-demo", "pass": 7, "fail": 0},
|
||||
{"name": "parse-recover", "pass": 6, "fail": 0},
|
||||
{"name": "interactive-debugger", "pass": 7, "fail": 0},
|
||||
{"name": "clos", "pass": 35, "fail": 0},
|
||||
{"name": "geometry", "pass": 0, "fail": 0},
|
||||
{"name": "mop-trace", "pass": 0, "fail": 0},
|
||||
{"name": "macros", "pass": 27, "fail": 0},
|
||||
{"name": "stdlib", "pass": 54, "fail": 0}
|
||||
{"name": "Phase 1: tokenizer/reader", "pass": 79, "fail": 0},
|
||||
{"name": "Phase 1: parser/lambda-lists", "pass": 31, "fail": 0},
|
||||
{"name": "Phase 2: evaluator", "pass": 182, "fail": 0},
|
||||
{"name": "Phase 3: condition system", "pass": 59, "fail": 0},
|
||||
{"name": "Phase 3: restart-demo", "pass": 7, "fail": 0},
|
||||
{"name": "Phase 3: parse-recover", "pass": 6, "fail": 0},
|
||||
{"name": "Phase 3: interactive-debugger", "pass": 7, "fail": 0},
|
||||
{"name": "Phase 4: CLOS", "pass": 41, "fail": 0},
|
||||
{"name": "Phase 4: geometry", "pass": 12, "fail": 0},
|
||||
{"name": "Phase 4: mop-trace", "pass": 13, "fail": 0},
|
||||
{"name": "Phase 5: macros+LOOP", "pass": 27, "fail": 0},
|
||||
{"name": "Phase 6: stdlib", "pass": 54, "fail": 0}
|
||||
]
|
||||
}
|
||||
|
||||
@@ -1,20 +1,20 @@
|
||||
# Common Lisp on SX — Scoreboard
|
||||
|
||||
_Generated: 2026-06-07 09:35 UTC_
|
||||
_Generated: 2026-05-06 22:55 UTC_
|
||||
|
||||
| Suite | Pass | Fail | Status |
|
||||
|-------|------|------|--------|
|
||||
| read | 79 | 0 | pass |
|
||||
| lambda | 31 | 0 | pass |
|
||||
| eval | 182 | 0 | pass |
|
||||
| conditions | 59 | 0 | pass |
|
||||
| restart-demo | 7 | 0 | pass |
|
||||
| parse-recover | 6 | 0 | pass |
|
||||
| interactive-debugger | 7 | 0 | pass |
|
||||
| clos | 35 | 0 | pass |
|
||||
| geometry | 0 | 0 | FAIL |
|
||||
| mop-trace | 0 | 0 | FAIL |
|
||||
| macros | 27 | 0 | pass |
|
||||
| stdlib | 54 | 0 | pass |
|
||||
| Phase 1: tokenizer/reader | 79 | 0 | pass |
|
||||
| Phase 1: parser/lambda-lists | 31 | 0 | pass |
|
||||
| Phase 2: evaluator | 182 | 0 | pass |
|
||||
| Phase 3: condition system | 59 | 0 | pass |
|
||||
| Phase 3: restart-demo | 7 | 0 | pass |
|
||||
| Phase 3: parse-recover | 6 | 0 | pass |
|
||||
| Phase 3: interactive-debugger | 7 | 0 | pass |
|
||||
| Phase 4: CLOS | 41 | 0 | pass |
|
||||
| Phase 4: geometry | 12 | 0 | pass |
|
||||
| Phase 4: mop-trace | 13 | 0 | pass |
|
||||
| Phase 5: macros+LOOP | 27 | 0 | pass |
|
||||
| Phase 6: stdlib | 54 | 0 | pass |
|
||||
|
||||
**Total: 487 passed, 0 failed**
|
||||
**Total: 518 passed, 0 failed**
|
||||
|
||||
@@ -25,8 +25,13 @@
|
||||
(define content/append doc-append)
|
||||
(define content/blocks doc-blocks)
|
||||
(define content/count doc-count)
|
||||
(define content/find doc-find)
|
||||
(define content/has? doc-has?)
|
||||
;; find / has? are TREE-WIDE by id (descend into sections) — so the facade reads
|
||||
;; back any block content/edit can update or delete. content/find-top / has-top?
|
||||
;; keep the top-level-only lookup for callers that mean the ordered sequence.
|
||||
(define content/find doc-find-deep)
|
||||
(define content/has? doc-has-deep?)
|
||||
(define content/find-top doc-find)
|
||||
(define content/has-top? doc-has?)
|
||||
(define content/ids doc-ids)
|
||||
(define content/types doc-types)
|
||||
|
||||
|
||||
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
|
||||
|
||||
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_MD="lib/content/scoreboard.md"
|
||||
@@ -48,6 +48,7 @@ run_suite() {
|
||||
(load "lib/content/compose.sx")
|
||||
(load "lib/content/tree-edit.sx")
|
||||
(load "lib/content/move.sx")
|
||||
(load "lib/content/block-path.sx")
|
||||
(load "lib/content/clone.sx")
|
||||
(load "lib/content/query.sx")
|
||||
(load "lib/content/toc.sx")
|
||||
@@ -68,7 +69,9 @@ run_suite() {
|
||||
(load "lib/content/page.sx")
|
||||
(load "lib/content/page-full.sx")
|
||||
(load "lib/content/markdown.sx")
|
||||
(load "lib/content/runs.sx")
|
||||
(load "lib/content/validate.sx")
|
||||
(load "lib/content/sanitize.sx")
|
||||
(load "lib/content/store.sx")
|
||||
(load "lib/content/snapshot.sx")
|
||||
(load "lib/content/crdt.sx")
|
||||
|
||||
@@ -5,14 +5,19 @@
|
||||
;; and returns a NEW document — the input is never mutated, so any version is the
|
||||
;; head of an op stream (replay-friendly for persist + CRDT merge).
|
||||
;;
|
||||
;; CtDoc also carries optional metadata (title/slug/tags) — see meta.sx for the
|
||||
;; ergonomic API; they default nil and do not affect block operations.
|
||||
;; By-id ops (update/delete) and by-id lookup (doc-find-deep/doc-has-deep?) are
|
||||
;; TREE-WIDE: they descend into any block carrying a `children` list (i.e.
|
||||
;; sections), since ids are unique across the tree. This keeps the persist
|
||||
;; op-log, content/edit and content/find correct for nested documents.
|
||||
;; insert/move are positional and act at the top level.
|
||||
;;
|
||||
;; CtDoc also carries optional metadata (title/slug/tags) — see meta.sx.
|
||||
;;
|
||||
;; Op shapes (data, not objects — they are the persist event payload):
|
||||
;; {:op "insert" :block <blk> :after <id|nil>} ; after nil = prepend
|
||||
;; {:op "update" :id <id> :field <name> :value <v>}
|
||||
;; {:op "move" :id <id> :index <n>}
|
||||
;; {:op "delete" :id <id>}
|
||||
;; {:op "insert" :block <blk> :after <id|nil>} ; after nil = prepend (top level)
|
||||
;; {:op "update" :id <id> :field <name> :value <v>} ; tree-wide by id
|
||||
;; {:op "move" :id <id> :index <n>} ; top level
|
||||
;; {:op "delete" :id <id>} ; tree-wide by id
|
||||
|
||||
(define
|
||||
content-bootstrap-doc!
|
||||
@@ -76,17 +81,58 @@
|
||||
(first blocks)
|
||||
(ct-insert-at (rest blocks) (- i 1) x))))))
|
||||
|
||||
;; tree-wide remove by id: drop matches at this level, recurse into children
|
||||
;; (blocks carrying a `children` list, i.e. sections).
|
||||
(define
|
||||
ct-remove-id
|
||||
(fn
|
||||
(blocks id)
|
||||
(filter (fn (b) (if (= (blk-id b) id) false true)) blocks)))
|
||||
(map
|
||||
(fn
|
||||
(b)
|
||||
(let
|
||||
((ch (st-iv-get b "children")))
|
||||
(if (list? ch) (st-iv-set! b "children" (ct-remove-id ch id)) b)))
|
||||
(filter (fn (b) (if (= (blk-id b) id) false true)) blocks))))
|
||||
|
||||
;; tree-wide replace by id: apply f to the match wherever it sits in the tree.
|
||||
(define
|
||||
ct-replace-id
|
||||
(fn
|
||||
(blocks id f)
|
||||
(map (fn (b) (if (= (blk-id b) id) (f b) b)) blocks)))
|
||||
(map
|
||||
(fn
|
||||
(b)
|
||||
(if
|
||||
(= (blk-id b) id)
|
||||
(f b)
|
||||
(let
|
||||
((ch (st-iv-get b "children")))
|
||||
(if
|
||||
(list? ch)
|
||||
(st-iv-set! b "children" (ct-replace-id ch id f))
|
||||
b))))
|
||||
blocks)))
|
||||
|
||||
;; tree-wide find by id: first block matching id anywhere in the tree, or nil.
|
||||
;; Descends into any `children` list, mirroring ct-replace-id/ct-remove-id.
|
||||
(define
|
||||
ct-find-id
|
||||
(fn
|
||||
(blocks id)
|
||||
(if
|
||||
(= (len blocks) 0)
|
||||
nil
|
||||
(let
|
||||
((b (first blocks)))
|
||||
(if
|
||||
(= (blk-id b) id)
|
||||
b
|
||||
(let
|
||||
((ch (st-iv-get b "children")))
|
||||
(let
|
||||
((nested (if (list? ch) (ct-find-id ch id) nil)))
|
||||
(if (= nested nil) (ct-find-id (rest blocks) id) nested))))))))
|
||||
|
||||
;; ── query ──
|
||||
(define doc-index-of (fn (doc id) (ct-index-of (doc-blocks doc) id)))
|
||||
@@ -103,6 +149,14 @@
|
||||
doc-has?
|
||||
(fn (doc id) (if (= (doc-index-of doc id) -1) false true)))
|
||||
|
||||
;; tree-wide lookup by id — reads a nested block by the same id content/edit can
|
||||
;; update/delete (no section.sx dependency; uses the generic children descent).
|
||||
(define doc-find-deep (fn (doc id) (ct-find-id (doc-blocks doc) id)))
|
||||
|
||||
(define
|
||||
doc-has-deep?
|
||||
(fn (doc id) (if (= (doc-find-deep doc id) nil) false true)))
|
||||
|
||||
;; ── structural edits (each returns a new document) ──
|
||||
(define doc-with-blocks (fn (doc blocks) (st-iv-set! doc "blocks" blocks)))
|
||||
|
||||
|
||||
@@ -1,10 +1,22 @@
|
||||
;; content-on-sx — global find/replace across text-bearing blocks.
|
||||
;; content-on-sx — global find/replace across every text-bearing field.
|
||||
;;
|
||||
;; Replaces every occurrence of `from` with `to` in the text field of text /
|
||||
;; heading / code / quote blocks, tree-wide (via the transform layer). For
|
||||
;; renaming a term throughout a document. Immutable; case-sensitive.
|
||||
;; Replaces every occurrence of `from` with `to` in the text-bearing fields of
|
||||
;; a document, tree-wide (via the transform layer):
|
||||
;; - the `text` of text / heading / code / quote / callout blocks
|
||||
;; - the `alt` of image blocks
|
||||
;; - each item of list blocks
|
||||
;; - every header and cell of table blocks
|
||||
;; This is exactly the set asText / stats / summary draw prose from, so a rename
|
||||
;; via content/find-replace and a word count over asText stay consistent.
|
||||
;; Immutable; case-sensitive.
|
||||
;;
|
||||
;; Requires (loaded by harness): block.sx, transform.sx (content/map-blocks).
|
||||
;; 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),
|
||||
;; table.sx (CtTable ivars).
|
||||
|
||||
(define
|
||||
fr-in?
|
||||
@@ -15,17 +27,71 @@
|
||||
((= (first xs) x) true)
|
||||
(else (fr-in? x (rest xs))))))
|
||||
|
||||
(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).
|
||||
(define
|
||||
fr-has-text?
|
||||
(fn (b) (fr-in? (blk-type b) (list "text" "heading" "code" "quote"))))
|
||||
(fn
|
||||
(b)
|
||||
(fr-in?
|
||||
(blk-type b)
|
||||
(list "text" "heading" "code" "quote" "callout" "image" "list" "table"))))
|
||||
|
||||
;; Per-type field rewrite. Each branch returns a new (copy-on-write) block.
|
||||
(define
|
||||
fr-rewrite
|
||||
(fn
|
||||
(b from to)
|
||||
(let
|
||||
((t (blk-type b)))
|
||||
(cond
|
||||
((= t "image")
|
||||
(blk-set b "alt" (fr-rep (blk-get b "alt") from to)))
|
||||
((= t "list")
|
||||
(let
|
||||
((items (blk-get b "items")))
|
||||
(if
|
||||
(list? items)
|
||||
(blk-set b "items" (map (fn (it) (fr-rep it from to)) items))
|
||||
b)))
|
||||
((= t "table")
|
||||
(let
|
||||
((hs (blk-get b "headers")) (rs (blk-get b "rows")))
|
||||
(let
|
||||
((b1 (if (list? hs) (blk-set b "headers" (map (fn (h) (fr-rep h from to)) hs)) b)))
|
||||
(if
|
||||
(list? rs)
|
||||
(blk-set
|
||||
b1
|
||||
"rows"
|
||||
(map
|
||||
(fn
|
||||
(r)
|
||||
(if (list? r) (map (fn (c) (fr-rep c from to)) r) r))
|
||||
rs))
|
||||
b1))))
|
||||
(else (blk-set b "text" (fr-rep-text (blk-get b "text") from to)))))))
|
||||
|
||||
(define
|
||||
content/find-replace
|
||||
(fn
|
||||
(doc from to)
|
||||
(content/map-blocks
|
||||
doc
|
||||
fr-has-text?
|
||||
(fn
|
||||
(b)
|
||||
(blk-set b "text" (replace (str (blk-get b "text")) from to))))))
|
||||
(content/map-blocks doc fr-has-text? (fn (b) (fr-rewrite b from to)))))
|
||||
|
||||
@@ -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
|
||||
;; ergonomic than the index-based doc-move. No-op if either id is missing.
|
||||
;; Immutable; composes the doc.sx list helpers.
|
||||
;; Relative reorder of top-level blocks (move-before/after/to-front/to-back by
|
||||
;; id) plus TREE reparenting: move a block into a section (content/move-into) or
|
||||
;; 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.
|
||||
|
||||
@@ -67,3 +72,57 @@
|
||||
(doc-with-blocks
|
||||
doc
|
||||
(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)))))))
|
||||
|
||||
@@ -1,10 +1,10 @@
|
||||
;; content-on-sx — block query + table of contents.
|
||||
;;
|
||||
;; Collect blocks across the whole tree (descending into sections) by predicate
|
||||
;; or type, and derive a table of contents from headings. Tree detection is
|
||||
;; inline (class + st-iv-get) so this needs no section.sx.
|
||||
;; or type, search them by prose, and derive a table of contents from headings.
|
||||
;; Tree detection is inline (class + st-iv-get) so this needs no section.sx.
|
||||
;;
|
||||
;; Requires (loaded by harness): block.sx, doc.sx.
|
||||
;; Requires (loaded by harness): block.sx, doc.sx, text.sx (asText for search).
|
||||
|
||||
(define
|
||||
qry-section?
|
||||
@@ -45,6 +45,30 @@
|
||||
content/select-ids
|
||||
(fn (doc pred) (map (fn (b) (blk-id b)) (content/select doc pred))))
|
||||
|
||||
;; Blocks (tree-wide, excluding section containers) whose own prose contains
|
||||
;; `term`. "Prose" is (asText b), so search covers exactly what every block
|
||||
;; exposes as text — text/heading/code/quote/callout text, image alt, list
|
||||
;; items, table headers+cells — with no separate field list to drift from
|
||||
;; asText / find-replace / stats. Case-sensitive substring match.
|
||||
(define
|
||||
content/search-text
|
||||
(fn
|
||||
(doc term)
|
||||
(content/select
|
||||
doc
|
||||
(fn
|
||||
(b)
|
||||
(and
|
||||
(not (qry-section? b))
|
||||
(>= (index-of (asText b) term) 0))))))
|
||||
|
||||
;; Same search, returning matching block ids in document order.
|
||||
(define
|
||||
content/search-text-ids
|
||||
(fn
|
||||
(doc term)
|
||||
(map (fn (b) (blk-id b)) (content/search-text doc term))))
|
||||
|
||||
;; table of contents: {:id :level :text} for every heading, in document order.
|
||||
(define
|
||||
content/headings
|
||||
|
||||
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)))))
|
||||
@@ -3,25 +3,27 @@
|
||||
"block": {"pass": 38, "fail": 0},
|
||||
"doc": {"pass": 40, "fail": 0},
|
||||
"render": {"pass": 42, "fail": 0},
|
||||
"api": {"pass": 26, "fail": 0},
|
||||
"api": {"pass": 32, "fail": 0},
|
||||
"meta": {"pass": 27, "fail": 0},
|
||||
"page": {"pass": 7, "fail": 0},
|
||||
"page-full": {"pass": 4, "fail": 0},
|
||||
"markdown": {"pass": 20, "fail": 0},
|
||||
"runs": {"pass": 36, "fail": 0},
|
||||
"text": {"pass": 20, "fail": 0},
|
||||
"section": {"pass": 25, "fail": 0},
|
||||
"compose": {"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},
|
||||
"query": {"pass": 13, "fail": 0},
|
||||
"query": {"pass": 20, "fail": 0},
|
||||
"toc": {"pass": 8, "fail": 0},
|
||||
"anchor": {"pass": 6, "fail": 0},
|
||||
"outline": {"pass": 14, "fail": 0},
|
||||
"flatten": {"pass": 10, "fail": 0},
|
||||
"transform": {"pass": 12, "fail": 0},
|
||||
"normalize": {"pass": 11, "fail": 0},
|
||||
"find-replace": {"pass": 10, "fail": 0},
|
||||
"find-replace": {"pass": 16, "fail": 0},
|
||||
"stats": {"pass": 17, "fail": 0},
|
||||
"summary": {"pass": 14, "fail": 0},
|
||||
"index": {"pass": 13, "fail": 0},
|
||||
@@ -30,8 +32,9 @@
|
||||
"media": {"pass": 15, "fail": 0},
|
||||
"data": {"pass": 25, "fail": 0},
|
||||
"wire": {"pass": 11, "fail": 0},
|
||||
"validate": {"pass": 23, "fail": 0},
|
||||
"store": {"pass": 33, "fail": 0},
|
||||
"validate": {"pass": 32, "fail": 0},
|
||||
"sanitize": {"pass": 12, "fail": 0},
|
||||
"store": {"pass": 46, "fail": 0},
|
||||
"snapshot": {"pass": 20, "fail": 0},
|
||||
"crdt": {"pass": 34, "fail": 0},
|
||||
"crdt-tree": {"pass": 21, "fail": 0},
|
||||
@@ -42,7 +45,7 @@
|
||||
"md-doc": {"pass": 12, "fail": 0},
|
||||
"fed": {"pass": 20, "fail": 0}
|
||||
},
|
||||
"total_pass": 746,
|
||||
"total_pass": 861,
|
||||
"total_fail": 0,
|
||||
"total": 746
|
||||
"total": 861
|
||||
}
|
||||
|
||||
@@ -7,25 +7,27 @@ _Generated by `lib/content/conformance.sh`_
|
||||
| block | 38 | 0 | 38 |
|
||||
| doc | 40 | 0 | 40 |
|
||||
| render | 42 | 0 | 42 |
|
||||
| api | 26 | 0 | 26 |
|
||||
| api | 32 | 0 | 32 |
|
||||
| meta | 27 | 0 | 27 |
|
||||
| page | 7 | 0 | 7 |
|
||||
| page-full | 4 | 0 | 4 |
|
||||
| markdown | 20 | 0 | 20 |
|
||||
| runs | 36 | 0 | 36 |
|
||||
| text | 20 | 0 | 20 |
|
||||
| section | 25 | 0 | 25 |
|
||||
| compose | 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 |
|
||||
| query | 13 | 0 | 13 |
|
||||
| query | 20 | 0 | 20 |
|
||||
| toc | 8 | 0 | 8 |
|
||||
| anchor | 6 | 0 | 6 |
|
||||
| outline | 14 | 0 | 14 |
|
||||
| flatten | 10 | 0 | 10 |
|
||||
| transform | 12 | 0 | 12 |
|
||||
| normalize | 11 | 0 | 11 |
|
||||
| find-replace | 10 | 0 | 10 |
|
||||
| find-replace | 16 | 0 | 16 |
|
||||
| stats | 17 | 0 | 17 |
|
||||
| summary | 14 | 0 | 14 |
|
||||
| index | 13 | 0 | 13 |
|
||||
@@ -34,8 +36,9 @@ _Generated by `lib/content/conformance.sh`_
|
||||
| media | 15 | 0 | 15 |
|
||||
| data | 25 | 0 | 25 |
|
||||
| wire | 11 | 0 | 11 |
|
||||
| validate | 23 | 0 | 23 |
|
||||
| store | 33 | 0 | 33 |
|
||||
| validate | 32 | 0 | 32 |
|
||||
| sanitize | 12 | 0 | 12 |
|
||||
| store | 46 | 0 | 46 |
|
||||
| snapshot | 20 | 0 | 20 |
|
||||
| crdt | 34 | 0 | 34 |
|
||||
| crdt-tree | 21 | 0 | 21 |
|
||||
@@ -45,4 +48,4 @@ _Generated by `lib/content/conformance.sh`_
|
||||
| md-import | 38 | 0 | 38 |
|
||||
| md-doc | 12 | 0 | 12 |
|
||||
| fed | 20 | 0 | 20 |
|
||||
| **Total** | **746** | **0** | **746** |
|
||||
| **Total** | **861** | **0** | **861** |
|
||||
|
||||
@@ -5,9 +5,10 @@
|
||||
;; replay of its op stream up to a sequence number; the materialised doc is a
|
||||
;; cache, never primary state.
|
||||
;;
|
||||
;; Requires (loaded by the harness): block.sx, doc.sx, and persist
|
||||
;; (event/backend/log/kv/api). The persist backend `b` is opened by the caller
|
||||
;; via (persist/open) and injected — content knows nothing about which backend.
|
||||
;; Requires (loaded by the harness): block.sx, doc.sx, section.sx (doc-deep-find
|
||||
;; + doc-tree-ids, for the tree-wide diff), plus persist (event/backend/log/kv/
|
||||
;; api). The persist backend `b` is opened by the caller via (persist/open) and
|
||||
;; injected — content knows nothing about which backend.
|
||||
|
||||
(define content/-stream (fn (doc-id) (str "content:" doc-id)))
|
||||
|
||||
@@ -69,11 +70,18 @@
|
||||
(fn (b doc-id) (map (fn (ev) {:type (persist/event-type ev) :at (persist/event-at ev) :seq (persist/event-seq ev)}) (content/log b doc-id))))
|
||||
|
||||
;; ── diff between two materialised document versions ──
|
||||
;; Returns {:added (ids) :removed (ids) :changed (ids)} where changed = ids
|
||||
;; present in both whose block content differs.
|
||||
(define
|
||||
content/-missing?
|
||||
(fn (doc id) (= (ct-index-of (doc-blocks doc) id) -1)))
|
||||
;; Tree-wide: ids are enumerated across the whole block tree (descending into
|
||||
;; sections), so nested-block adds/removes/changes are detected, not just
|
||||
;; top-level ones. Returns {:added :removed :changed} (lists of ids):
|
||||
;; :added — ids present (anywhere) in `new` but not in `old`
|
||||
;; :removed — ids present (anywhere) in `old` but not in `new`
|
||||
;; :changed — content blocks present in both whose block value differs
|
||||
;; Section containers never appear in :changed (they hold no own content — a
|
||||
;; child change surfaces as that child's own entry); a whole section appearing
|
||||
;; or disappearing shows up in :added / :removed by its id.
|
||||
(define content/-all-ids (fn (doc) (doc-tree-ids doc)))
|
||||
|
||||
(define content/-missing? (fn (doc id) (= (doc-deep-find doc id) nil)))
|
||||
|
||||
(define
|
||||
content/-changed
|
||||
@@ -83,15 +91,16 @@
|
||||
(fn
|
||||
(id)
|
||||
(let
|
||||
((bo (doc-find old id)) (bn (doc-find new id)))
|
||||
((bo (doc-deep-find old id)) (bn (doc-deep-find new id)))
|
||||
(cond
|
||||
((= bo nil) false)
|
||||
((= bn nil) false)
|
||||
((= (blk-type bo) "section") false)
|
||||
((= bo bn) false)
|
||||
(else true))))
|
||||
(doc-ids old))))
|
||||
(content/-all-ids old))))
|
||||
|
||||
(define content/diff (fn (old new) {:changed (content/-changed old new) :removed (filter (fn (id) (content/-missing? new id)) (doc-ids old)) :added (filter (fn (id) (content/-missing? old id)) (doc-ids new))}))
|
||||
(define content/diff (fn (old new) {:changed (content/-changed old new) :removed (filter (fn (id) (content/-missing? new id)) (content/-all-ids old)) :added (filter (fn (id) (content/-missing? old id)) (content/-all-ids new))}))
|
||||
|
||||
;; convenience: diff two persisted versions by seq.
|
||||
(define
|
||||
|
||||
@@ -97,3 +97,37 @@
|
||||
"render original unchanged"
|
||||
(content/render d1 "html")
|
||||
"<h1>Hi</h1><p>World</p>")
|
||||
|
||||
;; ── facade find/has? are TREE-WIDE (reach into sections); find-top/has-top?
|
||||
;; keep the top-level-only lookup. This makes the read-by-id surface consistent
|
||||
;; with content/edit, whose update/delete are already tree-wide. ──
|
||||
(content-bootstrap-section!)
|
||||
(define
|
||||
nd
|
||||
(content/append
|
||||
(content/empty "nested")
|
||||
(mk-section
|
||||
"sec"
|
||||
(list (content/block "text" "inner" (list (list "text" "deep")))))))
|
||||
(content-test
|
||||
"find nested (deep)"
|
||||
(blk-id (content/find nd "inner"))
|
||||
"inner")
|
||||
(content-test "has? nested (deep)" (content/has? nd "inner") true)
|
||||
(content-test "find-top misses nested" (content/find-top nd "inner") nil)
|
||||
(content-test "has-top? misses nested" (content/has-top? nd "inner") false)
|
||||
(content-test
|
||||
"find-top sees top-level"
|
||||
(blk-id (content/find-top nd "sec"))
|
||||
"sec")
|
||||
;; a nested block updated by id via content/edit is now readable by id via
|
||||
;; content/find (was impossible when find was top-level-only).
|
||||
(content-test
|
||||
"edit-then-find nested round-trip"
|
||||
(str
|
||||
(blk-send
|
||||
(content/find
|
||||
(content/edit nd (content/update "inner" "text" "edited"))
|
||||
"inner")
|
||||
"text"))
|
||||
"edited")
|
||||
|
||||
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,8 +1,10 @@
|
||||
;; Extension — global find/replace across text-bearing blocks.
|
||||
;; Extension — global find/replace across every text-bearing field.
|
||||
|
||||
(st-bootstrap-classes!)
|
||||
(content/bootstrap!)
|
||||
(content-bootstrap-section!)
|
||||
(content-bootstrap-callout!)
|
||||
(content-bootstrap-table!)
|
||||
|
||||
(define
|
||||
d
|
||||
@@ -30,11 +32,12 @@
|
||||
(str (blk-send (doc-deep-find r "n") "text"))
|
||||
"nested Bar")
|
||||
|
||||
;; ── does NOT touch image alt/src (not a text field) ──
|
||||
;; ── image alt IS a text field (asText ^ alt), so it is rewritten ──
|
||||
(content-test
|
||||
"image alt untouched"
|
||||
"image alt replaced"
|
||||
(str (blk-send (doc-deep-find r "img") "alt"))
|
||||
"Foo alt")
|
||||
"Bar alt")
|
||||
;; ── but src is a URL, not prose, so it stays put ──
|
||||
(content-test
|
||||
"image src untouched"
|
||||
(str (blk-send (doc-deep-find r "img") "src"))
|
||||
@@ -76,6 +79,68 @@
|
||||
(str (blk-send (doc-find r2 "q") "text"))
|
||||
"new saying")
|
||||
|
||||
;; ── callout text is covered (consistency with asText/stats/summary) ──
|
||||
(content-test
|
||||
"replace callout text"
|
||||
(str
|
||||
(blk-send
|
||||
(doc-find
|
||||
(content/find-replace
|
||||
(doc-append (doc-empty "d") (mk-callout "co" "note" "Foo here"))
|
||||
"Foo"
|
||||
"Bar")
|
||||
"co")
|
||||
"text"))
|
||||
"Bar here")
|
||||
(content-test
|
||||
"callout kind untouched by text replace"
|
||||
(str
|
||||
(blk-send
|
||||
(doc-find
|
||||
(content/find-replace
|
||||
(doc-append (doc-empty "d") (mk-callout "co" "note" "x"))
|
||||
"note"
|
||||
"X")
|
||||
"co")
|
||||
"kind"))
|
||||
"note")
|
||||
|
||||
;; ── list items are rewritten (asText folds items) ──
|
||||
(define
|
||||
rl
|
||||
(content/find-replace
|
||||
(doc-append
|
||||
(doc-empty "d")
|
||||
(mk-list "l" false (list "Foo one" "two Foo")))
|
||||
"Foo"
|
||||
"Bar"))
|
||||
(content-test
|
||||
"replace first list item"
|
||||
(str (first (blk-send (doc-find rl "l") "items")))
|
||||
"Bar one")
|
||||
(content-test
|
||||
"replace second list item"
|
||||
(str (first (rest (blk-send (doc-find rl "l") "items"))))
|
||||
"two Bar")
|
||||
|
||||
;; ── table headers + cells are rewritten (asText folds rows) ──
|
||||
(define
|
||||
rt
|
||||
(content/find-replace
|
||||
(doc-append
|
||||
(doc-empty "d")
|
||||
(mk-table "t" (list "Foo head") (list (list "a Foo" "b"))))
|
||||
"Foo"
|
||||
"Bar"))
|
||||
(content-test
|
||||
"replace table header"
|
||||
(str (first (table-headers (doc-find rt "t"))))
|
||||
"Bar head")
|
||||
(content-test
|
||||
"replace table cell"
|
||||
(str (first (first (table-rows (doc-find rt "t")))))
|
||||
"a Bar")
|
||||
|
||||
;; ── no match → unchanged render ──
|
||||
(content-test
|
||||
"no match"
|
||||
|
||||
@@ -1,7 +1,8 @@
|
||||
;; Extension — relative block reorder.
|
||||
;; Extension — relative block reorder + tree reparent.
|
||||
|
||||
(st-bootstrap-classes!)
|
||||
(content/bootstrap!)
|
||||
(content-bootstrap-section!)
|
||||
|
||||
(define
|
||||
d
|
||||
@@ -61,3 +62,84 @@
|
||||
"render after move"
|
||||
(asHTML (content/move-after d "a" "c"))
|
||||
"<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"))
|
||||
|
||||
@@ -1,8 +1,11 @@
|
||||
;; Extension — block query + table of contents.
|
||||
;; Extension — block query + table of contents + prose search.
|
||||
|
||||
(st-bootstrap-classes!)
|
||||
(content/bootstrap!)
|
||||
(content-bootstrap-text!)
|
||||
(content-bootstrap-section!)
|
||||
(content-bootstrap-table!)
|
||||
(content-bootstrap-callout!)
|
||||
|
||||
(define
|
||||
d
|
||||
@@ -87,3 +90,49 @@
|
||||
"deep toc level"
|
||||
(get (first (content/headings deep)) :level)
|
||||
3)
|
||||
|
||||
;; ── prose search (content/search-text) ──
|
||||
;; "cat" appears in text, image alt, a list item, a table cell, and a callout
|
||||
;; — every text-bearing field — so search must find all five via asText.
|
||||
(define
|
||||
sd
|
||||
(doc-append
|
||||
(doc-append
|
||||
(doc-append
|
||||
(doc-append
|
||||
(doc-append
|
||||
(doc-empty "sd")
|
||||
(mk-heading "sh" 1 "Welcome aboard"))
|
||||
(mk-text "st" "the cat sat"))
|
||||
(mk-image "si" "/x.png" "a cat photo"))
|
||||
(mk-list "sl" false (list "first cat" "second dog")))
|
||||
(mk-section
|
||||
"sec"
|
||||
(list
|
||||
(mk-table "stb" (list "Animal") (list (list "cat") (list "fish")))
|
||||
(mk-callout "sc" "note" "beware of cat")))))
|
||||
|
||||
(content-test
|
||||
"search across every text-bearing field"
|
||||
(content/search-text-ids sd "cat")
|
||||
(list "st" "si" "sl" "stb" "sc"))
|
||||
(content-test "search count" (len (content/search-text sd "cat")) 5)
|
||||
(content-test
|
||||
"search heading text"
|
||||
(content/search-text-ids sd "Welcome")
|
||||
(list "sh"))
|
||||
(content-test
|
||||
"search list item only"
|
||||
(content/search-text-ids sd "dog")
|
||||
(list "sl"))
|
||||
(content-test "search no match" (content/search-text-ids sd "zzz") (list))
|
||||
;; section containers are excluded — a term living only inside a section's
|
||||
;; children returns the child, never the section wrapper.
|
||||
(content-test
|
||||
"search excludes section wrapper"
|
||||
(content/search-text-ids sd "fish")
|
||||
(list "stb"))
|
||||
(content-test
|
||||
"search returns block objects"
|
||||
(blk-id (first (content/search-text sd "Welcome")))
|
||||
"sh")
|
||||
|
||||
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))
|
||||
@@ -151,3 +151,58 @@
|
||||
"op-log media type"
|
||||
(blk-type (doc-find (content/head B3 "rich") "v"))
|
||||
"media")
|
||||
|
||||
;; ── op-log update/delete reach NESTED blocks (tree-wide by id) ──
|
||||
(content-bootstrap-section!)
|
||||
(define B4 (persist/open))
|
||||
(content/commit!
|
||||
B4
|
||||
"nest"
|
||||
(op-insert (mk-section "sec" (list (mk-text "n" "orig"))) nil)
|
||||
1)
|
||||
(content/commit! B4 "nest" (op-update "n" "text" "edited") 2)
|
||||
(content-test
|
||||
"op-log nested update"
|
||||
(str (blk-send (doc-deep-find (content/head B4 "nest") "n") "text"))
|
||||
"edited")
|
||||
(content-test
|
||||
"op-log nested update tree intact"
|
||||
(doc-tree-ids (content/head B4 "nest"))
|
||||
(list "sec" "n"))
|
||||
(content/commit! B4 "nest" (op-delete "n") 3)
|
||||
(content-test
|
||||
"op-log nested delete"
|
||||
(doc-tree-ids (content/head B4 "nest"))
|
||||
(list "sec"))
|
||||
(content-test
|
||||
"op-log nested delete via content/at seq2"
|
||||
(doc-tree-ids (content/at B4 "nest" 2))
|
||||
(list "sec" "n"))
|
||||
|
||||
;; ── diff is TREE-WIDE: nested-block add/change/remove are detected, and
|
||||
;; section containers never appear in :changed (a top-level-only diff would miss
|
||||
;; "n" entirely and instead flag the section). ──
|
||||
(define dn01 (content/diff-versions B4 "nest" 0 1))
|
||||
(content-test
|
||||
"diff nested added (section + child)"
|
||||
(get dn01 :added)
|
||||
(list "sec" "n"))
|
||||
(content-test "diff nested added removed empty" (get dn01 :removed) (list))
|
||||
(content-test "diff nested added changed empty" (get dn01 :changed) (list))
|
||||
|
||||
(define dn12 (content/diff-versions B4 "nest" 1 2))
|
||||
(content-test
|
||||
"diff nested changed child only"
|
||||
(get dn12 :changed)
|
||||
(list "n"))
|
||||
(content-test "diff nested changed no add" (get dn12 :added) (list))
|
||||
(content-test "diff nested changed no remove" (get dn12 :removed) (list))
|
||||
|
||||
(define dn23 (content/diff-versions B4 "nest" 2 3))
|
||||
(content-test "diff nested removed child" (get dn23 :removed) (list "n"))
|
||||
(content-test "diff nested removed no change" (get dn23 :changed) (list))
|
||||
|
||||
(content-test
|
||||
"diff nested no-op"
|
||||
(get (content/diff-versions B4 "nest" 1 1) :changed)
|
||||
(list))
|
||||
|
||||
@@ -5,6 +5,7 @@
|
||||
(content-bootstrap-blocks!)
|
||||
(content-bootstrap-doc!)
|
||||
(content-bootstrap-section!)
|
||||
(content-bootstrap-table!)
|
||||
|
||||
;; ── a fully valid document ──
|
||||
(define
|
||||
@@ -164,3 +165,62 @@
|
||||
(content/validate dup-tree)))
|
||||
1)
|
||||
(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.
|
||||
;; 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.
|
||||
|
||||
(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))))
|
||||
|
||||
;; 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) ──
|
||||
(define
|
||||
ct-section-block?
|
||||
@@ -136,30 +163,43 @@
|
||||
"embed provider must be a string")))
|
||||
((= t "divider") (list))
|
||||
((= t "list")
|
||||
(append
|
||||
(ct-field-issue
|
||||
id
|
||||
(boolean? (blk-get b "ordered"))
|
||||
"list ordered must be a boolean")
|
||||
(ct-field-issue
|
||||
id
|
||||
(list? (blk-get b "items"))
|
||||
"list items must be a list")))
|
||||
(let
|
||||
((items (blk-get b "items")))
|
||||
(append
|
||||
(ct-field-issue
|
||||
id
|
||||
(boolean? (blk-get b "ordered"))
|
||||
"list ordered must be a boolean")
|
||||
(append
|
||||
(ct-field-issue id (list? items) "list items must be a list")
|
||||
(ct-field-issue
|
||||
id
|
||||
(if (list? items) (ct-all-str? items) true)
|
||||
"list items must all be strings")))))
|
||||
((= t "section")
|
||||
(ct-field-issue
|
||||
id
|
||||
(list? (blk-get b "children"))
|
||||
"section children must be a list"))
|
||||
((= t "table")
|
||||
(append
|
||||
(ct-field-issue
|
||||
id
|
||||
(list? (blk-get b "headers"))
|
||||
"table headers must be a list")
|
||||
(ct-field-issue
|
||||
id
|
||||
(list? (blk-get b "rows"))
|
||||
"table rows must be a list")))
|
||||
(let
|
||||
((headers (blk-get b "headers")) (rows (blk-get b "rows")))
|
||||
(append
|
||||
(append
|
||||
(ct-field-issue
|
||||
id
|
||||
(list? headers)
|
||||
"table headers must be a list")
|
||||
(ct-field-issue
|
||||
id
|
||||
(if (list? headers) (ct-all-str? headers) true)
|
||||
"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")
|
||||
(append
|
||||
(ct-field-issue
|
||||
|
||||
@@ -1,79 +0,0 @@
|
||||
# dream-on-sx
|
||||
|
||||
OCaml's [Dream](https://aantron.github.io/dream/) web framework, reimplemented in
|
||||
**plain SX** on the CEK evaluator. Dream is the cleanest middleware-shaped HTTP
|
||||
framework in any language, and it maps onto SX with almost no impedance:
|
||||
|
||||
| Dream | SX |
|
||||
|-------|-----|
|
||||
| `handler = request -> response promise` | `(fn (req) … (perform …))` |
|
||||
| `middleware = handler -> handler` | `(fn (next) (fn (req) …))` |
|
||||
| `m1 @@ m2 @@ handler` | `(m1 (m2 handler))` — left fold |
|
||||
| `Dream.run handler` | `(dream-run handler)` → `(perform (:http/listen …))` |
|
||||
|
||||
There are five types — **request, response, route**, and (as plain functions)
|
||||
**handler** and **middleware**. Everything else is a function over them.
|
||||
|
||||
## Quickstart
|
||||
|
||||
```lisp
|
||||
(dream-run
|
||||
(dream-make-app
|
||||
(list
|
||||
(dream-get "/" (fn (req) (dream-html "<h1>Hello, World!</h1>")))
|
||||
(dream-get "/hello/:name"
|
||||
(fn (req) (dream-text (str "Hi, " (dream-param req "name"))))))))
|
||||
```
|
||||
|
||||
`dream-make-app` wraps the router in the default stack (error catch + content-type).
|
||||
`dream-run` installs the root handler on the existing SX HTTP server — it does **not**
|
||||
open its own socket.
|
||||
|
||||
## Public surface
|
||||
|
||||
- **types** — `dream-request`/`dream-response`/`dream-route`, accessors
|
||||
(`dream-method`/`-path`/`-body`/`-header`/`-query-param`/`-param`), smart
|
||||
constructors (`dream-html`/`-text`/`-json`/`-empty`/`-not-found`/`-redirect`),
|
||||
convenience (`dream-queries`, `*-or` defaults, `dream-accepts?`/`dream-wants-json?`).
|
||||
- **router** — `dream-get`/`-post`/`-put`/`-delete`/`-patch`/`-head`/`-options`/`-any`,
|
||||
`dream-router`, `dream-scope` (prefix + middleware), `:name` params + `**` catch-all,
|
||||
405 + `Allow`, automatic HEAD.
|
||||
- **middleware** — `dream-pipeline`, `dream-no-middleware`, `dream-logger`,
|
||||
`dream-content-type`, `dream-set-header`, `dream-tap-request`.
|
||||
- **session** — `dream-sessions` / `dream-sessions-signed`, `dream-session-field` /
|
||||
`dream-set-session-field` / `dream-session-all` / `dream-invalidate-session`; cookie
|
||||
helpers (`dream-cookie`, `dream-set-cookie`, `dream-cookie-sign`/`-unsign`).
|
||||
- **flash** — `dream-flash`, `dream-add-flash-message`, `dream-flash-messages`.
|
||||
- **form** — `dream-form` (Ok/Err), `dream-form-fields`, `dream-multipart`, CSRF
|
||||
(`dream-csrf` / `dream-csrf-protect` / `dream-csrf-token` / `dream-csrf-tag`).
|
||||
- **websocket** — `dream-websocket`, `dream-send`/`-receive`/`-close`/`-broadcast`.
|
||||
- **static** — `dream-static` (mime, ETags, 304, ranges, traversal guard).
|
||||
- **error** — `dream-catch`, `dream-status-text`/`-line`, `dream-status-page`.
|
||||
- **cors** — `dream-cors`, `dream-cors-origin`, `dream-cors-with`.
|
||||
- **json** — `dream-json-encode`/`-parse`, `dream-json-value`, `dream-json-body`.
|
||||
- **run / api** — `dream-run`/`-port`/`-opts`, `dream-app`, `dream-make-app`,
|
||||
`dream-serve`.
|
||||
|
||||
## Testing story
|
||||
|
||||
Every effectful concern is **dependency-injected**, so the whole framework is testable
|
||||
without a running host:
|
||||
|
||||
- sessions take a backend `(fn (op) …)` — `dream-memory-sessions` for tests,
|
||||
`dream-perform-sessions` in production;
|
||||
- static files take an fs — `dream-memory-fs` vs `dream-static-perform-fs`;
|
||||
- websockets take an io — `dream-mock-ws` vs `dream-ws-perform-io`;
|
||||
- `dream-run` takes a listen transport (`dream-run-with`).
|
||||
|
||||
Run the suite: `bash lib/dream/conformance.sh` (367 tests, 14 suites).
|
||||
|
||||
## Notes & caveats
|
||||
|
||||
- Headers are dicts with **lowercased string keys** (in SX keywords *are* strings, so
|
||||
`:content-type` == `"content-type"`).
|
||||
- Outgoing cookies accumulate in a `:set-cookies` list on the response so multiple
|
||||
`Set-Cookie` headers don't collide.
|
||||
- The CSRF/cookie/ETag signing uses a pure-SX keyed hash — **not cryptographic**.
|
||||
Production should inject a host HMAC (`dream-csrf-with`, and the signed-session
|
||||
secret path).
|
||||
- JSON and multipart are in-memory (not streaming).
|
||||
@@ -1,33 +0,0 @@
|
||||
;; lib/dream/api.sx — Dream-on-SX public facade.
|
||||
;; Loaded last; bundles the modules into a batteries-included surface. The full
|
||||
;; public API is the `dream-*` functions across types/router/middleware/session/
|
||||
;; flash/form/websocket/static/error/cors/json/run; this file adds convenience
|
||||
;; app builders. Depends on all other dream modules.
|
||||
|
||||
(define dream-version "0.1.0")
|
||||
|
||||
;; standard middleware stack (pure — no IO): error catch outermost, then
|
||||
;; content-type sniffing. Logger is opt-in since it performs host IO.
|
||||
(define
|
||||
dream-defaults
|
||||
(fn
|
||||
(handler)
|
||||
(dream-pipeline (list dream-catch dream-content-type) handler)))
|
||||
|
||||
;; build a complete app handler from a route list with the default stack
|
||||
(define
|
||||
dream-make-app
|
||||
(fn (routes) (dream-defaults (dream-router routes))))
|
||||
|
||||
;; build an app and wrap it with extra middleware (outermost first)
|
||||
(define
|
||||
dream-make-app-with
|
||||
(fn
|
||||
(middlewares routes)
|
||||
(dream-pipeline middlewares (dream-make-app routes))))
|
||||
|
||||
;; one-call serve: routes + opts -> installed on the host
|
||||
(define
|
||||
dream-serve
|
||||
(fn (routes opts) (dream-run-opts (dream-make-app routes) opts)))
|
||||
(define dream-serve-port (fn (routes port) (dream-serve routes {:port port})))
|
||||
@@ -1,172 +0,0 @@
|
||||
;; lib/dream/auth.sx — Dream-on-SX authentication helpers.
|
||||
;; HTTP Basic auth (with a pure-SX base64 codec) and Bearer-token guards.
|
||||
;; Depends on types.sx.
|
||||
|
||||
;; ── base64 (pure SX; arithmetic, no bitwise) ───────────────────────
|
||||
(define
|
||||
dr/b64-alpha
|
||||
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
|
||||
(define dr/b64-char (fn (n) (char-at dr/b64-alpha n)))
|
||||
(define dr/b64-index (fn (c) (index-of dr/b64-alpha c)))
|
||||
|
||||
(define
|
||||
dr/b64-encode-loop
|
||||
(fn
|
||||
(s i n acc)
|
||||
(if
|
||||
(>= i n)
|
||||
acc
|
||||
(let
|
||||
((b0 (char-code (char-at s i))) (rem (- n i)))
|
||||
(cond
|
||||
((>= rem 3)
|
||||
(let
|
||||
((triple (+ (* b0 65536) (* (char-code (char-at s (+ i 1))) 256) (char-code (char-at s (+ i 2))))))
|
||||
(dr/b64-encode-loop
|
||||
s
|
||||
(+ i 3)
|
||||
n
|
||||
(str
|
||||
acc
|
||||
(dr/b64-char (mod (quotient triple 262144) 64))
|
||||
(dr/b64-char (mod (quotient triple 4096) 64))
|
||||
(dr/b64-char (mod (quotient triple 64) 64))
|
||||
(dr/b64-char (mod triple 64))))))
|
||||
((= rem 2)
|
||||
(let
|
||||
((triple (+ (* b0 65536) (* (char-code (char-at s (+ i 1))) 256))))
|
||||
(str
|
||||
acc
|
||||
(dr/b64-char (mod (quotient triple 262144) 64))
|
||||
(dr/b64-char (mod (quotient triple 4096) 64))
|
||||
(dr/b64-char (mod (quotient triple 64) 64))
|
||||
"=")))
|
||||
(else
|
||||
(let
|
||||
((triple (* b0 65536)))
|
||||
(str
|
||||
acc
|
||||
(dr/b64-char (mod (quotient triple 262144) 64))
|
||||
(dr/b64-char (mod (quotient triple 4096) 64))
|
||||
"=="))))))))
|
||||
|
||||
(define
|
||||
dream-base64-encode
|
||||
(fn (s) (dr/b64-encode-loop s 0 (string-length s) "")))
|
||||
|
||||
(define
|
||||
dr/b64-decode-loop
|
||||
(fn
|
||||
(s i n acc)
|
||||
(if
|
||||
(>= i n)
|
||||
acc
|
||||
(let
|
||||
((p2 (char-at s (+ i 2)))
|
||||
(p3 (char-at s (+ i 3))))
|
||||
(let
|
||||
((c0 (dr/b64-index (char-at s i)))
|
||||
(c1 (dr/b64-index (char-at s (+ i 1))))
|
||||
(c2 (if (= p2 "=") 0 (dr/b64-index p2)))
|
||||
(c3 (if (= p3 "=") 0 (dr/b64-index p3))))
|
||||
(let
|
||||
((triple (+ (* c0 262144) (* c1 4096) (* c2 64) c3)))
|
||||
(dr/b64-decode-loop
|
||||
s
|
||||
(+ i 4)
|
||||
n
|
||||
(str
|
||||
acc
|
||||
(char-from-code
|
||||
(mod (quotient triple 65536) 256))
|
||||
(if
|
||||
(= p2 "=")
|
||||
""
|
||||
(char-from-code
|
||||
(mod (quotient triple 256) 256)))
|
||||
(if (= p3 "=") "" (char-from-code (mod triple 256)))))))))))
|
||||
|
||||
(define
|
||||
dream-base64-decode
|
||||
(fn
|
||||
(s)
|
||||
(if (= s "") "" (dr/b64-decode-loop s 0 (string-length s) ""))))
|
||||
|
||||
;; ── Authorization header parsing ───────────────────────────────────
|
||||
(define dream-authorization (fn (req) (dream-header req "authorization")))
|
||||
|
||||
(define
|
||||
dream-bearer-token
|
||||
(fn
|
||||
(req)
|
||||
(let
|
||||
((a (dream-authorization req)))
|
||||
(if (and a (starts-with? a "Bearer ")) (substr a 7) nil))))
|
||||
|
||||
(define
|
||||
dream-basic-credentials
|
||||
(fn
|
||||
(req)
|
||||
(let
|
||||
((a (dream-authorization req)))
|
||||
(if
|
||||
(and a (starts-with? a "Basic "))
|
||||
(let
|
||||
((decoded (dream-base64-decode (substr a 6))))
|
||||
(let
|
||||
((colon (index-of decoded ":")))
|
||||
(if (< colon 0) nil {:pass (substr decoded (+ colon 1)) :user (substr decoded 0 colon)})))
|
||||
nil))))
|
||||
|
||||
;; ── Basic auth middleware ──────────────────────────────────────────
|
||||
;; check is (fn (user pass) -> bool). On success the request gains :dream-user.
|
||||
(define
|
||||
dr/www-authenticate
|
||||
(fn
|
||||
(realm)
|
||||
(dream-add-header
|
||||
(dream-response 401 {:content-type "text/plain; charset=utf-8"} "Unauthorized")
|
||||
"www-authenticate"
|
||||
(str "Basic realm=\"" realm "\""))))
|
||||
|
||||
(define
|
||||
dream-basic-auth
|
||||
(fn
|
||||
(realm check)
|
||||
(fn
|
||||
(next)
|
||||
(fn
|
||||
(req)
|
||||
(let
|
||||
((creds (dream-basic-credentials req)))
|
||||
(if
|
||||
(and creds (check (get creds :user) (get creds :pass)))
|
||||
(next (assoc req :dream-user (get creds :user)))
|
||||
(dr/www-authenticate realm)))))))
|
||||
|
||||
(define dream-user (fn (req) (get req :dream-user)))
|
||||
|
||||
;; ── Bearer-token middleware ────────────────────────────────────────
|
||||
;; check is (fn (token) -> principal | nil). On success the request gains
|
||||
;; :dream-principal. Missing/invalid -> 401.
|
||||
(define
|
||||
dream-require-bearer
|
||||
(fn
|
||||
(check)
|
||||
(fn
|
||||
(next)
|
||||
(fn
|
||||
(req)
|
||||
(let
|
||||
((tok (dream-bearer-token req)))
|
||||
(let
|
||||
((principal (if tok (check tok) nil)))
|
||||
(if
|
||||
(nil? principal)
|
||||
(dream-add-header
|
||||
(dream-response 401 {:content-type "text/plain; charset=utf-8"} "Unauthorized")
|
||||
"www-authenticate"
|
||||
"Bearer")
|
||||
(next (assoc req :dream-principal principal)))))))))
|
||||
|
||||
(define dream-principal (fn (req) (get req :dream-principal)))
|
||||
@@ -1,122 +0,0 @@
|
||||
#!/usr/bin/env bash
|
||||
# dream-on-sx conformance runner — loads all dream modules + test suites in one
|
||||
# sx_server process and reports pass/fail per suite.
|
||||
#
|
||||
# Usage:
|
||||
# bash lib/dream/conformance.sh # run all suites
|
||||
# bash lib/dream/conformance.sh -v # verbose (list each 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:-}"
|
||||
|
||||
# Dream library modules loaded before any test suite.
|
||||
MODULES=(
|
||||
"lib/dream/types.sx"
|
||||
"lib/dream/router.sx"
|
||||
"lib/dream/middleware.sx"
|
||||
"lib/dream/session.sx"
|
||||
"lib/dream/flash.sx"
|
||||
"lib/dream/form.sx"
|
||||
"lib/dream/websocket.sx"
|
||||
"lib/dream/static.sx"
|
||||
"lib/dream/error.sx"
|
||||
"lib/dream/cors.sx"
|
||||
"lib/dream/json.sx"
|
||||
"lib/dream/auth.sx"
|
||||
"lib/dream/html.sx"
|
||||
"lib/dream/headers.sx"
|
||||
"lib/dream/run.sx"
|
||||
"lib/dream/api.sx"
|
||||
"lib/dream/demos/hello.sx"
|
||||
"lib/dream/demos/counter.sx"
|
||||
"lib/dream/demos/chat.sx"
|
||||
"lib/dream/demos/todo.sx"
|
||||
)
|
||||
|
||||
# Suites: NAME RUNNER-FN PATH
|
||||
SUITES=(
|
||||
"types dream-ty-tests-run! lib/dream/tests/types.sx"
|
||||
"router dream-rt-tests-run! lib/dream/tests/router.sx"
|
||||
"middleware dream-mw-tests-run! lib/dream/tests/middleware.sx"
|
||||
"session dream-ss-tests-run! lib/dream/tests/session.sx"
|
||||
"flash dream-fl-tests-run! lib/dream/tests/flash.sx"
|
||||
"form dream-fo-tests-run! lib/dream/tests/form.sx"
|
||||
"websocket dream-ws-tests-run! lib/dream/tests/websocket.sx"
|
||||
"static dream-st-tests-run! lib/dream/tests/static.sx"
|
||||
"error dream-er-tests-run! lib/dream/tests/error.sx"
|
||||
"cors dream-co-tests-run! lib/dream/tests/cors.sx"
|
||||
"json dream-js-tests-run! lib/dream/tests/json.sx"
|
||||
"auth dream-au-tests-run! lib/dream/tests/auth.sx"
|
||||
"html dream-ht-tests-run! lib/dream/tests/html.sx"
|
||||
"headers dream-hd-tests-run! lib/dream/tests/headers.sx"
|
||||
"run dream-rn-tests-run! lib/dream/tests/run.sx"
|
||||
"api dream-ap-tests-run! lib/dream/tests/api.sx"
|
||||
"demos dream-dm-tests-run! lib/dream/tests/demos.sx"
|
||||
)
|
||||
|
||||
TMPFILE=$(mktemp); trap "rm -f $TMPFILE" EXIT
|
||||
EPOCH=1
|
||||
emit_load () { echo "(epoch $EPOCH)"; echo "(load \"$1\")"; EPOCH=$((EPOCH+1)); }
|
||||
emit_eval () { echo "(epoch $EPOCH)"; echo "(eval \"$1\")"; EPOCH=$((EPOCH+1)); }
|
||||
|
||||
{
|
||||
for M in "${MODULES[@]}"; do emit_load "$M"; done
|
||||
for SUITE in "${SUITES[@]}"; do
|
||||
read -r _NAME _RUNNER FILE <<< "$SUITE"
|
||||
emit_load "$FILE"
|
||||
emit_eval "($_RUNNER)"
|
||||
done
|
||||
} > "$TMPFILE"
|
||||
|
||||
OUTPUT=$(timeout 540 "$SX_SERVER" < "$TMPFILE" 2>&1 || true)
|
||||
|
||||
TOTAL_PASS=0
|
||||
TOTAL_FAIL=0
|
||||
FAILED_SUITES=()
|
||||
LAST_DICT_LINES=$(echo "$OUTPUT" | grep -E '^\{:' || true)
|
||||
|
||||
I=0
|
||||
while read -r LINE; do
|
||||
[ -z "$LINE" ] && continue
|
||||
P=$(echo "$LINE" | grep -oE ':passed [0-9]+' | awk '{print $2}')
|
||||
F=$(echo "$LINE" | grep -oE ':failed [0-9]+' | awk '{print $2}')
|
||||
[ -z "$P" ] && P=0
|
||||
[ -z "$F" ] && F=0
|
||||
SUITE_INFO="${SUITES[$I]}"
|
||||
SUITE_NAME=$(echo "$SUITE_INFO" | awk '{print $1}')
|
||||
TOTAL_PASS=$((TOTAL_PASS + P))
|
||||
TOTAL_FAIL=$((TOTAL_FAIL + F))
|
||||
if [ "$F" -gt 0 ]; then
|
||||
FAILED_SUITES+=("$SUITE_NAME: $P/$((P+F))")
|
||||
printf 'X %-12s %d/%d\n' "$SUITE_NAME" "$P" "$((P+F))"
|
||||
echo "$LINE" | grep -oE ':name "[^"]*"' | sed 's/:name / fail: /'
|
||||
elif [ "$VERBOSE" = "-v" ]; then
|
||||
printf 'ok %-12s %d passed\n' "$SUITE_NAME" "$P"
|
||||
fi
|
||||
I=$((I+1))
|
||||
done <<< "$LAST_DICT_LINES"
|
||||
|
||||
TOTAL=$((TOTAL_PASS + TOTAL_FAIL))
|
||||
if [ "$TOTAL" -eq 0 ]; then
|
||||
echo "ERROR: no suite results parsed. Raw output:" >&2
|
||||
echo "$OUTPUT" >&2
|
||||
exit 1
|
||||
fi
|
||||
if [ $TOTAL_FAIL -eq 0 ]; then
|
||||
echo "ok $TOTAL_PASS/$TOTAL dream-on-sx tests passed (${#SUITES[@]} suites)"
|
||||
else
|
||||
echo "FAIL $TOTAL_PASS/$TOTAL passed, $TOTAL_FAIL failed:"
|
||||
for S in "${FAILED_SUITES[@]}"; do echo " $S"; done
|
||||
exit 1
|
||||
fi
|
||||
@@ -1,51 +0,0 @@
|
||||
;; lib/dream/cors.sx — Dream-on-SX CORS middleware.
|
||||
;; Decorates responses with Access-Control-Allow-* headers and short-circuits
|
||||
;; preflight OPTIONS requests with a 204. Depends on types.sx.
|
||||
|
||||
(define dream-cors-defaults {:methods "GET, POST, PUT, PATCH, DELETE, OPTIONS" :headers "Content-Type" :max-age 86400 :credentials false :origin "*"})
|
||||
|
||||
(define
|
||||
dr/cors-origin-headers
|
||||
(fn
|
||||
(opts resp)
|
||||
(let
|
||||
((r1 (dream-add-header resp "access-control-allow-origin" (get opts :origin))))
|
||||
(if
|
||||
(get opts :credentials)
|
||||
(dream-add-header r1 "access-control-allow-credentials" "true")
|
||||
r1))))
|
||||
|
||||
(define
|
||||
dr/cors-preflight
|
||||
(fn
|
||||
(opts)
|
||||
(dr/cors-origin-headers
|
||||
opts
|
||||
(dream-add-header
|
||||
(dream-add-header
|
||||
(dream-add-header
|
||||
(dream-empty 204)
|
||||
"access-control-allow-methods"
|
||||
(get opts :methods))
|
||||
"access-control-allow-headers"
|
||||
(get opts :headers))
|
||||
"access-control-max-age"
|
||||
(str (get opts :max-age))))))
|
||||
|
||||
(define
|
||||
dream-cors-with
|
||||
(fn
|
||||
(opts)
|
||||
(fn
|
||||
(next)
|
||||
(fn
|
||||
(req)
|
||||
(if
|
||||
(= (dream-method req) "OPTIONS")
|
||||
(dr/cors-preflight opts)
|
||||
(dr/cors-origin-headers opts (next req)))))))
|
||||
|
||||
(define dream-cors (dream-cors-with dream-cors-defaults))
|
||||
(define
|
||||
dream-cors-origin
|
||||
(fn (origin) (dream-cors-with (assoc dream-cors-defaults :origin origin))))
|
||||
@@ -1,46 +0,0 @@
|
||||
;; lib/dream/demos/chat.sx — multi-room WebSocket chat (chat.ml).
|
||||
;; A room registry holds the live connections per room; each ws session joins its
|
||||
;; room, broadcasts every received message to the room, and leaves on close.
|
||||
|
||||
(define dream-chat-rooms (fn () (let ((rooms {})) {:join (fn (room ws) (set! rooms (assoc rooms room (concat (or (get rooms room) (list)) (list ws))))) :broadcast (fn (room msg) (for-each (fn (w) (dream-send w msg)) (or (get rooms room) (list)))) :members (fn (room) (or (get rooms room) (list))) :leave (fn (room ws) (set! rooms (assoc rooms room (filter (fn (w) (not (= w ws))) (or (get rooms room) (list))))))})))
|
||||
|
||||
(define
|
||||
dream-chat-loop
|
||||
(fn
|
||||
(rooms room ws)
|
||||
(let
|
||||
((m (dream-receive ws)))
|
||||
(if
|
||||
(nil? m)
|
||||
(begin ((get rooms :leave) room ws) (dream-close ws))
|
||||
(begin
|
||||
((get rooms :broadcast) room m)
|
||||
(dream-chat-loop rooms room ws))))))
|
||||
|
||||
(define
|
||||
dream-chat-session
|
||||
(fn
|
||||
(rooms room)
|
||||
(fn
|
||||
(ws)
|
||||
(begin ((get rooms :join) room ws) (dream-chat-loop rooms room ws)))))
|
||||
|
||||
(define
|
||||
dream-chat-route
|
||||
(fn
|
||||
(rooms)
|
||||
(fn
|
||||
(req)
|
||||
((dream-websocket (dream-chat-session rooms (dream-param req "room")))
|
||||
req))))
|
||||
|
||||
(define
|
||||
dream-chat-app-with
|
||||
(fn
|
||||
(rooms)
|
||||
(dream-router
|
||||
(list
|
||||
(dream-get "/" (fn (req) (dream-html "<h1>Rooms</h1>")))
|
||||
(dream-get "/chat/:room" (dream-chat-route rooms))))))
|
||||
|
||||
;; entry point: (dream-run (dream-chat-app-with (dream-chat-rooms)))
|
||||
@@ -1,35 +0,0 @@
|
||||
;; lib/dream/demos/counter.sx — per-session visit counter (counter.ml).
|
||||
;; Demonstrates the session middleware: each browser session keeps its own count.
|
||||
|
||||
(define
|
||||
dream-counter-handler
|
||||
(fn
|
||||
(req)
|
||||
(let
|
||||
((n (+ 1 (or (dream-session-field req "count") 0))))
|
||||
(begin
|
||||
(dream-set-session-field req "count" n)
|
||||
(dream-html (str "<p>You have visited this page " n " time(s).</p>"))))))
|
||||
|
||||
;; reset clears the session counter
|
||||
(define
|
||||
dream-counter-reset
|
||||
(fn
|
||||
(req)
|
||||
(begin
|
||||
(dream-set-session-field req "count" 0)
|
||||
(dream-redirect "/"))))
|
||||
|
||||
(define
|
||||
dream-counter-app-with
|
||||
(fn
|
||||
(backend)
|
||||
((dream-sessions backend)
|
||||
(dream-router
|
||||
(list
|
||||
(dream-get "/" dream-counter-handler)
|
||||
(dream-post "/reset" dream-counter-reset))))))
|
||||
|
||||
(define dream-counter-app (dream-counter-app-with (dream-memory-sessions)))
|
||||
|
||||
;; entry point: (dream-run (dream-counter-app-with (dream-memory-sessions)))
|
||||
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue
Block a user