blob: b8a9829a42f73487b2c188dfb78a19f43bfac765 (
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
|
(** Database state: a named collection of relations with a Merkle tree over
their hashes, a domain registry, and a history chain of prior hashes. All
mutations produce a new value; no in-place update. *)
(* TODO: history is an unbounded list of hashes; there is no way to
reconstruct a past state from a hash alone without a separate snapshot
store. Either cap the history or make it actually useful. *)
(* TODO: refactor RelationMap keying from composite "schema:relation" strings
to nested maps (schema -> relation -> Relation.t) for cleaner semantics.
Currently, callers are responsible for passing composite keys. *)
module RelationMap = Map.Make (String)
type deferred_entry = {
relation_name : string;
constraint_name : string;
body : Constraint.t;
}
type t = {
hash : Conventions.Hash.t;
name : Conventions.Name.t;
tree : Merkle.t;
relations : Relation.t RelationMap.t;
domains : Domain.t RelationMap.t;
history : Conventions.Hash.t list;
timestamp : float;
deferred : deferred_entry list;
}
let empty ~name =
{
hash = "";
name;
tree = Merkle.empty;
relations = RelationMap.empty;
domains = RelationMap.empty;
history = [];
timestamp = Unix.gettimeofday ();
deferred = [];
}
let compute_hash db =
match Merkle.root_hash db.tree with
| Some root -> root
| None -> Conventions.Hash.hash_text db.name
let max_history = 128
let rec take_at_most n = function
| [] -> []
| _ when n = 0 -> []
| x :: xs -> x :: take_at_most (n - 1) xs
let update_state db ~relations ~tree =
let new_hash =
match Merkle.root_hash tree with
| Some root -> root
| None -> Conventions.Hash.hash_text db.name
in
let history =
if db.hash = "" then db.history
else take_at_most max_history (db.hash :: db.history)
in
{
hash = new_hash;
name = db.name;
tree;
relations;
domains = db.domains;
history;
timestamp = Unix.gettimeofday ();
deferred = db.deferred;
}
let get_relation db name = RelationMap.find_opt name db.relations
let get_relation_hash db name =
match RelationMap.find_opt name db.relations with
| None -> None
| Some rel -> rel.Relation.hash
let get_relation_names db =
RelationMap.fold (fun name _ acc -> name :: acc) db.relations []
let has_relation db name = RelationMap.mem name db.relations
let relation_hash_or_compute (relation : Relation.t) =
match relation.hash with
| Some h -> h
| None ->
let tree = Option.value relation.tree ~default:Merkle.empty in
Hashing.hash_relation ~name:relation.name ~schema:relation.schema ~tree
(* TODO: computing the hash here for hash:None relations (ephemeral/prelude)
is a layering violation — callers should assign the hash before calling
add_relation, not rely on this fallback. *)
let add_relation db ~(relation : Relation.t) =
let relation_hash = relation_hash_or_compute relation in
let relation = { relation with hash = Some relation_hash } in
let tree = Merkle.insert relation_hash db.tree in
let relations = RelationMap.add relation.name relation db.relations in
update_state db ~relations ~tree
let remove_relation db ~name =
match RelationMap.find_opt name db.relations with
| None -> db
| Some relation ->
let relation_hash = relation_hash_or_compute relation in
let tree = Merkle.delete relation_hash db.tree in
let relations = RelationMap.remove name db.relations in
update_state db ~relations ~tree
let update_relation db ~(relation : Relation.t) =
let name = relation.name in
match RelationMap.find_opt name db.relations with
| None -> db
| Some old_relation ->
let old_hash = relation_hash_or_compute old_relation in
let new_hash = relation_hash_or_compute relation in
let tree = db.tree |> Merkle.delete old_hash |> Merkle.insert new_hash in
let relations = RelationMap.add name relation db.relations in
update_state db ~relations ~tree
let add_domain db (domain : Domain.t) =
{ db with domains = RelationMap.add domain.name domain db.domains }
let get_domain db name = RelationMap.find_opt name db.domains
let get_domain_names db =
RelationMap.fold (fun name _ acc -> name :: acc) db.domains []
let has_domain db name = RelationMap.mem name db.domains
let remove_domain db name =
{ db with domains = RelationMap.remove name db.domains }
|
