Branching and naïve merge strategies

* AGPL license

* branching and merging

* Delete LICENSE in favor of separate PR

Signed-off-by: Marcos Magueta <maguetamarcos@gmail.com>

* add unmonitored tests and docs

---------

Signed-off-by: Marcos Magueta <maguetamarcos@gmail.com>

3 files changed, 433 insertions, 0 deletions

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:<name>" → 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