From e6661bfa6a3d7dc477d0b7717c80bd536eca2d68 Mon Sep 17 00:00:00 2001 From: Marcos Magueta Date: Sat, 14 Mar 2026 11:39:04 -0300 Subject: =?UTF-8?q?Branching=20and=20na=C3=AFve=20merge=20strategies?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * AGPL license * branching and merging * Delete LICENSE in favor of separate PR Signed-off-by: Marcos Magueta * add unmonitored tests and docs --------- Signed-off-by: Marcos Magueta --- lib/management/branch.ml | 138 ++++++++++++++++++++++++++++ lib/management/diff.ml | 60 ++++++++++++ lib/management/merge.ml | 235 +++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 433 insertions(+) create mode 100644 lib/management/branch.ml create mode 100644 lib/management/diff.ml create mode 100644 lib/management/merge.ml (limited to 'lib/management') diff --git a/lib/management/branch.ml b/lib/management/branch.ml new file mode 100644 index 0000000..70dfd85 --- /dev/null +++ b/lib/management/branch.ml @@ -0,0 +1,138 @@ +(** Branch registry: named pointers to database tip hashes, plus HEAD tracking. + Stored in the Physical backend under reserved key prefixes: + - "branch:" → serialized { name; tip } + - "branch_names" → serialized string list (index for enumeration) + - "head" → branch name as raw bytes *) + +type t = { + name : string; + tip : Conventions.Hash.t; +} + +type head = string + +type error = string + +let branch_key name = "branch:" ^ name +let head_key = "head" +let names_key = "branch_names" + +module Make (Storage : Physical.S with type error = string) = struct + + let load_names storage = + match Storage.load_raw storage names_key with + | Ok (Some bytes) -> (Marshal.from_bytes bytes 0 : string list) + | _ -> [] + + let store_names storage names = + let bytes = Marshal.to_bytes names [] in + ignore (Storage.store_raw storage names_key bytes) + + let create storage ~name ~tip = + let record = { name; tip } in + let bytes = Marshal.to_bytes record [] in + (match Storage.store_raw storage (branch_key name) bytes with + | Error e -> Error e + | Ok () -> + let names = load_names storage in + if not (List.mem name names) then + store_names storage (name :: names); + Ok ()) + + let checkout storage branch_name = + let bytes = Bytes.of_string branch_name in + Storage.store_raw storage head_key bytes + + let get_head storage = + match Storage.load_raw storage head_key with + | Ok (Some bytes) -> Ok (Some (Bytes.to_string bytes)) + | Ok None -> Ok None + | Error e -> Error e + + let get_tip storage name = + match Storage.load_raw storage (branch_key name) with + | Ok (Some bytes) -> + let record : t = Marshal.from_bytes bytes 0 in + Ok (Some record.tip) + | Ok None -> Ok None + | Error e -> Error e + + let update_tip storage ~name ~tip = + match Storage.load_raw storage (branch_key name) with + | Ok (Some _) -> + let record = { name; tip } in + let bytes = Marshal.to_bytes record [] in + Storage.store_raw storage (branch_key name) bytes + | Ok None -> Error ("Branch not found: " ^ name) + | Error e -> Error e + + let list storage = + let names = load_names storage in + let branches = List.filter_map (fun name -> + match get_tip storage name with + | Ok (Some tip) -> Some (name, tip) + | _ -> None + ) names in + Ok branches + + let branch_relation storage : Relation.t = + let schema = + Schema.empty |> Schema.add "name" "string" |> Schema.add "hash" "string" + in + let mk v = { Attribute.value = Obj.repr v } in + let rec generator position = + match position with + | None -> Generator.Error "random access not supported for sakura:branch" + | Some pos -> + (match list storage with + | Error _ -> Generator.Done + | Ok branches -> + if pos >= List.length branches then Generator.Done + else + let (name, tip) = List.nth branches pos in + let short = String.sub tip 0 (min 8 (String.length tip)) in + let attributes = + Tuple.AttributeMap.of_list + [ ("name", mk name) + ; ("hash", mk short) + ] + in + Generator.Value + ( Tuple.make_materialized ~relation:Prelude.Catalog.branch_rel_name ~attributes + , generator )) + in + Relation.make ~hash:None ~name:Prelude.Catalog.branch_rel_name ~schema + ~tree:None ~constraints:None + ~cardinality:Conventions.Cardinality.ConstrainedFinite + ~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) + + 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 = + match position with + | None -> Generator.Error "random access not supported for sakura:head" + | Some 0 -> + (match get_head storage with + | Ok None | Error _ -> Generator.Done + | Ok (Some branch_name) -> + let attributes = + Tuple.AttributeMap.of_list [ ("branch", mk branch_name) ] + in + Generator.Value + ( Tuple.make_materialized ~relation:Prelude.Catalog.head_rel_name ~attributes + , fun _ -> Generator.Done )) + | Some _ -> Generator.Done + in + Relation.make ~hash:None ~name:Prelude.Catalog.head_rel_name ~schema + ~tree:None ~constraints:None + ~cardinality:Conventions.Cardinality.ConstrainedFinite + ~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) + +end diff --git a/lib/management/diff.ml b/lib/management/diff.ml new file mode 100644 index 0000000..865c757 --- /dev/null +++ b/lib/management/diff.ml @@ -0,0 +1,60 @@ +(** 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 -> + 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 [] diff --git a/lib/management/merge.ml b/lib/management/merge.ml new file mode 100644 index 0000000..e50d0e6 --- /dev/null +++ b/lib/management/merge.ml @@ -0,0 +1,235 @@ +(** 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 + +(** 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 -- cgit v1.2.3