diff --git a/src/proto_alpha/lib_protocol/src/storage_functors.ml b/src/proto_alpha/lib_protocol/src/storage_functors.ml index 6dc2e191a..5c2685bb1 100644 --- a/src/proto_alpha/lib_protocol/src/storage_functors.ml +++ b/src/proto_alpha/lib_protocol/src/storage_functors.ml @@ -254,6 +254,37 @@ module Make_indexed_data_storage end +module Make_indexed_data_snapshotable_storage (C : Raw_context.T) + (Snapshot_index : INDEX) (I : INDEX) (V : VALUE) + : Indexed_data_snapshotable_storage with type t = C.t + and type snapshot = Snapshot_index.t + and type key = I.t + and type value = V.t = struct + type snapshot = Snapshot_index.t + + let data_name = ["current"] + let snapshot_name = ["snapshot"] + let snapshot_name_length = List.length snapshot_name + + module C_data = Make_subcontext(C)(struct let name = data_name end) + module C_snapshot = Make_subcontext(C)(struct let name = snapshot_name end) + + include Make_indexed_data_storage(C_data)(I) (V) + module Snapshot = Make_indexed_data_storage(C_snapshot)(Pair(Snapshot_index)(I))(V) + + let snapshot_path id = snapshot_name @ Snapshot_index.to_path id [] + + let snapshot s id = + C.copy s ~from:data_name ~to_:(snapshot_path id) >>=? fun t -> + return (C.project t) + + let delete_snapshot s id = + C.remove_rec s (Snapshot_index.to_path id snapshot_name) >>= fun t -> + Lwt.return (C.project t) + +end + + module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) : Indexed_raw_context with type t = C.t and type key = I.t = struct diff --git a/src/proto_alpha/lib_protocol/src/storage_functors.mli b/src/proto_alpha/lib_protocol/src/storage_functors.mli index 30129fc9d..ecd850867 100644 --- a/src/proto_alpha/lib_protocol/src/storage_functors.mli +++ b/src/proto_alpha/lib_protocol/src/storage_functors.mli @@ -44,6 +44,13 @@ module Make_indexed_data_storage (C : Raw_context.T) (I : INDEX) (V : VALUE) and type key = I.t and type value = V.t +module Make_indexed_data_snapshotable_storage (C : Raw_context.T) + (Snapshot : INDEX) (I : INDEX) (V : VALUE) + : Indexed_data_snapshotable_storage with type t = C.t + and type snapshot = Snapshot.t + and type key = I.t + and type value = V.t + module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) : Indexed_raw_context with type t = C.t and type key = I.t diff --git a/src/proto_alpha/lib_protocol/src/storage_sigs.ml b/src/proto_alpha/lib_protocol/src/storage_sigs.ml index f8978d987..07e4ddaed 100644 --- a/src/proto_alpha/lib_protocol/src/storage_sigs.ml +++ b/src/proto_alpha/lib_protocol/src/storage_sigs.ml @@ -141,6 +141,22 @@ module type Indexed_data_storage = sig end +module type Indexed_data_snapshotable_storage = sig + type snapshot + type key + + include Indexed_data_storage with type key := key + + module Snapshot : Indexed_data_storage + with type key = (snapshot * key) + and type value = value + and type t = t + + val snapshot : context -> snapshot -> Raw_context.t tzresult Lwt.t + val delete_snapshot : context -> snapshot -> Raw_context.t Lwt.t + +end + (** The generic signature of a data set accessor (a set of values bound to a specific key prefix in the hierarchical (key x value) database). *)