branch world: state scoped reads, insert transitions, tip commit

1 files changed, 151 insertions, 0 deletions

diff --git a/test/test_branch.ml b/test/test_branch.ml
new file mode 100644
index 0000000..2cfabdd
--- /dev/null
+++ b/test/test_branch.ml
@@ -0,0 +1,151 @@
+(* The branch world end to end: state-scoped reads, transition
+   chains threading states linearly, integrity at the transition,
+   and the single commit effect. *)
+
+let label s =
+  match Sol.Label.of_string s with
+  | Ok l -> l
+  | Error (`Invalid_label s) -> Alcotest.failf "invalid label: %s" s
+
+module Branch_vm = Sol.Vm.Make (Sol.Branch)
+
+let world () =
+  Sol.Branch.create
+    ~schemas:
+      [
+        ( "Person",
+          [ (label "name", Sol.World.D_string); (label "age", Sol.World.D_integer) ] );
+      ]
+
+let compile source =
+  match Sol.Front.parse_string ("Query expression: " ^ source) with
+  | Ok [ Sol.Ast.Directive ("Query", [ ("expression", node) ]) ] -> (
+      match Sol.World.expr_of_node node with
+      | Ok expr -> expr
+      | Error error ->
+          Alcotest.failf "compile error: %a" Sol.World.pp_error error)
+  | _ -> Alcotest.fail "expected one query"
+
+let solve world expr =
+  match Sol.Branch.linear expr with
+  | Error message -> Alcotest.failf "linearity: %s" message
+  | Ok () -> (
+      match Branch_vm.solve world expr with
+      | Ok solutions -> solutions
+      | Error error -> Alcotest.failf "solve error: %a" Sol.Vm.pp_error error)
+
+let tip_digest world =
+  match Sol.Branch.tip world "main" with
+  | Some (Sol.Term.String digest) -> digest
+  | _ -> Alcotest.fail "no main tip"
+
+let binding solution name =
+  match List.assoc_opt name solution.Sol.Vm.bindings with
+  | Some pattern -> pattern
+  | None -> Alcotest.failf "no binding for %s" name
+
+let test_transition_chain () =
+  let world = world () in
+  let source =
+    Printf.sprintf
+      {| [Insert relation: "Person" tuple: {name: "Marcos" age: 30} before: %S after: S1] :and
+         [Insert relation: "Person" tuple: {name: "Ana" age: 12} before: S1 after: S2] :and
+         [Person name: N age: A at: S2] |}
+      (tip_digest world)
+  in
+  let solutions = solve world (compile source) in
+  Alcotest.(check int) "two people at the final state" 2 (List.length solutions);
+  (* Read your own write mid-chain: only the first insert is
+     visible at S1. *)
+  let mid =
+    Printf.sprintf
+      {| [Insert relation: "Person" tuple: {name: "Marcos" age: 30} before: %S after: S1] :and
+         [Person name: N age: A at: S1] |}
+      (tip_digest world)
+  in
+  Alcotest.(check int) "one person at the middle state" 1
+    (List.length (solve world (compile mid)))
+
+let test_tip_unmoved_until_commit () =
+  let world = world () in
+  let before = tip_digest world in
+  let _ =
+    solve world
+      (compile
+         (Printf.sprintf
+            {| [Insert relation: "Person" tuple: {name: "Rui" age: 70} before: %S after: S1] |}
+            before))
+  in
+  Alcotest.(check string) "solving commits nothing" before (tip_digest world)
+
+let test_commit_and_conflict () =
+  let world = world () in
+  let root = tip_digest world in
+  let solutions =
+    solve world
+      (compile
+         (Printf.sprintf
+            {| [Insert relation: "Person" tuple: {name: "Rui" age: 70} before: %S after: S1] |}
+            root))
+  in
+  let next =
+    match solutions with
+    | [ solution ] -> (
+        match binding solution "S1" with
+        | Sol.Pattern.String digest -> Sol.Term.string digest
+        | _ -> Alcotest.fail "S1 did not resolve to a state")
+    | _ -> Alcotest.fail "expected one solution"
+  in
+  let expect = Sol.Term.string root in
+  (match Sol.Branch.commit world ~branch:"main" ~expect ~next with
+  | Ok () -> ()
+  | Error `Conflict -> Alcotest.fail "first commit must succeed");
+  (* A second commit from the same stale expectation conflicts:
+     the kernel arbitrates only the tip. *)
+  match Sol.Branch.commit world ~branch:"main" ~expect ~next with
+  | Error `Conflict -> ()
+  | Ok () -> Alcotest.fail "stale expectation must conflict"
+
+let test_integrity_at_transition () =
+  let world = world () in
+  let source =
+    Printf.sprintf
+      {| [Insert relation: "Person" tuple: {name: "Ghost" age: "old"} before: %S after: S1] |}
+      (tip_digest world)
+  in
+  Alcotest.(check int) "an ill-typed tuple is no transition" 0
+    (List.length (solve world (compile source)))
+
+let test_linearity_rejects_forks () =
+  let world = world () in
+  ignore world;
+  let source =
+    {| [Insert relation: "Person" tuple: {name: "A" age: 1} before: S0 after: S1] :and
+       [Insert relation: "Person" tuple: {name: "B" age: 2} before: S0 after: S2] |}
+  in
+  match Sol.Branch.linear (compile source) with
+  | Error _ -> ()
+  | Ok () -> Alcotest.fail "a fork inside one expression must be rejected"
+
+let test_reads_default_to_tip () =
+  let world = world () in
+  Alcotest.(check int) "the root tip has nobody" 0
+    (List.length (solve world (compile {| [Person name: N age: A] |})))
+
+let () =
+  Alcotest.run "sol-branch"
+    [
+      ( "states and transitions",
+        [
+          Alcotest.test_case "transition chain" `Quick test_transition_chain;
+          Alcotest.test_case "tip unmoved until commit" `Quick
+            test_tip_unmoved_until_commit;
+          Alcotest.test_case "commit and conflict" `Quick test_commit_and_conflict;
+          Alcotest.test_case "integrity at the transition" `Quick
+            test_integrity_at_transition;
+          Alcotest.test_case "linearity rejects forks" `Quick
+            test_linearity_rejects_forks;
+          Alcotest.test_case "reads default to tip" `Quick
+            test_reads_default_to_tip;
+        ] );
+    ]