path: root/test/test_branch.ml

(* 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_unknown_relation_is_no_transition () =
  (* Decision 15: inserting into a relation absent from the catalog
     is a dangling reference, and there is no such transition. *)
  let world = world () in
  let source =
    Printf.sprintf
      {| [Insert relation: #Ghost tuple: {name: "X" age: 1} before: %S after: S1] |}
      (tip_digest world)
  in
  Alcotest.(check int) "dangling reference" 0
    (List.length (solve world (compile source)))

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 "unknown relation is no transition" `Quick
            test_unknown_relation_is_no_transition;
          Alcotest.test_case "reads default to tip" `Quick
            test_reads_default_to_tip;
        ] );
    ]