diff options
Diffstat (limited to '')
| -rw-r--r-- | lib/management/branch.ml | 99 | ||||
| -rw-r--r-- | lib/management/merge.ml | 435 | ||||
| -rw-r--r-- | lib/management/physical.ml | 135 |
3 files changed, 354 insertions, 315 deletions
diff --git a/lib/management/branch.ml b/lib/management/branch.ml index 70dfd85..ea15311 100644 --- a/lib/management/branch.ml +++ b/lib/management/branch.ml @@ -4,13 +4,8 @@ - "branch_names" → serialized string list (index for enumeration) - "head" → branch name as raw bytes *) -type t = { - name : string; - tip : Conventions.Hash.t; -} - +type t = { name : string; tip : Conventions.Hash.t } type head = string - type error = string let branch_key name = "branch:" ^ name @@ -18,7 +13,6 @@ 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) @@ -31,13 +25,12 @@ module Make (Storage : Physical.S with type error = string) = struct 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 ()) + 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 @@ -52,27 +45,30 @@ module Make (Storage : Physical.S with type error = string) = struct 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) + 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 + 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 + 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 = @@ -83,23 +79,22 @@ module Make (Storage : Physical.S with type error = string) = struct 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 )) + | 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 @@ -115,16 +110,17 @@ module Make (Storage : Physical.S with type error = string) = struct 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 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 @@ -134,5 +130,4 @@ module Make (Storage : Physical.S with type error = string) = struct ~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/merge.ml b/lib/management/merge.ml index e50d0e6..d30545a 100644 --- a/lib/management/merge.ml +++ b/lib/management/merge.ml @@ -1,40 +1,37 @@ -(** 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. *) +(** 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 + | 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 +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 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) +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 + 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. *) @@ -42,104 +39,140 @@ 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 + (* 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)) + (* 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) = + (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, @@ -151,85 +184,103 @@ struct 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 - + | 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/physical.ml b/lib/management/physical.ml index 6063d79..3fc2cf7 100644 --- a/lib/management/physical.ml +++ b/lib/management/physical.ml @@ -1,46 +1,48 @@ (** Physical storage abstraction. - This module defines a functor-based storage interface that can be backed - by any key-value store (etcd, Redis, DynamoDB, PostgreSQL, filesystem, etc.). + This module defines a functor-based storage interface that can be backed by + any key-value store (etcd, Redis, DynamoDB, PostgreSQL, filesystem, etc.). - All data is content-addressed: keys are hashes, values are serialized objects. - The storage is append-only - objects are never modified, only new versions - are written with new hashes. *) + All data is content-addressed: keys are hashes, values are serialized + objects. The storage is append-only - objects are never modified, only new + versions are written with new hashes. *) (** Backend module signature that any storage driver must implement *) module type BACKEND = sig type connection type error - (** Connect to the storage backend *) val connect : unit -> (connection, error) result + (** Connect to the storage backend *) - (** Disconnect from the backend *) val disconnect : connection -> unit + (** Disconnect from the backend *) - (** Get a value by its hash. Returns None if not found. *) val get : connection -> Conventions.Hash.t -> (bytes option, error) result + (** Get a value by its hash. Returns None if not found. *) - (** Store a value at its hash *) val put : connection -> Conventions.Hash.t -> bytes -> (unit, error) result + (** Store a value at its hash *) - (** Check if a hash exists *) val exists : connection -> Conventions.Hash.t -> (bool, error) result + (** Check if a hash exists *) - (** Begin a transaction *) val begin_transaction : connection -> (unit, error) result + (** Begin a transaction *) - (** Commit a transaction *) val commit : connection -> (unit, error) result + (** Commit a transaction *) - (** Rollback a transaction *) val rollback : connection -> (unit, error) result + (** Rollback a transaction *) + val get_many : + connection -> Conventions.Hash.t list -> (bytes option list, error) result (** Batch get multiple values *) - val get_many : connection -> Conventions.Hash.t list -> (bytes option list, error) result + val put_many : + connection -> (Conventions.Hash.t * bytes) list -> (unit, error) result (** Batch put multiple values *) - val put_many : connection -> (Conventions.Hash.t * bytes) list -> (unit, error) result end (** Storage operations built on top of a backend *) @@ -48,29 +50,33 @@ module type S = sig type t type error - (** Create a storage instance from a backend connection *) val create : unit -> (t, error) result + (** Create a storage instance from a backend connection *) - (** Close the storage *) val close : t -> unit + (** Close the storage *) + val store_attribute : + t -> Conventions.AbstractValue.t -> (Conventions.Hash.t, error) result (** Store an attribute value, returns its hash *) - val store_attribute : t -> Conventions.AbstractValue.t -> (Conventions.Hash.t, error) result + val load_attribute : + t -> + Conventions.Hash.t -> + (Conventions.AbstractValue.t option, error) result (** Load an attribute value by hash *) - val load_attribute : t -> Conventions.Hash.t -> (Conventions.AbstractValue.t option, error) result - (** Store raw bytes at a hash *) val store_raw : t -> Conventions.Hash.t -> bytes -> (unit, error) result + (** Store raw bytes at a hash *) - (** Load raw bytes by hash *) val load_raw : t -> Conventions.Hash.t -> (bytes option, error) result + (** Load raw bytes by hash *) - (** Check if a hash exists *) val exists : t -> Conventions.Hash.t -> (bool, error) result + (** Check if a hash exists *) - (** Execute a function within a transaction *) val with_transaction : t -> (unit -> ('a, error) result) -> ('a, error) result + (** Execute a function within a transaction *) end (** Functor to create storage operations from a backend *) @@ -79,15 +85,12 @@ module Make (B : BACKEND) : S with type error = B.error = struct type error = B.error let create () = B.connect () - let close = B.disconnect let store_attribute conn value = let bytes = Marshal.to_bytes value [] in let hash = Conventions.AbstractValue.hash value in - match B.put conn hash bytes with - | Ok () -> Ok hash - | Error e -> Error e + match B.put conn hash bytes with Ok () -> Ok hash | Error e -> Error e let load_attribute conn hash = match B.get conn hash with @@ -95,27 +98,20 @@ module Make (B : BACKEND) : S with type error = B.error = struct | Ok None -> Ok None | Error e -> Error e - let store_raw conn hash bytes = - B.put conn hash bytes - - let load_raw conn hash = - B.get conn hash - - let exists conn hash = - B.exists conn hash + let store_raw conn hash bytes = B.put conn hash bytes + let load_raw conn hash = B.get conn hash + let exists conn hash = B.exists conn hash let with_transaction conn f = match B.begin_transaction conn with | Error e -> Error e - | Ok () -> - match f () with - | Ok result -> - (match B.commit conn with - | Ok () -> Ok result - | Error e -> Error e) - | Error e -> - let _ = B.rollback conn in - Error e + | Ok () -> ( + match f () with + | Ok result -> ( + match B.commit conn with Ok () -> Ok result | Error e -> Error e) + | Error e -> + let _ = B.rollback conn in + Error e) end (** In-memory backend for testing and development *) @@ -125,35 +121,34 @@ module MemoryBackend : BACKEND with type error = string = struct mutable in_transaction : bool; mutable transaction_buffer : (string * bytes) list; } + type error = string let connect () = - Ok { - data = Hashtbl.create 1024; - in_transaction = false; - transaction_buffer = []; - } + Ok + { + data = Hashtbl.create 1024; + in_transaction = false; + transaction_buffer = []; + } let disconnect _ = () - - let get conn hash = - Ok (Hashtbl.find_opt conn.data hash) + let get conn hash = Ok (Hashtbl.find_opt conn.data hash) let put conn hash value = if conn.in_transaction then begin conn.transaction_buffer <- (hash, value) :: conn.transaction_buffer; Ok () - end else begin + end + else begin Hashtbl.replace conn.data hash value; Ok () end - let exists conn hash = - Ok (Hashtbl.mem conn.data hash) + let exists conn hash = Ok (Hashtbl.mem conn.data hash) let begin_transaction conn = - if conn.in_transaction then - Error "Already in transaction" + if conn.in_transaction then Error "Already in transaction" else begin conn.in_transaction <- true; conn.transaction_buffer <- []; @@ -161,20 +156,18 @@ module MemoryBackend : BACKEND with type error = string = struct end let commit conn = - if not conn.in_transaction then - Error "Not in transaction" + if not conn.in_transaction then Error "Not in transaction" else begin - List.iter (fun (hash, value) -> - Hashtbl.replace conn.data hash value - ) conn.transaction_buffer; + List.iter + (fun (hash, value) -> Hashtbl.replace conn.data hash value) + conn.transaction_buffer; conn.in_transaction <- false; conn.transaction_buffer <- []; Ok () end let rollback conn = - if not conn.in_transaction then - Error "Not in transaction" + if not conn.in_transaction then Error "Not in transaction" else begin conn.in_transaction <- false; conn.transaction_buffer <- []; @@ -185,14 +178,14 @@ module MemoryBackend : BACKEND with type error = string = struct Ok (List.map (fun h -> Hashtbl.find_opt conn.data h) hashes) let put_many conn pairs = - List.iter (fun (hash, value) -> - if conn.in_transaction then - conn.transaction_buffer <- (hash, value) :: conn.transaction_buffer - else - Hashtbl.replace conn.data hash value - ) pairs; + List.iter + (fun (hash, value) -> + if conn.in_transaction then + conn.transaction_buffer <- (hash, value) :: conn.transaction_buffer + else Hashtbl.replace conn.data hash value) + pairs; Ok () end +module Memory = Make (MemoryBackend) (** Default in-memory storage for development *) -module Memory = Make(MemoryBackend) |