Allow storage backend addresses to be labels rather than hashes

6 files changed, 25 insertions, 17 deletions

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
diff --git a/test/unit/backend/Storage.ml b/test/unit/backend/Storage.ml
index 76bda8b..e184e1b 100644
--- a/test/unit/backend/Storage.ml
+++ b/test/unit/backend/Storage.ml
@@ -13,9 +13,9 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) =
       begin
         let open Utilities.Result in
         let* tx = S.start conn in
-        let* v = S.get tx key in
-        let* () = S.put tx key blob in
-        let* v' = S.get tx key in
+        let* v = S.get tx (S.Hash key) in
+        let* () = S.put tx (S.Hash key) blob in
+        let* v' = S.get tx (S.Hash key) in
         Ok Concepts.Representation.(Option.map value_of_blob v, Option.map value_of_blob v')
       end
       |> Helpers.condition_as_failure