blob: 2dc0ae63c296da1c96dfb239acfc890e1ef3efb1 (
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
|
(** 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. *)
module RelationMap = Map.Make(String)
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;
}
let empty ~name = {
hash = "";
name;
tree = Merkle.empty;
relations = RelationMap.empty;
domains = RelationMap.empty;
history = [];
timestamp = Unix.gettimeofday ();
}
let compute_hash db =
match Merkle.root_hash db.tree with
| Some root -> root
| None -> Conventions.Hash.hash_text db.name
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 db.hash :: db.history in
{ hash = new_hash; name = db.name; tree; relations;
domains = db.domains; history; timestamp = Unix.gettimeofday () }
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
(* 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 = 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
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 = Option.get relation.hash 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 = Option.get old_relation.hash in
let new_hash = Option.get relation.hash 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 }
|
