diff options
Diffstat (limited to '')
| -rw-r--r-- | lib/management/branch.ml | 8 | ||||
| -rw-r--r-- | lib/management/database.ml | 136 | ||||
| -rw-r--r-- | lib/management/diff.ml | 70 | ||||
| -rw-r--r-- | lib/management/merge.ml | 288 | ||||
| -rw-r--r-- | lib/management/multigroup.ml | 84 |
5 files changed, 88 insertions, 498 deletions
diff --git a/lib/management/branch.ml b/lib/management/branch.ml index 81da225..801c43d 100644 --- a/lib/management/branch.ml +++ b/lib/management/branch.ml @@ -70,7 +70,7 @@ module Make (Storage : Physical.S with type error = string) = struct names in Ok branches - +(* let branch_relation storage : Relation.t = let schema = Schema.empty |> Schema.add "name" "string" |> Schema.add "hash" "string" @@ -102,9 +102,9 @@ module Make (Storage : Physical.S with type error = string) = struct ~generator:(Some generator) ~membership_criteria:(fun _ _ -> true) ~provenance:(Relation.Provenance.Base Prelude.Catalog.branch_rel_name) - ~lineage:(Relation.Lineage.Base Prelude.Catalog.branch_rel_name) () + ~lineage:(Relation.Lineage.Base Prelude.Catalog.branch_rel_name) () *) - let head_relation storage : Relation.t = + (* let head_relation storage : Relation.t = let schema = Schema.empty |> Schema.add "branch" "string" in let mk v = { Attribute.value = Obj.repr v } in let generator position = @@ -129,5 +129,5 @@ module Make (Storage : Physical.S with type error = string) = struct ~generator:(Some generator) ~membership_criteria:(fun _ _ -> true) ~provenance:(Relation.Provenance.Base Prelude.Catalog.head_rel_name) - ~lineage:(Relation.Lineage.Base Prelude.Catalog.head_rel_name) () + ~lineage:(Relation.Lineage.Base Prelude.Catalog.head_rel_name) () *) end diff --git a/lib/management/database.ml b/lib/management/database.ml deleted file mode 100644 index b8a9829..0000000 --- a/lib/management/database.ml +++ /dev/null @@ -1,136 +0,0 @@ -(** 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 } diff --git a/lib/management/diff.ml b/lib/management/diff.ml deleted file mode 100644 index 8fca0af..0000000 --- a/lib/management/diff.ml +++ /dev/null @@ -1,70 +0,0 @@ -(** Structural delta between two Database.t states. Computes what changed from - ancestor -> target at the relation level. *) - -type relation_diff = - | RelationAdded of Relation.t - | RelationRemoved of string - | RelationModified of { - 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; - relation_diffs : relation_diff list; -} - -module StringSet = Set.Make (String) - -let relation_keys rel = - match rel.Relation.tree with - | None -> StringSet.empty - | Some tree -> StringSet.of_list (Merkle.keys tree) - -(** Compute relation-level diffs from ancestor → target. *) -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 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 -> ( - 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 [] diff --git a/lib/management/merge.ml b/lib/management/merge.ml deleted file mode 100644 index dff4808..0000000 --- a/lib/management/merge.ml +++ /dev/null @@ -1,288 +0,0 @@ -(** 3-way merge of two branch tips using their Lowest Common Ancestor. Walks the - history chain to find it, diffs both sides against it, applies merge rules, - validates constraints, and persists the result. *) - -type conflict = - | TupleConflict of { relation : string; hash : Conventions.Hash.t } - | SchemaConflict of string - | ConstraintConflict of string - -type strategy = PreferLeft | PreferRight | RevertToAncestor -type merge_result = Clean of Database.t | Failed of conflict list - -(* TODO: Remove this later. We already should have the interface on the manipulation *) - -(** Module type for the subset of Manipulation.Make we need. *) -module type MANIPULATION = sig - type storage - type error - - val of_string_error : string -> error - - val load_database : - storage -> Conventions.Hash.t -> (Database.t option, error) result - - val store_database : storage -> Database.t -> (unit, error) result -end - -module StringSet = Set.Make (String) - -(** Walk history to find LCA. First hash in right's ancestry that also appears - in left's ancestry set. *) -let find_lca left_db right_db = - let left_ancestors = - StringSet.of_list (left_db.Database.hash :: left_db.Database.history) - in - let right_chain = right_db.Database.hash :: right_db.Database.history in - List.find_opt (fun h -> StringSet.mem h left_ancestors) right_chain - -(** Apply a single relation diff to a database, using strategy on conflicts. *) -let apply_diff db ~strategy ~left_db ~right_db ~(left_diff : Diff.relation_diff) - ~(right_diff : Diff.relation_diff option) : Database.t * conflict list = - match left_diff with - | Diff.RelationAdded rel -> - (* Only left added it; right_diff must be None or same *) - (Database.add_relation db ~relation:rel, []) - | Diff.RelationRemoved name -> (Database.remove_relation db ~name, []) - | Diff.RelationModified { name; added_tuples; removed_tuples; schema_changed } - -> ( - let conflicts = ref [] in - (* Determine the merged relation's Merkle tree *) - let base_rel_opt = Database.get_relation db name in - match base_rel_opt with - | None -> (db, []) - | Some base_rel -> - let base_tree = - Option.value base_rel.Relation.tree ~default:Merkle.empty - in - (* Handle schema conflict *) - let resolved_rel, schema_conflict = - if schema_changed then - match right_diff with - | Some (Diff.RelationModified { schema_changed = true; _ }) -> - (* Both changed schema — apply strategy *) - let winner = - match strategy with - | PreferLeft -> Database.get_relation left_db name - | PreferRight -> Database.get_relation right_db name - | RevertToAncestor -> Some base_rel - in - ( Option.value winner ~default:base_rel, - [ SchemaConflict name ] ) - | _ -> - (* Only left changed schema — take left's relation *) - let left_rel = - Option.value - (Database.get_relation left_db name) - ~default:base_rel - in - (left_rel, []) - else (base_rel, []) - in - conflicts := schema_conflict @ !conflicts; - (* Apply tuple adds/removes from left *) - let merged_tree = - List.fold_left (fun t h -> Merkle.insert h t) base_tree added_tuples - in - let merged_tree = - List.fold_left - (fun t h -> Merkle.delete h t) - merged_tree removed_tuples - in - (* Apply tuple adds/removes from right if disjoint *) - let merged_tree = - match right_diff with - | Some - (Diff.RelationModified - { added_tuples = r_add; removed_tuples = r_rem; _ }) -> - (* Detect tuple conflicts: same hash both added and removed *) - let left_add = StringSet.of_list added_tuples in - let left_rem = StringSet.of_list removed_tuples in - let right_add = StringSet.of_list r_add in - let right_rem = StringSet.of_list r_rem in - let conflict_hashes = - StringSet.inter left_add right_rem - |> StringSet.union (StringSet.inter left_rem right_add) - in - if not (StringSet.is_empty conflict_hashes) then begin - StringSet.iter - (fun h -> - conflicts := - TupleConflict { relation = name; hash = h } - :: !conflicts) - conflict_hashes; - (* Resolve conflicting tuples per strategy *) - match strategy with - | PreferLeft -> - (* keep left's merged_tree as-is, ignore conflicting right ops *) - let safe_add = StringSet.diff right_add conflict_hashes in - let safe_rem = StringSet.diff right_rem conflict_hashes in - let t = - StringSet.fold - (fun h acc -> Merkle.insert h acc) - safe_add merged_tree - in - StringSet.fold - (fun h acc -> Merkle.delete h acc) - safe_rem t - | PreferRight -> - (* revert left's conflicting ops, apply right's *) - let t = - StringSet.fold - (fun h acc -> Merkle.delete h acc) - conflict_hashes merged_tree - in - let t = - StringSet.fold - (fun h acc -> Merkle.insert h acc) - right_add t - in - StringSet.fold - (fun h acc -> Merkle.delete h acc) - right_rem t - | RevertToAncestor -> - (* drop conflicting hashes from merged tree *) - StringSet.fold - (fun h acc -> Merkle.delete h acc) - conflict_hashes merged_tree - end - else begin - (* Disjoint — union both sides *) - let t = - List.fold_left - (fun acc h -> Merkle.insert h acc) - merged_tree r_add - in - List.fold_left (fun acc h -> Merkle.delete h acc) t r_rem - end - | _ -> merged_tree - in - let new_hash = - Hashing.hash_relation ~name:resolved_rel.Relation.name - ~schema:resolved_rel.Relation.schema ~tree:merged_tree - in - let updated_rel = - { - resolved_rel with - Relation.tree = Some merged_tree; - hash = Some new_hash; - } - in - let new_db = Database.update_relation db ~relation:updated_rel in - (new_db, !conflicts)) - -module Make - (Storage : Physical.S) - (Manip : MANIPULATION with type storage = Storage.t) = -struct - let err s = Error (Manip.of_string_error s) - - (* Load both tips, find the lowest common ancestor, compute the diffs, - lookup for right diffs by relation name, start from ancestor and - apply all the diffs, apply first the left diffs, then right-only diffs - (relations only right touched). If there are no conflicts, persist the - merged database, otherwise return Failed, unless a strategy resolved them. *) - let merge ~storage ~strategy ~left_tip ~right_tip = - match Manip.load_database storage left_tip with - | Error e -> Error e - | Ok None -> err ("Left tip not found: " ^ left_tip) - | Ok (Some left_db) -> ( - match Manip.load_database storage right_tip with - | Error e -> Error e - | Ok None -> err ("Right tip not found: " ^ right_tip) - | Ok (Some right_db) -> ( - match find_lca left_db right_db with - | None -> err "No common ancestor found between branches" - | Some ancestor_hash -> ( - match Manip.load_database storage ancestor_hash with - | Error e -> Error e - | Ok None -> err ("Ancestor not found: " ^ ancestor_hash) - | Ok (Some ancestor_db) -> - let left_diffs = - Diff.diff ~ancestor:ancestor_db ~target:left_db - in - let right_diffs = - Diff.diff ~ancestor:ancestor_db ~target:right_db - in - let right_diff_map = - List.fold_left - (fun m d -> - let key = - match d with - | Diff.RelationAdded r -> r.Relation.name - | Diff.RelationRemoved n -> n - | Diff.RelationModified { name; _ } -> name - in - Database.RelationMap.add key d m) - Database.RelationMap.empty right_diffs - in - let merged_db, all_conflicts = - let db_after_left, left_conflicts = - List.fold_left - (fun (db, conflicts) left_d -> - let rel_name = - match left_d with - | Diff.RelationAdded r -> r.Relation.name - | Diff.RelationRemoved n -> n - | Diff.RelationModified { name; _ } -> name - in - let right_d = - Database.RelationMap.find_opt rel_name - right_diff_map - in - let new_db, cs = - apply_diff db ~strategy ~left_db ~right_db - ~left_diff:left_d ~right_diff:right_d - in - (new_db, cs @ conflicts)) - (ancestor_db, []) left_diffs - in - let left_names = - List.fold_left - (fun s d -> - let n = - match d with - | Diff.RelationAdded r -> r.Relation.name - | Diff.RelationRemoved n -> n - | Diff.RelationModified { name; _ } -> name - in - StringSet.add n s) - StringSet.empty left_diffs - in - let right_only = - List.filter - (fun d -> - let n = - match d with - | Diff.RelationAdded r -> r.Relation.name - | Diff.RelationRemoved n -> n - | Diff.RelationModified { name; _ } -> name - in - not (StringSet.mem n left_names)) - right_diffs - in - let db_final, right_conflicts = - List.fold_left - (fun (db, conflicts) right_d -> - let new_db, cs = - apply_diff db ~strategy ~left_db ~right_db - ~left_diff:right_d ~right_diff:None - in - (new_db, cs @ conflicts)) - (db_after_left, left_conflicts) - right_only - in - (db_final, right_conflicts) - in - let unresolvable = - List.filter - (function ConstraintConflict _ -> true | _ -> false) - all_conflicts - in - if unresolvable <> [] then Ok (Failed unresolvable) - else - begin match Manip.store_database storage merged_db with - | Error e -> Error e - | Ok () -> Ok (Clean merged_db) - end))) -end diff --git a/lib/management/multigroup.ml b/lib/management/multigroup.ml new file mode 100644 index 0000000..cfde4c1 --- /dev/null +++ b/lib/management/multigroup.ml @@ -0,0 +1,84 @@ +(** Multigroup root: a lightweight versioned descriptor that maps relation names + to content-addressed relation values. The multigroup object owns the B+ tree + pointer and advances it when relations change. *) + + +class multigroup ~name:(init_name : Conventions.Name.t) = + let init_hash = Conventions.Hash.hash_text init_name in + object (self) + val name : Conventions.Name.t = init_name + val hash : Conventions.Hash.t = init_hash + val previous_version : Conventions.Hash.t option = None + val tree_pointer : Conventions.Hash.t option = None + val relations : Relation.relation BatMap.String.t = BatMap.String.empty + val timestamp : float = Unix.gettimeofday () + + method name = name + method hash = hash + method previous_version = previous_version + method tree_pointer = tree_pointer + method relations = relations + method timestamp = timestamp + + method get_relation rel_name = BatMap.String.find_opt rel_name relations + method get_relation_names = BatMap.String.fold (fun n _ acc -> n :: acc) relations [] + method has_relation rel_name = BatMap.String.mem rel_name relations + + (* Derive the B+ tree root hash from sorted relation hashes. *) + method private compute_tree_pointer rels = + BatMap.String.fold + (fun _n (r : Relation.relation) acc -> acc ^ r#hash) + rels "" + |> Conventions.Hash.hash_text + + method private compute_hash tp = + Conventions.Hash.hash_text (name ^ tp) + + method private advance rels = + let tp = self#compute_tree_pointer rels in + {< hash = self#compute_hash tp; + previous_version = (if hash = "" then None else Some hash); + tree_pointer = Some tp; + relations = rels; + timestamp = Unix.gettimeofday () >} + + method add_relation (rel : Relation.relation) = + let rels = BatMap.String.add rel#name rel relations in + self#advance rels + + method remove_relation rel_name = + if not (BatMap.String.mem rel_name relations) then self + else self#advance (BatMap.String.remove rel_name relations) + + method update_relation (rel : Relation.relation) = + if not (BatMap.String.mem rel#name relations) then self + else self#advance (BatMap.String.add rel#name rel relations) + + method serialize () : Storable.Multigroup.t = + { + Storable.Multigroup.name = name; + relations = BatMap.String.bindings relations |> List.map snd |> List.map (fun r -> r#serialize ()); + } +end + +let deserialize (_bytes : bytes) : (multigroup, string) result = + try + let stored = Storable.Multigroup.of_bytes _bytes in + let db = new multigroup ~name:stored.name in + let db = + List.fold_left + (fun db rel -> + let membership_criteria = + Constraint.build_membership_criteria ~_name:rel.Storable.Relation.name + ~schema:rel.schema + in + let relation = + new Relation.stored ~name:rel.name ~schema:rel.schema ~constraints:None + ~cardinality:Conventions.Cardinality.ConstrainedFinite + ~membership_criteria ~lineage:None ~provenance:None + in + db#add_relation relation) + db stored.relations + in + Ok db + with Invalid_argument message -> Error message |