blob: 415e1c2eb7fc2dcab8ec6e53ec5e8b0dfafc178d (
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
152
153
154
155
156
157
158
159
160
161
162
163
164
165
|
(* 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;
] );
]
|
