From 5a4f7d5ed6e5d6b2711db316e8de06cea78b54ec Mon Sep 17 00:00:00 2001 From: Estevan Castilho Date: Sat, 15 Aug 2026 00:09:22 +0000 Subject: Allow storage backend addresses to be labels rather than hashes --- lib/abstract/Storage.ml | 6 ++++-- lib/backend/storage/LMDB.ml | 14 ++++++++++---- lib/kernel/Initialization.ml | 4 ++-- lib/kernel/Merkle.ml | 10 +++++----- lib/kernel/Storage.ml | 2 +- 5 files changed, 22 insertions(+), 14 deletions(-) (limited to 'lib') diff --git a/lib/abstract/Storage.ml b/lib/abstract/Storage.ml index 5eaeba3..c936be4 100644 --- a/lib/abstract/Storage.ml +++ b/lib/abstract/Storage.ml @@ -7,6 +7,8 @@ module type STORAGE = sig type connection type transaction + type address = Label of string | Hash of Concepts.Hash.hash + val connect : Concepts.Configuration.term -> (connection, Concepts.Condition.condition) result (** begin a transaction within `connection` *) @@ -21,13 +23,13 @@ module type STORAGE = sig (** within a transaction, fetch a blob from disk *) val get : transaction -> - Concepts.Hash.hash -> + address -> (Concepts.Representation.blob option, Concepts.Condition.condition) result (** within a transaction, associate a hash with a blob on disk *) val put : transaction -> - Concepts.Hash.hash -> + address -> Concepts.Representation.blob -> (unit, Concepts.Condition.condition) result end diff --git a/lib/backend/storage/LMDB.ml b/lib/backend/storage/LMDB.ml index ff5eb3d..dc7f510 100644 --- a/lib/backend/storage/LMDB.ml +++ b/lib/backend/storage/LMDB.ml @@ -129,6 +129,8 @@ end type connection = {env: C.mdb_env_ptr; dbi: C.mdb_dbi} type transaction = {tx: C.mdb_txn_ptr; dbi: C.mdb_dbi} +type address = Label of string | Hash of Concepts.Hash.hash + let parse (c : Concepts.Configuration.term) = let open Concepts.Configuration in let open Utilities.Result in @@ -170,16 +172,20 @@ let abort ({tx; _} : transaction) = C.mdb_txn_abort tx |> Result.map_error Error * opens the path for avoiding a copy on the FFI boundary later on *) -let get ({tx; dbi} : transaction) (h : Concepts.Hash.hash) = - begin match C.mdb_get' tx dbi (Concepts.Hash.bytes_of_hash h) with +let bytes_of_address = function + | Label s -> String.to_bytes s + | Hash h -> Concepts.Hash.bytes_of_hash h + +let get ({tx; dbi} : transaction) (addr : address) = + begin match C.mdb_get' tx dbi (bytes_of_address addr) with | Ok x -> Ok (Some (Concepts.Representation.blob_of_bytes x)) | Error e when e = C.Errors.mdb_notfound -> Ok None | Error e -> Error e end |> Result.map_error Error.lmdb_error -let put ({tx; dbi} : transaction) (h : Concepts.Hash.hash) (b : Concepts.Representation.blob) = - C.mdb_put' tx dbi (Concepts.Hash.bytes_of_hash h) +let put ({tx; dbi} : transaction) (addr : address) (b : Concepts.Representation.blob) = + C.mdb_put' tx dbi (bytes_of_address addr) (Concepts.Representation.bytes_of_blob b) Unsigned.UInt.zero |> Result.map_error Error.lmdb_error diff --git a/lib/kernel/Initialization.ml b/lib/kernel/Initialization.ml index a27539f..fc7c51a 100644 --- a/lib/kernel/Initialization.ml +++ b/lib/kernel/Initialization.ml @@ -34,7 +34,7 @@ module Make (Store : Abstract.Storage.STORAGE) = struct let read_in_transaction tx = let open Utilities.Result in - let* fixed = Store.get tx fixed_label_address in + let* fixed = Store.get tx (Store.Hash fixed_label_address) in match fixed with | None -> Ok None | Some fixed -> @@ -45,7 +45,7 @@ module Make (Store : Abstract.Storage.STORAGE) = struct | None -> Error (Error.missing_branch_index root) end - let store_fixed_root tx root = Store.put tx fixed_label_address (address_to_blob root) + let store_fixed_root tx root = Store.put tx (Store.Hash fixed_label_address) (address_to_blob root) let create_initial_branch_state tx = let open Utilities.Result in diff --git a/lib/kernel/Merkle.ml b/lib/kernel/Merkle.ml index 49f4fda..60a10a7 100644 --- a/lib/kernel/Merkle.ml +++ b/lib/kernel/Merkle.ml @@ -118,7 +118,7 @@ module Make : TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> struct let find tx node = let open Utilities.Result in - let* data = S.get tx node in + let* data = S.get tx (S.Hash node) in match data with | None -> Ok None | Some data -> @@ -146,7 +146,7 @@ module Make : TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> struct let open Utilities.Result in let data = to_blob node in let addr = Concepts.Hash.hash_of_blob data in - let* () = S.put tx addr data in + let* () = S.put tx (S.Hash addr) data in Ok addr let empty_under tx = persist tx empty @@ -286,7 +286,7 @@ module Make : TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> struct end module type INTERFACE = functor (S : Abstract.Storage.STORAGE) (K : KEY) (V : VALUE) -> sig - type address + type address = Concepts.Hash.hash type node val find : S.transaction -> address -> (node option, Concepts.Condition.condition) result @@ -311,11 +311,11 @@ module Interface : INTERFACE = functor (S : Abstract.Storage.STORAGE) (K : KEY) let intern tx v = let data = V.encode v in let addr = Concepts.Hash.hash_of_blob data in - let* () = S.put tx addr data in + let* () = S.put tx (S.Hash addr) data in Ok addr let retrieve tx addr = - let* data = S.get tx addr in + let* data = S.get tx (S.Hash addr) in match data with | None -> Ok None | Some data -> diff --git a/lib/kernel/Storage.ml b/lib/kernel/Storage.ml index 952b306..376d839 100644 --- a/lib/kernel/Storage.ml +++ b/lib/kernel/Storage.ml @@ -16,7 +16,7 @@ module Make (S : Abstract.Storage.STORAGE) = struct let store_blob tx blob = let open Utilities.Result in let address = Concepts.Hash.hash_of_blob blob in - let* () = S.put tx address blob in + let* () = S.put tx (S.Hash address) blob in Ok address end -- cgit v1.2.3