diff options
Diffstat (limited to 'lib/management')
| -rw-r--r-- | lib/management/database.ml | 76 | ||||
| -rw-r--r-- | lib/management/diff.ml | 82 |
2 files changed, 89 insertions, 69 deletions
diff --git a/lib/management/database.ml b/lib/management/database.ml index c4c6dc3..f4d18e8 100644 --- a/lib/management/database.ml +++ b/lib/management/database.ml @@ -1,12 +1,12 @@ (** 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. *) + 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) +module RelationMap = Map.Make (String) type deferred_entry = { relation_name : string; @@ -25,16 +25,17 @@ type t = { deferred : deferred_entry list; } -let empty ~name = { - hash = ""; - name; - tree = Merkle.empty; - relations = RelationMap.empty; - domains = RelationMap.empty; - history = []; - timestamp = Unix.gettimeofday (); - deferred = []; -} +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 @@ -44,8 +45,8 @@ let compute_hash db = let max_history = 128 let rec take_at_most n = function - | [] -> [] - | _ when n = 0 -> [] + | [] -> [] + | _ when n = 0 -> [] | x :: xs -> x :: take_at_most (n - 1) xs let update_state db ~relations ~tree = @@ -58,9 +59,16 @@ let update_state db ~relations ~tree = 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 } + { + 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 @@ -74,16 +82,18 @@ let get_relation_names db = 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 = 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_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 @@ -93,21 +103,21 @@ 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 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 = 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 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 } diff --git a/lib/management/diff.ml b/lib/management/diff.ml index 865c757..8fca0af 100644 --- a/lib/management/diff.ml +++ b/lib/management/diff.ml @@ -1,24 +1,24 @@ -(** Structural delta between two Database.t states. - Computes what changed from ancestor → target at the relation level. *) +(** Structural delta between two Database.t states. Computes what changed from + ancestor -> target at the relation level. *) type relation_diff = - | RelationAdded of Relation.t + | RelationAdded of Relation.t | RelationRemoved of string | RelationModified of { - name : string; - added_tuples : Conventions.Hash.t list; + name : string; + added_tuples : Conventions.Hash.t list; removed_tuples : Conventions.Hash.t list; schema_changed : bool; } type t = { - ancestor : Conventions.Hash.t; - left : Conventions.Hash.t; - right : Conventions.Hash.t; + ancestor : Conventions.Hash.t; + left : Conventions.Hash.t; + right : Conventions.Hash.t; relation_diffs : relation_diff list; } -module StringSet = Set.Make(String) +module StringSet = Set.Make (String) let relation_keys rel = match rel.Relation.tree with @@ -30,31 +30,41 @@ let diff ~ancestor ~(target : Database.t) = let ancestor_names = Database.get_relation_names ancestor |> StringSet.of_list in - let target_names = - Database.get_relation_names target |> StringSet.of_list - in + let target_names = Database.get_relation_names target |> StringSet.of_list in let all_names = StringSet.union ancestor_names target_names in - StringSet.fold (fun name acc -> - let in_ancestor = StringSet.mem name ancestor_names in - let in_target = StringSet.mem name target_names in - match in_ancestor, in_target with - | false, true -> - let rel = Option.get (Database.get_relation target name) in - RelationAdded rel :: acc - | true, false -> - RelationRemoved name :: acc - | true, true -> - let anc_rel = Option.get (Database.get_relation ancestor name) in - let tgt_rel = Option.get (Database.get_relation target name) in - (* Compare hashes — if identical, no diff *) - if anc_rel.Relation.hash = tgt_rel.Relation.hash then acc - else begin - let anc_keys = relation_keys anc_rel in - let tgt_keys = relation_keys tgt_rel in - let added_tuples = StringSet.diff tgt_keys anc_keys |> StringSet.elements in - let removed_tuples = StringSet.diff anc_keys tgt_keys |> StringSet.elements in - let schema_changed = anc_rel.Relation.schema <> tgt_rel.Relation.schema in - RelationModified { name; added_tuples; removed_tuples; schema_changed } :: acc - end - | false, false -> acc (* impossible *) - ) all_names [] + StringSet.fold + (fun name acc -> + let in_ancestor = StringSet.mem name ancestor_names in + let in_target = StringSet.mem name target_names in + match (in_ancestor, in_target) with + | false, true -> ( + match Database.get_relation target name with + | Some rel -> RelationAdded rel :: acc + | None -> acc) + | true, false -> RelationRemoved name :: acc + | true, true -> ( + match + ( Database.get_relation ancestor name, + Database.get_relation target name ) + with + | Some anc_rel, Some tgt_rel -> + (* Compare hashes — if identical, no diff *) + if anc_rel.Relation.hash = tgt_rel.Relation.hash then acc + else + let anc_keys = relation_keys anc_rel in + let tgt_keys = relation_keys tgt_rel in + let added_tuples = + StringSet.diff tgt_keys anc_keys |> StringSet.elements + in + let removed_tuples = + StringSet.diff anc_keys tgt_keys |> StringSet.elements + in + let schema_changed = + anc_rel.Relation.schema <> tgt_rel.Relation.schema + in + RelationModified + { name; added_tuples; removed_tuples; schema_changed } + :: acc + | _ -> acc) + | false, false -> acc (* impossible *)) + all_names [] |