blob: 2cfabdd84205e212fa9e9d2799dee96f614e85d1 (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
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;
] );
]
|
