From 17644e0fa3bc07c009e75a9820d649300374eb3f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gr=C3=A9goire=20Henry?= Date: Thu, 16 Nov 2017 16:45:22 +0100 Subject: [PATCH] Proto: reimplements `Storage_functors` with iterable indexes The new `Storage_functors` is now a "functional" equivalent of the "imperative" `Store_helpers` used in the shell. --- src/environment/v1/context.mli | 3 + src/environment/v1/hash.mli | 2 +- src/node/db/store_helpers.ml | 20 +- src/node/db/store_sigs.ml | 2 +- src/proto/alpha/TEZOS_PROTOCOL | 2 +- src/proto/alpha/amendment.ml | 10 +- src/proto/alpha/bootstrap_storage.ml | 4 +- src/proto/alpha/bootstrap_storage.mli | 6 +- src/proto/alpha/contract_repr.ml | 30 + src/proto/alpha/contract_repr.mli | 9 + src/proto/alpha/contract_storage.ml | 11 +- src/proto/alpha/contract_storage.mli | 48 +- src/proto/alpha/cycle_repr.ml | 13 + src/proto/alpha/cycle_repr.mli | 8 + src/proto/alpha/fitness_storage.ml | 4 +- src/proto/alpha/init_storage.ml | 24 +- src/proto/alpha/level_repr.ml | 1 + src/proto/alpha/level_storage.ml | 12 +- src/proto/alpha/level_storage.mli | 16 +- src/proto/alpha/nonce_storage.mli | 10 +- src/proto/alpha/persist.ml | 422 ------------ src/proto/alpha/persist.mli | 218 ------- src/proto/alpha/public_key_storage.ml | 10 +- src/proto/alpha/public_key_storage.mli | 10 +- src/proto/alpha/raw_context.ml | 339 ++++++++++ src/proto/alpha/raw_context.mli | 134 ++++ src/proto/alpha/raw_level_repr.ml | 12 + src/proto/alpha/raw_level_repr.mli | 7 + src/proto/alpha/reward_storage.ml | 29 +- src/proto/alpha/reward_storage.mli | 10 +- src/proto/alpha/roll_repr.ml | 16 + src/proto/alpha/roll_repr.mli | 7 + src/proto/alpha/roll_storage.ml | 41 +- src/proto/alpha/roll_storage.mli | 22 +- src/proto/alpha/seed_repr.mli | 2 +- src/proto/alpha/seed_storage.mli | 8 +- src/proto/alpha/services_registration.ml | 7 +- src/proto/alpha/storage.ml | 765 +++++++++------------- src/proto/alpha/storage.mli | 141 ++-- src/proto/alpha/storage_functors.ml | 778 ++++++++++++----------- src/proto/alpha/storage_functors.mli | 114 +--- src/proto/alpha/storage_sigs.ml | 196 +++--- src/proto/alpha/tezos_context.ml | 32 +- src/proto/alpha/tezos_context.mli | 12 +- src/proto/alpha/vote_storage.ml | 7 +- src/proto/alpha/vote_storage.mli | 40 +- src/utils/hash.ml | 12 +- src/utils/hash.mli | 2 +- test/proto_alpha/proto_alpha_helpers.ml | 3 +- 49 files changed, 1671 insertions(+), 1960 deletions(-) delete mode 100644 src/proto/alpha/persist.ml delete mode 100644 src/proto/alpha/persist.mli create mode 100644 src/proto/alpha/raw_context.ml create mode 100644 src/proto/alpha/raw_context.mli diff --git a/src/environment/v1/context.mli b/src/environment/v1/context.mli index c3918966d..3594ad366 100644 --- a/src/environment/v1/context.mli +++ b/src/environment/v1/context.mli @@ -20,8 +20,11 @@ type value = MBytes.t val mem: t -> key -> bool Lwt.t val dir_mem: t -> key -> bool Lwt.t + val get: t -> key -> value option Lwt.t + val set: t -> key -> value -> t Lwt.t + val del: t -> key -> t Lwt.t val remove_rec: t -> key -> t Lwt.t diff --git a/src/environment/v1/hash.mli b/src/environment/v1/hash.mli index 47a4cd87b..747d4b82f 100644 --- a/src/environment/v1/hash.mli +++ b/src/environment/v1/hash.mli @@ -45,7 +45,7 @@ module type MINIMAL_HASH = sig val read: MBytes.t -> int -> t val write: MBytes.t -> int -> t -> unit - val to_path: t -> string list + val to_path: t -> string list -> string list val of_path: string list -> t option val of_path_exn: string list -> t diff --git a/src/node/db/store_helpers.ml b/src/node/db/store_helpers.ml index 7e7ace68f..a34f27493 100644 --- a/src/node/db/store_helpers.ml +++ b/src/node/db/store_helpers.ml @@ -84,8 +84,8 @@ module Make_indexed_substore (S : STORE) (I : INDEX) = struct type key = string list type value = MBytes.t let to_key i k = - assert (List.length (I.to_path i) = I.path_length) ; - I.to_path i @ k + assert (List.length (I.to_path i []) = I.path_length) ; + I.to_path i k let of_key k = Utils.remove_elem_from_list I.path_length k let known (t,i) k = S.known t (to_key i k) let known_dir (t,i) k = S.known_dir t (to_key i k) @@ -250,9 +250,9 @@ module Make_set (S : STORE) (I : INDEX) = struct type t = S.t type elt = I.t let inited = MBytes.of_string "inited" - let known s i = S.known s (I.to_path i) - let store s i = S.store s (I.to_path i) inited - let remove s i = S.remove s (I.to_path i) + let known s i = S.known s (I.to_path i []) + let store s i = S.store s (I.to_path i []) inited + let remove s i = S.remove s (I.to_path i []) let remove_all s = S.remove_dir s [] let fold s ~init ~f = @@ -298,9 +298,9 @@ module Make_map (S : STORE) (I : INDEX) (V : VALUE) = struct type t = S.t type key = I.t type value = V.t - let known s i = S.known s (I.to_path i) + let known s i = S.known s (I.to_path i []) let read s i = - S.read s (I.to_path i) >>=? fun b -> Lwt.return (V.of_bytes b) + S.read s (I.to_path i []) >>=? fun b -> Lwt.return (V.of_bytes b) let read_opt s i = read s i >>= function | Error _ -> Lwt.return_none @@ -309,8 +309,8 @@ module Make_map (S : STORE) (I : INDEX) (V : VALUE) = struct read s i >>= function | Error _ -> Lwt.fail Not_found | Ok v -> Lwt.return v - let store s i v = S.store s (I.to_path i) (V.to_bytes v) - let remove s i = S.remove s (I.to_path i) + let store s i v = S.store s (I.to_path i []) (V.to_bytes v) + let remove s i = S.remove s (I.to_path i []) let remove_all s = S.remove_dir s [] let fold s ~init ~f = let rec dig i path acc = @@ -375,7 +375,7 @@ end module Integer_index = struct type t = int let path_length = 1 - let to_path x = [string_of_int x] + let to_path x l = string_of_int x :: l let of_path = function | [x] -> begin try Some (int_of_string x) with _ -> None end | _ -> None diff --git a/src/node/db/store_sigs.ml b/src/node/db/store_sigs.ml index 1ff7ecbbc..da7dbe0a0 100644 --- a/src/node/db/store_sigs.ml +++ b/src/node/db/store_sigs.ml @@ -25,7 +25,7 @@ end module type INDEX = sig type t val path_length: int - val to_path: t -> string list + val to_path: t -> string list -> string list val of_path: string list -> t option end diff --git a/src/proto/alpha/TEZOS_PROTOCOL b/src/proto/alpha/TEZOS_PROTOCOL index b476a04d4..77c98364a 100644 --- a/src/proto/alpha/TEZOS_PROTOCOL +++ b/src/proto/alpha/TEZOS_PROTOCOL @@ -26,7 +26,7 @@ "Manager_repr", "Block_header_repr", - "Persist", + "Raw_context", "Storage_sigs", "Storage_functors", "Storage", diff --git a/src/proto/alpha/amendment.ml b/src/proto/alpha/amendment.ml index 3b2394c61..543af6e61 100644 --- a/src/proto/alpha/amendment.ml +++ b/src/proto/alpha/amendment.ml @@ -49,8 +49,8 @@ let check_approval_and_update_quorum ctxt = let start_new_voting_cycle ctxt = Vote.get_current_period_kind ctxt >>=? function | Proposal -> begin - Vote.get_proposals ctxt >>=? fun proposals -> - Vote.clear_proposals ctxt >>=? fun ctxt -> + Vote.get_proposals ctxt >>= fun proposals -> + Vote.clear_proposals ctxt >>= fun ctxt -> Vote.clear_listings ctxt >>=? fun ctxt -> match select_winning_proposal proposals with | None -> @@ -111,10 +111,10 @@ let record_proposals ctxt delegate proposals = | Proposal -> Vote.in_listings ctxt delegate >>= fun in_listings -> if in_listings then - fold_left_s + Lwt_list.fold_left_s (fun ctxt proposal -> Vote.record_proposal ctxt proposal delegate) - ctxt proposals + ctxt proposals >>= return else fail Unauthorized_proposal | Testing_vote | Testing | Promotion_vote -> @@ -128,7 +128,7 @@ let record_ballot ctxt delegate proposal ballot = Invalid_proposal >>=? fun () -> Vote.in_listings ctxt delegate >>= fun in_listings -> if in_listings then - Vote.record_ballot ctxt delegate ballot + Vote.record_ballot ctxt delegate ballot >>= return else fail Unauthorized_ballot | Testing | Proposal -> diff --git a/src/proto/alpha/bootstrap_storage.ml b/src/proto/alpha/bootstrap_storage.ml index 8d9cf8991..bb85078a6 100644 --- a/src/proto/alpha/bootstrap_storage.ml +++ b/src/proto/alpha/bootstrap_storage.ml @@ -29,7 +29,7 @@ let make public_key = { public_key ; public_key_hash = Ed25519.Public_key.hash public_key } let accounts ctxt = - let { Constants_repr.bootstrap_keys } = Storage.constants ctxt in + let { Constants_repr.bootstrap_keys } = Raw_context.constants ctxt in List.map make bootstrap_keys let init ctxt = @@ -49,7 +49,7 @@ let account_encoding = let refill ctxt = (* Unefficient HACK for the alphanet only... *) - Contract_storage.list ctxt >>=? fun contracts -> + Contract_storage.list ctxt >>= fun contracts -> List.fold_left (fun total contract -> Contract_storage.get_balance ctxt contract >>=? fun balance -> diff --git a/src/proto/alpha/bootstrap_storage.mli b/src/proto/alpha/bootstrap_storage.mli index c2db6a87e..0c916d474 100644 --- a/src/proto/alpha/bootstrap_storage.mli +++ b/src/proto/alpha/bootstrap_storage.mli @@ -14,8 +14,8 @@ type account = { val account_encoding: account Data_encoding.t -val accounts: Storage.t -> account list +val accounts: Raw_context.t -> account list -val init: Storage.t -> Storage.t tzresult Lwt.t +val init: Raw_context.t -> Raw_context.t tzresult Lwt.t -val refill: Storage.t -> Storage.t tzresult Lwt.t +val refill: Raw_context.t -> Raw_context.t tzresult Lwt.t diff --git a/src/proto/alpha/contract_repr.ml b/src/proto/alpha/contract_repr.ml index 069d7bd36..fdbe32b87 100644 --- a/src/proto/alpha/contract_repr.ml +++ b/src/proto/alpha/contract_repr.ml @@ -148,3 +148,33 @@ let (<=) l1 l2 = Compare.Int.(<=) (compare l1 l2) 0 let (<) l1 l2 = Compare.Int.(<) (compare l1 l2) 0 let min l1 l2 = if l1 <= l2 then l1 else l2 let max l1 l2 = if l1 >= l2 then l1 else l2 + +module Index = struct + type t = contract + let path_length = + assert Compare.Int.(Ed25519.Public_key_hash.path_length = + Contract_hash.path_length) ; + Ed25519.Public_key_hash.path_length + 1 + let to_path c l = + match c with + | Default k -> + "pubkey" :: Ed25519.Public_key_hash.to_path k l + | Originated h -> + "originated" :: Contract_hash.to_path h l + let of_path = function + | "pubkey" :: key -> begin + match Ed25519.Public_key_hash.of_path key with + | None -> None + | Some h -> Some (Default h) + end + | "originated" :: key -> begin + match Contract_hash.of_path key with + | None -> None + | Some h -> Some (Originated h) + end + | _ -> None + let contract_prefix s = + "originated" :: Contract_hash.prefix_path s + let pkh_prefix s = + "pubkey" :: Ed25519.Public_key_hash.prefix_path s +end diff --git a/src/proto/alpha/contract_repr.mli b/src/proto/alpha/contract_repr.mli index 1c97e34de..8dd71330b 100644 --- a/src/proto/alpha/contract_repr.mli +++ b/src/proto/alpha/contract_repr.mli @@ -59,3 +59,12 @@ val encoding : contract Data_encoding.t val origination_nonce_encoding : origination_nonce Data_encoding.t val arg : contract RPC.Arg.arg + +module Index : sig + type t = contract + val path_length: int + val to_path: t -> string list -> string list + val of_path: string list -> t option + val contract_prefix: string -> string list + val pkh_prefix: string -> string list +end diff --git a/src/proto/alpha/contract_storage.ml b/src/proto/alpha/contract_storage.ml index 3e82e3971..ad9b5690d 100644 --- a/src/proto/alpha/contract_storage.ml +++ b/src/proto/alpha/contract_storage.ml @@ -210,8 +210,7 @@ let create_base c contract ~balance ~manager ~delegate ?script ~spendable ~deleg return c) >>=? fun c -> Roll_storage.Contract.init c contract >>=? fun c -> Roll_storage.Contract.add_amount c contract balance >>=? fun c -> - Storage.Contract.Set.add c contract >>=? fun c -> - Lwt.return (Ok (c, contract)) + return (c, contract) let create c nonce ~balance ~manager ~delegate ?script ~spendable ~delegatable = let contract = Contract_repr.originated_contract nonce in @@ -238,7 +237,7 @@ let delete c contract = Storage.Contract.Storage.remove c contract >>= fun c -> Storage.Contract.Code_fees.remove c contract >>= fun c -> Storage.Contract.Storage_fees.remove c contract >>= fun c -> - Storage.Contract.Set.del c contract + return c let exists c contract = match Contract_repr.is_default contract with @@ -253,8 +252,7 @@ let must_exist c contract = | true -> return () | false -> fail (Non_existing_contract contract) -let list c = - Storage.Contract.Set.elements c +let list c = Storage.Contract.list c let check_counter_increment c contract counter = Storage.Contract.Counter.get c contract >>=? fun contract_counter -> @@ -360,7 +358,8 @@ let set_delegate c contract delegate = Storage.Contract.Delegate.remove c contract >>= fun c -> return c | Some delegate -> - Storage.Contract.Delegate.init_set c contract delegate + Storage.Contract.Delegate.init_set c contract delegate >>= fun c -> + return c let contract_fee c contract = Storage.Contract.Code_fees.get_option c contract >>=? fun code_fees -> diff --git a/src/proto/alpha/contract_storage.mli b/src/proto/alpha/contract_storage.mli index 27452a953..4507450a1 100644 --- a/src/proto/alpha/contract_storage.mli +++ b/src/proto/alpha/contract_storage.mli @@ -21,46 +21,46 @@ type error += | Missing_public_key of Ed25519.Public_key_hash.t (* `Permanent *) | Failure of string (* `Permanent *) -val delete : Storage.t -> Contract_repr.t -> Storage.t tzresult Lwt.t +val delete : Raw_context.t -> Contract_repr.t -> Raw_context.t tzresult Lwt.t -val exists: Storage.t -> Contract_repr.t -> bool tzresult Lwt.t -val must_exist: Storage.t -> Contract_repr.t -> unit tzresult Lwt.t +val exists: Raw_context.t -> Contract_repr.t -> bool tzresult Lwt.t +val must_exist: Raw_context.t -> Contract_repr.t -> unit tzresult Lwt.t -val list: Storage.t -> Contract_repr.t list tzresult Lwt.t +val list: Raw_context.t -> Contract_repr.t list Lwt.t -val check_counter_increment: Storage.t -> Contract_repr.t -> int32 -> unit tzresult Lwt.t -val increment_counter: Storage.t -> Contract_repr.t -> Storage.t tzresult Lwt.t +val check_counter_increment: Raw_context.t -> Contract_repr.t -> int32 -> unit tzresult Lwt.t +val increment_counter: Raw_context.t -> Contract_repr.t -> Raw_context.t tzresult Lwt.t -val is_delegatable : Storage.t -> Contract_repr.t -> bool tzresult Lwt.t -val is_spendable : Storage.t -> Contract_repr.t -> bool tzresult Lwt.t +val is_delegatable : Raw_context.t -> Contract_repr.t -> bool tzresult Lwt.t +val is_spendable : Raw_context.t -> Contract_repr.t -> bool tzresult Lwt.t -val get_manager: Storage.t -> Contract_repr.t -> Ed25519.Public_key_hash.t tzresult Lwt.t +val get_manager: Raw_context.t -> Contract_repr.t -> Ed25519.Public_key_hash.t tzresult Lwt.t val update_manager_key: - Storage.t -> Contract_repr.t -> Ed25519.Public_key.t option -> - (Storage.t * Ed25519.Public_key.t) tzresult Lwt.t + Raw_context.t -> Contract_repr.t -> Ed25519.Public_key.t option -> + (Raw_context.t * Ed25519.Public_key.t) tzresult Lwt.t -val get_delegate_opt: Storage.t -> Contract_repr.t -> Ed25519.Public_key_hash.t option tzresult Lwt.t -val get_balance: Storage.t -> Contract_repr.t -> Tez_repr.t tzresult Lwt.t -val get_counter: Storage.t -> Contract_repr.t -> int32 tzresult Lwt.t +val get_delegate_opt: Raw_context.t -> Contract_repr.t -> Ed25519.Public_key_hash.t option tzresult Lwt.t +val get_balance: Raw_context.t -> Contract_repr.t -> Tez_repr.t tzresult Lwt.t +val get_counter: Raw_context.t -> Contract_repr.t -> int32 tzresult Lwt.t -val get_script: Storage.t -> Contract_repr.t -> Script_repr.t option tzresult Lwt.t -val get_storage: Storage.t -> Contract_repr.t -> Script_repr.expr option tzresult Lwt.t +val get_script: Raw_context.t -> Contract_repr.t -> Script_repr.t option tzresult Lwt.t +val get_storage: Raw_context.t -> Contract_repr.t -> Script_repr.expr option tzresult Lwt.t -val update_script_storage_and_fees: Storage.t -> Contract_repr.t -> Tez_repr.t -> Script_repr.expr -> Storage.t tzresult Lwt.t +val update_script_storage_and_fees: Raw_context.t -> Contract_repr.t -> Tez_repr.t -> Script_repr.expr -> Raw_context.t tzresult Lwt.t (** fails if the contract is not delegatable *) -val set_delegate : Storage.t -> Contract_repr.t -> Ed25519.Public_key_hash.t option -> Storage.t tzresult Lwt.t +val set_delegate : Raw_context.t -> Contract_repr.t -> Ed25519.Public_key_hash.t option -> Raw_context.t tzresult Lwt.t -val credit : Storage.t -> Contract_repr.t -> Tez_repr.t -> Storage.t tzresult Lwt.t +val credit : Raw_context.t -> Contract_repr.t -> Tez_repr.t -> Raw_context.t tzresult Lwt.t (** checks that the contract is spendable and decrease_balance *) -val spend : Storage.t -> Contract_repr.t -> Tez_repr.t -> Storage.t tzresult Lwt.t +val spend : Raw_context.t -> Contract_repr.t -> Tez_repr.t -> Raw_context.t tzresult Lwt.t (** decrease_balance even if the contract is not spendable *) -val spend_from_script : Storage.t -> Contract_repr.t -> Tez_repr.t -> Storage.t tzresult Lwt.t +val spend_from_script : Raw_context.t -> Contract_repr.t -> Tez_repr.t -> Raw_context.t tzresult Lwt.t val originate : - Storage.t -> + Raw_context.t -> Contract_repr.origination_nonce -> balance:Tez_repr.t -> manager:Ed25519.Public_key_hash.t -> @@ -68,7 +68,7 @@ val originate : delegate:Ed25519.Public_key_hash.t option -> spendable:bool -> delegatable:bool -> - (Storage.t * Contract_repr.t * Contract_repr.origination_nonce) tzresult Lwt.t + (Raw_context.t * Contract_repr.t * Contract_repr.origination_nonce) tzresult Lwt.t val init : - Storage.t -> Storage.t tzresult Lwt.t + Raw_context.t -> Raw_context.t tzresult Lwt.t diff --git a/src/proto/alpha/cycle_repr.ml b/src/proto/alpha/cycle_repr.ml index 35515f6df..603515fa7 100644 --- a/src/proto/alpha/cycle_repr.ml +++ b/src/proto/alpha/cycle_repr.ml @@ -40,3 +40,16 @@ let of_int32_exn l = if Compare.Int32.(l >= 0l) then l else invalid_arg "Level_repr.Cycle.of_int32" + +module Index = struct + type t = cycle + let path_length = 1 + let to_path c l = + Int32.to_string (to_int32 c) :: l + let of_path = function + | [s] -> begin + try Some (Int32.of_string s) + with _ -> None + end + | _ -> None +end diff --git a/src/proto/alpha/cycle_repr.mli b/src/proto/alpha/cycle_repr.mli index 8ef99b3c8..6cbbd5a3e 100644 --- a/src/proto/alpha/cycle_repr.mli +++ b/src/proto/alpha/cycle_repr.mli @@ -20,3 +20,11 @@ val succ: cycle -> cycle val to_int32: cycle -> int32 val of_int32_exn: int32 -> cycle + +module Index : sig + (* Storage_functors.INDEX with type t = cycle *) + type t = cycle + val path_length: int + val to_path: t -> string list -> string list + val of_path: string list -> t option +end diff --git a/src/proto/alpha/fitness_storage.ml b/src/proto/alpha/fitness_storage.ml index d2b89f27d..f2348c99a 100644 --- a/src/proto/alpha/fitness_storage.ml +++ b/src/proto/alpha/fitness_storage.ml @@ -7,7 +7,7 @@ (* *) (**************************************************************************) -let current = Storage.current_fitness +let current = Raw_context.current_fitness let increase ctxt = let fitness = current ctxt in - Storage.set_current_fitness ctxt (Int64.succ fitness) + Raw_context.set_current_fitness ctxt (Int64.succ fitness) diff --git a/src/proto/alpha/init_storage.ml b/src/proto/alpha/init_storage.ml index b4cee9b23..5bb97ab9a 100644 --- a/src/proto/alpha/init_storage.ml +++ b/src/proto/alpha/init_storage.ml @@ -21,30 +21,10 @@ let initialize store = Vote_storage.init store >>=? fun store -> return store -type error += - | Unimplemented_sandbox_migration - let may_initialize ctxt ~level ~timestamp ~fitness = - Storage.prepare ~level ~timestamp ~fitness ctxt >>=? fun (ctxt, first_block) -> + Raw_context.prepare + ~level ~timestamp ~fitness ctxt >>=? fun (ctxt, first_block) -> if first_block then initialize ctxt else return ctxt - -let configure_sandbox ctxt json = - let json = - match json with - | None -> `O [] - | Some json -> json in - Storage.is_first_block ctxt >>=? function - | true -> - Storage.set_sandboxed ctxt json >>= fun ctxt -> - return ctxt - | false -> - Storage.get_sandboxed ctxt >>=? function - | None -> - fail Unimplemented_sandbox_migration - | Some _ -> - (* FIXME GRGR fail if parameter changed! *) - (* failwith "Changing sandbox parameter is not yet implemented" *) - return ctxt diff --git a/src/proto/alpha/level_repr.ml b/src/proto/alpha/level_repr.ml index be990226a..c244d2d44 100644 --- a/src/proto/alpha/level_repr.ml +++ b/src/proto/alpha/level_repr.ml @@ -89,3 +89,4 @@ let (<=) { level = l1 } { level = l2 } = Raw_level_repr.(<=) l1 l2 let (<) { level = l1 } { level = l2 } = Raw_level_repr.(<) l1 l2 let min l1 l2 = if l1 <= l2 then l1 else l2 let max l1 l2 = if l1 >= l2 then l1 else l2 + diff --git a/src/proto/alpha/level_storage.ml b/src/proto/alpha/level_storage.ml index 0fd18d77c..0e02fdc0d 100644 --- a/src/proto/alpha/level_storage.ml +++ b/src/proto/alpha/level_storage.ml @@ -14,8 +14,8 @@ let from_raw c ?offset l = match offset with | None -> l | Some o -> Raw_level_repr.(of_int32_exn (Int32.add (to_int32 l) o)) in - let constants = Storage.constants c in - let first_level = Storage.first_level c in + let constants = Raw_context.constants c in + let first_level = Raw_context.first_level c in Level_repr.from_raw ~first_level ~cycle_length:constants.Constants_repr.cycle_length @@ -23,7 +23,7 @@ let from_raw c ?offset l = l let root c = - Level_repr.root (Storage.first_level c) + Level_repr.root (Raw_context.first_level c) let succ c l = from_raw c (Raw_level_repr.succ l.level) let pred c l = @@ -31,7 +31,7 @@ let pred c l = | None -> None | Some l -> Some (from_raw c l) -let current ctxt = Storage.current_level ctxt +let current ctxt = Raw_context.current_level ctxt let previous ctxt = let l = current ctxt in @@ -40,8 +40,8 @@ let previous ctxt = | Some p -> p let first_level_in_cycle ctxt c = - let constants = Storage.constants ctxt in - let first_level = Storage.first_level ctxt in + let constants = Raw_context.constants ctxt in + let first_level = Raw_context.first_level ctxt in from_raw ctxt (Raw_level_repr.of_int32_exn (Int32.add diff --git a/src/proto/alpha/level_storage.mli b/src/proto/alpha/level_storage.mli index dbef2cbfb..4eb1c7cc2 100644 --- a/src/proto/alpha/level_storage.mli +++ b/src/proto/alpha/level_storage.mli @@ -7,14 +7,14 @@ (* *) (**************************************************************************) -val current: Storage.t -> Level_repr.t -val previous: Storage.t -> Level_repr.t +val current: Raw_context.t -> Level_repr.t +val previous: Raw_context.t -> Level_repr.t -val root: Storage.t -> Level_repr.t +val root: Raw_context.t -> Level_repr.t -val from_raw: Storage.t -> ?offset:int32 -> Raw_level_repr.t -> Level_repr.t -val pred: Storage.t -> Level_repr.t -> Level_repr.t option -val succ: Storage.t -> Level_repr.t -> Level_repr.t +val from_raw: Raw_context.t -> ?offset:int32 -> Raw_level_repr.t -> Level_repr.t +val pred: Raw_context.t -> Level_repr.t -> Level_repr.t option +val succ: Raw_context.t -> Level_repr.t -> Level_repr.t -val last_level_in_cycle: Storage.t -> Cycle_repr.t -> Level_repr.t -val levels_in_cycle: Storage.t -> Cycle_repr.t -> Level_repr.t list +val last_level_in_cycle: Raw_context.t -> Cycle_repr.t -> Level_repr.t +val levels_in_cycle: Raw_context.t -> Cycle_repr.t -> Level_repr.t list diff --git a/src/proto/alpha/nonce_storage.mli b/src/proto/alpha/nonce_storage.mli index 0d4fd40e4..c54c96aed 100644 --- a/src/proto/alpha/nonce_storage.mli +++ b/src/proto/alpha/nonce_storage.mli @@ -20,13 +20,13 @@ type nonce = t val encoding: nonce Data_encoding.t val record_hash: - Storage.t -> + Raw_context.t -> Ed25519.Public_key_hash.t -> Tez_repr.t -> - Nonce_hash.t -> Storage.t tzresult Lwt.t + Nonce_hash.t -> Raw_context.t tzresult Lwt.t val reveal: - Storage.t -> Level_repr.t -> nonce -> - (Storage.t * Ed25519.Public_key_hash.t * Tez_repr.t) tzresult Lwt.t + Raw_context.t -> Level_repr.t -> nonce -> + (Raw_context.t * Ed25519.Public_key_hash.t * Tez_repr.t) tzresult Lwt.t type status = | Unrevealed of { @@ -36,7 +36,7 @@ type status = } | Revealed of nonce -val get: Storage.t -> Level_repr.t -> status tzresult Lwt.t +val get: Raw_context.t -> Level_repr.t -> status tzresult Lwt.t val of_bytes: MBytes.t -> nonce tzresult val hash: nonce -> Nonce_hash.t diff --git a/src/proto/alpha/persist.ml b/src/proto/alpha/persist.ml deleted file mode 100644 index 82ebfe59c..000000000 --- a/src/proto/alpha/persist.ml +++ /dev/null @@ -1,422 +0,0 @@ -(**************************************************************************) -(* *) -(* Copyright (c) 2014 - 2017. *) -(* Dynamic Ledger Solutions, Inc. *) -(* *) -(* All rights reserved. No warranty, explicit or implicit, provided. *) -(* *) -(**************************************************************************) - -(* Tezos - Persistent structures on top of {!Store} or {!Context} *) - -(*-- Signatures --------------------------------------------------------------*) - -type key = string list -type value = MBytes.t - -module type STORE = sig - type t - val mem: t -> key -> bool Lwt.t - val dir_mem: t -> key -> bool Lwt.t - val get: t -> key -> value option Lwt.t - val set: t -> key -> value -> t Lwt.t - val del: t -> key -> t Lwt.t - val remove_rec: t -> key -> t Lwt.t - val fold: - t -> key -> init:'a -> - f:([ `Key of key | `Dir of key ] -> 'a -> 'a Lwt.t) -> - 'a Lwt.t - val keys: t -> key -> key list Lwt.t - val fold_keys: - t -> key -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t -end - -module type BYTES_STORE = sig - type t - type key - val mem: t -> key -> bool Lwt.t - val get: t -> key -> value option Lwt.t - val set: t -> key -> value -> t Lwt.t - val del: t -> key -> t Lwt.t - val remove_rec: t -> key -> t Lwt.t -end - -module type TYPED_STORE = sig - type t - type key - type value - val mem: t -> key -> bool Lwt.t - val get: t -> key -> value option Lwt.t - val set: t -> key -> value -> t Lwt.t - val del: t -> key -> t Lwt.t -end - -module type KEY = sig - type t - val prefix: key - val length: int - val to_path: t -> key - val of_path: key -> t - val compare: t -> t -> int -end - -module type VALUE = sig - type t - val of_bytes: value -> t option - val to_bytes: t -> value -end - -module type PERSISTENT_SET = sig - type t and key - val mem : t -> key -> bool Lwt.t - val set : t -> key -> t Lwt.t - val del : t -> key -> t Lwt.t - val elements : t -> key list Lwt.t - val clear : t -> t Lwt.t - val iter : t -> f:(key -> unit Lwt.t) -> unit Lwt.t - val fold : t -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t -end - -module type BUFFERED_PERSISTENT_SET = sig - include PERSISTENT_SET - module Set : Set.S with type elt = key - val read : t -> Set.t Lwt.t - val write : t -> Set.t -> t Lwt.t -end - -module type PERSISTENT_MAP = sig - type t and key and value - val mem : t -> key -> bool Lwt.t - val get : t -> key -> value option Lwt.t - val set : t -> key -> value -> t Lwt.t - val del : t -> key -> t Lwt.t - val bindings : t -> (key * value) list Lwt.t - val clear : t -> t Lwt.t - val iter : t -> f:(key -> value -> unit Lwt.t) -> unit Lwt.t - val fold : t -> init:'a -> f:(key -> value -> 'a -> 'a Lwt.t) -> 'a Lwt.t -end - -module type BUFFERED_PERSISTENT_MAP = sig - include PERSISTENT_MAP - module Map : Map.S with type key = key - val read : t -> value Map.t Lwt.t - val write : t -> value Map.t -> t Lwt.t -end - -(*-- Utils -------------------------------------------------------------------*) - -let prefix prf key = - prf @ key - -let unprefix prf key = - let rec eat = function - | k :: key, p :: prefix -> - assert Compare.String.(k = p) ; - eat (key, prefix) - | key, [] -> key - | _ -> assert false in - eat (key, prf) - -(*-- Typed Store Overlays ----------------------------------------------------*) - -module MakeBytesStore - (S : STORE) (K : KEY) = struct - - type t = S.t - type key = K.t - - let to_path k = - let suffix = K.to_path k in - prefix K.prefix suffix - - let mem s k = - S.mem s (to_path k) - - let get s k = - S.get s (to_path k) - - let set s k v = - S.set s (to_path k) v - - let del s k = - S.del s (to_path k) - - let remove_rec s k = - S.remove_rec s (to_path k) - -end - -module MakeTypedStore - (S : STORE) (K : KEY) (C : VALUE) = struct - - type t = S.t - type key = K.t - type value = C.t - - module S = MakeBytesStore (S) (K) - - let mem = S.mem - let get s k = - S.get s k >>= function - | None -> Lwt.return None - | Some v -> Lwt.return (C.of_bytes v) - let set s k v = S.set s k (C.to_bytes v) - let del = S.del - -end - -module CompareStringList = Compare.List(Compare.String) - -module RawKey = struct - type t = key - let prefix = [] - let length = 0 - let to_path p = p - let of_path p = p - let compare = CompareStringList.compare -end -module RawValue = struct - type t = value - let to_bytes b = b - let of_bytes b = Some b -end - -(*-- Set Builders ------------------------------------------------------------*) - -module MakePersistentSet - (S : STORE) (K : KEY) = struct - - let to_path k = - let suffix = K.to_path k in - assert Compare.Int.(List.length suffix = K.length) ; - prefix K.prefix suffix - - let of_path p = K.of_path (unprefix K.prefix p) - - let empty = - MBytes.of_string "" - - let inited_key = - prefix K.prefix [ "inited" ] - - let mem c k = - S.mem c (to_path k) - - let set c k = - S.set c inited_key empty >>= fun c -> - S.set c (to_path k) empty - - let del c k = - S.del c (to_path k) - - let clear c = - S.remove_rec c K.prefix - - let fold s ~init ~f = - let rec dig i path acc = - if Compare.Int.(i <= 1) then - S.fold s path ~init:acc ~f:begin fun k acc -> - match k with - | `Dir _ -> Lwt.return acc - | `Key file -> f (of_path file) acc - end - else - S.fold s path ~init:acc ~f:begin fun k acc -> - match k with - | `Dir k -> - dig (i-1) k acc - | `Key _ -> - Lwt.return acc - end in - dig K.length K.prefix init - - let iter c ~f = fold c ~init:() ~f:(fun x () -> f x) - let elements c = fold c ~init:[] ~f:(fun p xs -> Lwt.return (p :: xs)) - -end - -module MakeBufferedPersistentSet - (S : STORE) (K : KEY) (Set : Set.S with type elt = K.t) = struct - - include MakePersistentSet(S)(K) - - let read c = - fold c ~init:Set.empty ~f:(fun p set -> Lwt.return (Set.add p set)) - - let write c set = - S.set c inited_key empty >>= fun c -> - read c >>= fun old_set -> - Lwt_list.fold_left_s - (fun c h -> S.del c (to_path h)) - c Set.(elements (diff old_set set)) >>= fun c -> - Lwt_list.fold_left_s - (fun c h -> S.set c (to_path h) empty) - c Set.(elements (diff set old_set)) - -end - -(*-- Map Builders ------------------------------------------------------------*) - -module MakePersistentMap - (S : STORE) (K : KEY) (C : VALUE) = struct - - let to_path k = - let suffix = K.to_path k in - assert Compare.Int.(List.length suffix = K.length) ; - prefix K.prefix suffix - - let of_path p = K.of_path (unprefix K.prefix p) - - let empty = - MBytes.of_string "" - - let inited_key = - prefix K.prefix [ "inited" ] - - let mem c k = - S.mem c (to_path k) - - let get c k = - S.get c (to_path k) >|= function - | None -> None - | Some b -> C.of_bytes b - - let set c k b = - S.set c inited_key empty >>= fun c -> - S.set c (to_path k) (C.to_bytes b) - - let del c k = - S.del c (to_path k) - - let clear c = - S.remove_rec c K.prefix - - let fold s ~init ~f = - let rec dig i path acc = - if Compare.Int.(i <= 1) then - S.fold s path ~init:acc ~f:begin fun k acc -> - match k with - | `Dir _ -> Lwt.return acc - | `Key file -> - S.get s file >>= function - | None -> Lwt.return acc - | Some b -> - match C.of_bytes b with - | None -> - (* Silently ignore unparsable data *) - Lwt.return acc - | Some v -> f (of_path file) v acc - end - else - S.fold s path ~init:acc ~f:begin fun k acc -> - match k with - | `Dir k -> dig (i-1) k acc - | `Key _ -> Lwt.return acc - end in - dig K.length K.prefix init - - let iter c ~f = fold c ~init:() ~f:(fun k v () -> f k v) - let bindings c = fold c ~init:[] ~f:(fun k v acc -> Lwt.return ((k, v) :: acc)) - -end - -module MakeBufferedPersistentMap - (S : STORE) (K : KEY) (C : VALUE) (Map : Map.S with type key = K.t) = struct - - include MakePersistentMap(S)(K)(C) - - let read c = fold c ~init:Map.empty ~f:(fun k v m -> Lwt.return (Map.add k v m)) - - let write c m = - clear c >>= fun c -> - S.set c inited_key empty >>= fun c -> - Lwt_list.fold_left_s - (fun c (k, b) -> S.set c (to_path k) (C.to_bytes b)) - c (Map.bindings m) - -end - -(*-- Predefined Instances ----------------------------------------------------*) - -module MBytesValue = struct - type t = MBytes.t - let of_bytes x = Some x - let to_bytes x = x -end - -module MakePersistentBytesMap - (S : STORE) (K : KEY) = - MakePersistentMap(S)(K)(MBytesValue) - -module MakeBufferedPersistentBytesMap - (S : STORE) (K : KEY) (Map : Map.S with type key = K.t) = - MakeBufferedPersistentMap(S)(K)(MBytesValue)(Map) - -module type TYPED_VALUE_REPR = sig - type value - val encoding: value Data_encoding.t -end - -module TypedValue (T : TYPED_VALUE_REPR) = struct - type t = T.value - let of_bytes x = Data_encoding.Binary.of_bytes T.encoding x - let to_bytes x = Data_encoding.Binary.to_bytes T.encoding x -end - -module MakePersistentTypedMap - (S : STORE) (K : KEY) - (T : TYPED_VALUE_REPR) = - MakePersistentMap(S)(K)(TypedValue(T)) - -module MakeBufferedPersistentTypedMap - (S : STORE) - (K : KEY) - (T : TYPED_VALUE_REPR) - (Map : Map.S with type key = K.t) - = - MakeBufferedPersistentMap(S)(K)(TypedValue(T))(Map) - -module MakeHashResolver - (Store : sig - type t - val dir_mem: t -> string list -> bool Lwt.t - val fold: - t -> key -> init:'a -> - f:([ `Key of key | `Dir of key ] -> 'a -> 'a Lwt.t) -> - 'a Lwt.t - val prefix: string list - end) - (H: HASH) = struct - let plen = List.length Store.prefix - let build path = - H.of_path_exn @@ - Misc.remove_elem_from_list plen path - let list t k = - Store.fold t k ~init:[] ~f:(fun k acc -> Lwt.return (k :: acc)) - let resolve t p = - let rec loop prefix = function - | [] -> - list t prefix >>= fun prefixes -> - Lwt_list.map_p (function - | `Key prefix | `Dir prefix -> loop prefix []) prefixes - >|= List.flatten - | "" :: ds -> - list t prefix >>= fun prefixes -> - Lwt_list.map_p (function - | `Key prefix | `Dir prefix -> loop prefix ds) prefixes - >|= List.flatten - | [d] -> - list t prefix >>= fun prefixes -> - Lwt_list.filter_map_p (function - | `Dir _ -> Lwt.return_none - | `Key prefix -> - match Misc.remove_prefix ~prefix:d (List.hd (List.rev prefix)) with - | None -> Lwt.return_none - | Some _ -> Lwt.return (Some (build prefix)) - ) prefixes - | d :: ds -> - Store.dir_mem t (prefix @ [d]) >>= function - | true -> loop (prefix @ [d]) ds - | false -> Lwt.return_nil in - loop Store.prefix (H.prefix_path p) -end diff --git a/src/proto/alpha/persist.mli b/src/proto/alpha/persist.mli deleted file mode 100644 index 51c238e23..000000000 --- a/src/proto/alpha/persist.mli +++ /dev/null @@ -1,218 +0,0 @@ -(**************************************************************************) -(* *) -(* Copyright (c) 2014 - 2017. *) -(* Dynamic Ledger Solutions, Inc. *) -(* *) -(* All rights reserved. No warranty, explicit or implicit, provided. *) -(* *) -(**************************************************************************) - -(** Tezos - Persistent structures on top of {!Store} or {!Context} *) - -(** Keys in (kex x value) database implementations *) -type key = string list - -(** Values in (kex x value) database implementations *) -type value = MBytes.t - -(** Low level view over a (key x value) database implementation. *) -module type STORE = sig - type t - val mem: t -> key -> bool Lwt.t - val dir_mem: t -> key -> bool Lwt.t - val get: t -> key -> value option Lwt.t - val set: t -> key -> value -> t Lwt.t - val del: t -> key -> t Lwt.t - val remove_rec: t -> key -> t Lwt.t - val fold: - t -> key -> init:'a -> - f:([ `Key of key | `Dir of key ] -> 'a -> 'a Lwt.t) -> - 'a Lwt.t - val keys: t -> key -> key list Lwt.t - val fold_keys: - t -> key -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t -end - -(** Projection of OCaml keys of some abstract type to concrete storage - keys. For practical reasons, all such keys must fall under a same - {!prefix} and have the same relative {!length}. Functions - {!to_path} and {!of_path} only take the relative part into account - (the prefix is added and removed when needed). *) -module type KEY = sig - type t - val prefix: key - val length: int - val to_path: t -> key - val of_path: key -> t - val compare: t -> t -> int -end - -(** A KEY instance for using raw implementation paths as keys *) -module RawKey : KEY with type t = key - -(** Projection of OCaml values of some abstract type to concrete - storage data. *) -module type VALUE = sig - type t - val of_bytes: value -> t option - val to_bytes: t -> value -end - -(** A VALUE instance for using the raw bytes values *) -module RawValue : VALUE with type t = value - -module type BYTES_STORE = sig - type t - type key - val mem: t -> key -> bool Lwt.t - val get: t -> key -> value option Lwt.t - val set: t -> key -> value -> t Lwt.t - val del: t -> key -> t Lwt.t - val remove_rec: t -> key -> t Lwt.t -end - -module MakeBytesStore (S : STORE) (K : KEY) : - BYTES_STORE with type t = S.t and type key = K.t - -(** {2 Typed Store Overlays} *************************************************) - -(** Signature of a typed store as returned by {!MakecoTypedStore} *) -module type TYPED_STORE = sig - type t - type key - type value - val mem: t -> key -> bool Lwt.t - val get: t -> key -> value option Lwt.t - val set: t -> key -> value -> t Lwt.t - val del: t -> key -> t Lwt.t -end - -(** Gives a typed view of a store (values of a given type stored under - keys of a given type). The view is also restricted to a prefix, - (which can be empty). For all primitives to work as expected, all - keys under this prefix must be homogeneously typed. *) -module MakeTypedStore (S : STORE) (K : KEY) (C : VALUE) : - TYPED_STORE with type t = S.t and type key = K.t and type value = C.t - -(** {2 Persistent Sets} ******************************************************) - -(** Signature of a set as returned by {!MakePersistentSet} *) -module type PERSISTENT_SET = sig - type t and key - val mem : t -> key -> bool Lwt.t - val set : t -> key -> t Lwt.t - val del : t -> key -> t Lwt.t - val elements : t -> key list Lwt.t - val clear : t -> t Lwt.t - val iter : t -> f:(key -> unit Lwt.t) -> unit Lwt.t - val fold : t -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t -end - -(** Signature of a buffered set as returned by {!MakeBufferedPersistentSet} *) -module type BUFFERED_PERSISTENT_SET = sig - include PERSISTENT_SET - module Set : Set.S with type elt = key - val read : t -> Set.t Lwt.t - val write : t -> Set.t -> t Lwt.t -end - -(** Build a set in the (key x value) storage by encoding elements as - keys and using the association of (any) data to these keys as - membership. For this to work, the prefix passed must be reserved - for the set (every key under it is considered a member). *) -module MakePersistentSet (S : STORE) (K : KEY) - : PERSISTENT_SET with type t := S.t and type key := K.t - -(** Same as {!MakePersistentSet} but also provides a way to use an - OCaml set as an explicitly synchronized in-memory buffer. *) -module MakeBufferedPersistentSet - (S : STORE) (K : KEY) (Set : Set.S with type elt = K.t) - : BUFFERED_PERSISTENT_SET - with type t := S.t - and type key := K.t - and module Set := Set - -(** {2 Persistent Maps} ******************************************************) - -(** Signature of a map as returned by {!MakePersistentMap} *) -module type PERSISTENT_MAP = sig - type t and key and value - val mem : t -> key -> bool Lwt.t - val get : t -> key -> value option Lwt.t - val set : t -> key -> value -> t Lwt.t - val del : t -> key -> t Lwt.t - val bindings : t -> (key * value) list Lwt.t - val clear : t -> t Lwt.t - val iter : t -> f:(key -> value -> unit Lwt.t) -> unit Lwt.t - val fold : t -> init:'a -> f:(key -> value -> 'a -> 'a Lwt.t) -> 'a Lwt.t -end - -(** Signature of a buffered map as returned by {!MakeBufferedPersistentMap} *) -module type BUFFERED_PERSISTENT_MAP = sig - include PERSISTENT_MAP - module Map : Map.S with type key = key - val read : t -> value Map.t Lwt.t - val write : t -> value Map.t -> t Lwt.t -end - -(** Build a map in the (key x value) storage. For this to work, the - prefix passed must be reserved for the map (every key under it is - considered the key of a binding). *) -module MakePersistentMap (S : STORE) (K : KEY) (C : VALUE) - : PERSISTENT_MAP - with type t := S.t and type key := K.t and type value := C.t - -(** Same as {!MakePersistentMap} but also provides a way to use an - OCaml map as an explicitly synchronized in-memory buffer. *) -module MakeBufferedPersistentMap - (S : STORE) (K : KEY) (C : VALUE) (Map : Map.S with type key = K.t) - : BUFFERED_PERSISTENT_MAP - with type t := S.t - and type key := K.t - and type value := C.t - and module Map := Map - -(** {2 Predefined Instances} *************************************************) - -module MakePersistentBytesMap (S : STORE) (K : KEY) - : PERSISTENT_MAP - with type t := S.t and type key := K.t and type value := MBytes.t - -module MakeBufferedPersistentBytesMap - (S : STORE) (K : KEY) (Map : Map.S with type key = K.t) - : BUFFERED_PERSISTENT_MAP - with type t := S.t - and type key := K.t - and type value := MBytes.t - and module Map := Map - -module type TYPED_VALUE_REPR = sig - type value - val encoding: value Data_encoding.t -end - -module MakePersistentTypedMap (S : STORE) (K : KEY) (T : TYPED_VALUE_REPR) - : PERSISTENT_MAP - with type t := S.t and type key := K.t and type value := T.value - -module MakeBufferedPersistentTypedMap - (S : STORE) (K : KEY) (T : TYPED_VALUE_REPR) (Map : Map.S with type key = K.t) - : BUFFERED_PERSISTENT_MAP - with type t := S.t - and type key := K.t - and type value := T.value - and module Map := Map - -module MakeHashResolver - (Store : sig - type t - val dir_mem: t -> key -> bool Lwt.t - val fold: - t -> key -> init:'a -> - f:([ `Key of key | `Dir of key ] -> 'a -> 'a Lwt.t) -> - 'a Lwt.t - val prefix: string list - end) - (H: Hash.HASH) : sig - val resolve : Store.t -> string -> H.t list Lwt.t -end diff --git a/src/proto/alpha/public_key_storage.ml b/src/proto/alpha/public_key_storage.ml index 85e78c0a1..6d0751c47 100644 --- a/src/proto/alpha/public_key_storage.ml +++ b/src/proto/alpha/public_key_storage.ml @@ -36,13 +36,15 @@ let get_option = Storage.Public_key.get_option let reveal c hash key = let actual_hash = Ed25519.Public_key.hash key in if Ed25519.Public_key_hash.equal hash actual_hash then - Storage.Public_key.init_set c hash key + Storage.Public_key.init_set c hash key >>= return else fail (Inconsistent_hash (key, actual_hash, hash)) let remove = Storage.Public_key.remove let list ctxt = - Storage.Public_key.fold ctxt [] ~f:(fun pk_h pk acc -> - Lwt.return @@ (pk_h, pk) :: acc) >>= fun res -> - return res + Storage.Public_key.fold ctxt + ~init:[] + ~f:begin fun pk_h pk acc -> + Lwt.return @@ (pk_h, pk) :: acc + end diff --git a/src/proto/alpha/public_key_storage.mli b/src/proto/alpha/public_key_storage.mli index 58ce32b79..709193be4 100644 --- a/src/proto/alpha/public_key_storage.mli +++ b/src/proto/alpha/public_key_storage.mli @@ -12,13 +12,13 @@ open Ed25519 type error += Inconsistent_hash of Public_key.t * Public_key_hash.t * Public_key_hash.t val get: - Storage.t -> Public_key_hash.t -> Public_key.t tzresult Lwt.t + Raw_context.t -> Public_key_hash.t -> Public_key.t tzresult Lwt.t val get_option: - Storage.t -> Public_key_hash.t -> Public_key.t option tzresult Lwt.t + Raw_context.t -> Public_key_hash.t -> Public_key.t option tzresult Lwt.t val reveal: - Storage.t -> Public_key_hash.t -> Public_key.t -> Storage.t tzresult Lwt.t + Raw_context.t -> Public_key_hash.t -> Public_key.t -> Raw_context.t tzresult Lwt.t val remove: - Storage.t -> Public_key_hash.t -> Storage.t Lwt.t + Raw_context.t -> Public_key_hash.t -> Raw_context.t Lwt.t val list: - Storage.t -> (Public_key_hash.t * Public_key.t) list tzresult Lwt.t + Raw_context.t -> (Public_key_hash.t * Public_key.t) list Lwt.t diff --git a/src/proto/alpha/raw_context.ml b/src/proto/alpha/raw_context.ml new file mode 100644 index 000000000..53e52a24f --- /dev/null +++ b/src/proto/alpha/raw_context.ml @@ -0,0 +1,339 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type t = { + context: Context.t ; + constants: Constants_repr.constants ; + first_level: Raw_level_repr.t ; + level: Level_repr.t ; + timestamp: Time.t ; + fitness: Int64.t ; +} +type context = t +type root_context = t + +let current_level ctxt = ctxt.level +let current_timestamp ctxt = ctxt.timestamp +let current_fitness ctxt = ctxt.fitness +let first_level ctxt = ctxt.first_level +let constants ctxt = ctxt.constants +let recover ctxt = ctxt.context + +let set_current_fitness ctxt fitness = { ctxt with fitness } + +type storage_error = + | Incompatible_protocol_version of string + | Missing_key of string list * [`Get | `Set | `Del] + | Existing_key of string list + | Corrupted_data of string list + +let storage_error_encoding = + let open Data_encoding in + union [ + case ~tag:0 + (obj1 (req "incompatible_protocol_version" string)) + (function Incompatible_protocol_version arg -> Some arg | _ -> None) + (fun arg -> Incompatible_protocol_version arg) ; + case ~tag:1 + (obj2 + (req "missing_key" (list string)) + (req "function" (string_enum ["get", `Get ; "set", `Set]))) + (function Missing_key (key, f) -> Some (key, f) | _ -> None) + (fun (key, f) -> Missing_key (key, f)) ; + case ~tag:2 + (obj1 (req "existing_key" (list string))) + (function Existing_key key -> Some key | _ -> None) + (fun key -> Existing_key key) ; + case ~tag:3 + (obj1 (req "corrupted_data" (list string))) + (function Corrupted_data key -> Some key | _ -> None) + (fun key -> Corrupted_data key) ; + ] + +let pp_storage_error ppf = function + | Incompatible_protocol_version version -> + Format.fprintf ppf + "Found a context with an unexpected version '%s'." + version + | Missing_key (key, `Get) -> + Format.fprintf ppf + "Missing key '%s'." + (String.concat "/" key) + | Missing_key (key, `Set) -> + Format.fprintf ppf + "Cannot set undefined key '%s'." + (String.concat "/" key) + | Missing_key (key, `Del) -> + Format.fprintf ppf + "Cannot delete undefined key '%s'." + (String.concat "/" key) + | Existing_key key -> + Format.fprintf ppf + "Cannot initialize defined key '%s'." + (String.concat "/" key) + | Corrupted_data key -> + Format.fprintf ppf + "Failed to parse the data at '%s'." + (String.concat "/" key) + +type error += Storage_error of storage_error + +let () = + register_error_kind + `Permanent + ~id:"context.storage_error" + ~title: "Storage error (fatal internal error)" + ~description: + "An error that should never happen unless something \ + has been deleted or corrupted in the database." + ~pp:(fun ppf err -> + Format.fprintf ppf + "@[Storage error:@ %a@]" + pp_storage_error err) + storage_error_encoding + (function Storage_error err -> Some err | _ -> None) + (fun err -> Storage_error err) + +let storage_error err = fail (Storage_error err) + +(* Initialization *********************************************************) + +(* This key should always be populated for every version of the + protocol. It's absence meaning that the context is empty. *) +let version_key = ["version"] +let version_value = "alpha" + +let is_first_block ctxt = + Context.get ctxt version_key >>= function + | None -> + return true + | Some bytes -> + let s = MBytes.to_string bytes in + if Compare.String.(s = version_value) then + return false + else if Compare.String.(s = "genesis") then + return true + else + storage_error (Incompatible_protocol_version s) + +let version = "v1" +let first_level_key = [ version ; "first_level" ] +let sandboxed_key = [ version ; "sandboxed" ] + +let get_first_level ctxt = + Context.get ctxt first_level_key >>= function + | None -> storage_error (Missing_key (first_level_key, `Get)) + | Some bytes -> + match + Data_encoding.Binary.of_bytes Raw_level_repr.encoding bytes + with + | None -> storage_error (Corrupted_data first_level_key) + | Some level -> return level + +let set_first_level ctxt level = + let bytes = + Data_encoding.Binary.to_bytes Raw_level_repr.encoding level in + Context.set ctxt first_level_key bytes >>= fun ctxt -> + return ctxt + +type error += Failed_to_parse_sandbox_parameter of MBytes.t + +let () = + register_error_kind + `Temporary + ~id:"context.failed_to_parse_sandbox_parameter" + ~title: "Failed to parse sandbox parameter" + ~description: + "The sandbox paramater is not a valid JSON string." + ~pp:begin fun ppf bytes -> + Format.fprintf ppf + "@[Cannot parse the sandbox parameter:@ %s@]" + (MBytes.to_string bytes) + end + Data_encoding.(obj1 (req "contents" bytes)) + (function Failed_to_parse_sandbox_parameter data -> Some data | _ -> None) + (fun data -> Failed_to_parse_sandbox_parameter data) + +let get_sandboxed c = + Context.get c sandboxed_key >>= function + | None -> return None + | Some bytes -> + match Data_encoding.Binary.of_bytes Data_encoding.json bytes with + | None -> fail (Failed_to_parse_sandbox_parameter bytes) + | Some json -> return (Some json) + +let set_sandboxed c json = + Context.set c sandboxed_key + (Data_encoding.Binary.to_bytes Data_encoding.json json) + +let may_tag_first_block ctxt level = + is_first_block ctxt >>=? function + | false -> + get_first_level ctxt >>=? fun level -> + return (ctxt, false, level) + | true -> + Context.set ctxt version_key + (MBytes.of_string version_value) >>= fun ctxt -> + set_first_level ctxt level >>=? fun ctxt -> + return (ctxt, true, level) + +let prepare ~level ~timestamp ~fitness ctxt = + Lwt.return (Raw_level_repr.of_int32 level ) >>=? fun level -> + Lwt.return (Fitness_repr.to_int64 fitness) >>=? fun fitness -> + may_tag_first_block ctxt level >>=? fun (ctxt, first_block, first_level) -> + get_sandboxed ctxt >>=? fun sandbox -> + Constants_repr.read sandbox >>=? function constants -> + let level = + Level_repr.from_raw + ~first_level + ~cycle_length:constants.Constants_repr.cycle_length + ~voting_period_length:constants.Constants_repr.voting_period_length + level in + return ({ context = ctxt ; constants ; level ; + timestamp ; fitness ; first_level}, + first_block) + +let activate ({ context = c } as s) h = + Updater.activate c h >>= fun c -> Lwt.return { s with context = c } +let fork_test_network ({ context = c } as s) protocol expiration = + Updater.fork_test_network c ~protocol ~expiration >>= fun c -> + Lwt.return { s with context = c } + +let register_resolvers enc resolve = + let resolve context str = + let faked_context = { + context ; + constants = Constants_repr.default ; + first_level = Raw_level_repr.root ; + level = Level_repr.root Raw_level_repr.root ; + timestamp = Time.of_seconds 0L ; + fitness = 0L ; + } in + resolve faked_context str in + Context.register_resolver enc resolve + +type error += Unimplemented_sandbox_migration + +let configure_sandbox ctxt json = + let json = + match json with + | None -> `O [] + | Some json -> json in + is_first_block ctxt >>=? function + | true -> + set_sandboxed ctxt json >>= fun ctxt -> + return ctxt + | false -> + get_sandboxed ctxt >>=? function + | None -> + fail Unimplemented_sandbox_migration + | Some _ -> + (* FIXME GRGR fail if parameter changed! *) + (* failwith "Changing sandbox parameter is not yet implemented" *) + return ctxt + +(* Generic context ********************************************************) + +type key = string list + +type value = MBytes.t + +module type T = sig + + type t + type context = t + + val mem: context -> key -> bool Lwt.t + val dir_mem: context -> key -> bool Lwt.t + val get: context -> key -> value tzresult Lwt.t + val get_option: context -> key -> value option Lwt.t + val init: context -> key -> value -> context tzresult Lwt.t + val set: context -> key -> value -> context tzresult Lwt.t + val init_set: context -> key -> value -> context Lwt.t + val set_option: context -> key -> value option -> context Lwt.t + val delete: context -> key -> context tzresult Lwt.t + val remove: context -> key -> context Lwt.t + val remove_rec: context -> key -> context Lwt.t + + val fold: + context -> key -> init:'a -> + f:([ `Key of key | `Dir of key ] -> 'a -> 'a Lwt.t) -> + 'a Lwt.t + + val keys: context -> key -> key list Lwt.t + + val fold_keys: + context -> key -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t + + val project: context -> root_context +end + +let mem ctxt k = Context.mem ctxt.context k +let dir_mem ctxt k = Context.dir_mem ctxt.context k + +let get ctxt k = + Context.get ctxt.context k >>= function + | None -> storage_error (Missing_key (k, `Get)) + | Some v -> return v + +let get_option ctxt k = + Context.get ctxt.context k + +(* Verify that the k is present before modifying *) +let set ctxt k v = + Context.mem ctxt.context k >>= function + | false -> storage_error (Missing_key (k, `Set)) + | true -> + Context.set ctxt.context k v >>= fun context -> + return { ctxt with context } + +(* Verify that the k is not present before inserting *) +let init ctxt k v = + Context.mem ctxt.context k >>= function + | true -> storage_error (Existing_key k) + | false -> + Context.set ctxt.context k v >>= fun context -> + return { ctxt with context } + +(* Does not verify that the key is present or not *) +let init_set ctxt k v = + Context.set ctxt.context k v >>= fun context -> + Lwt.return { ctxt with context } + +(* Verify that the key is present before deleting *) +let delete ctxt k = + Context.mem ctxt.context k >>= function + | false -> storage_error (Missing_key (k, `Del)) + | true -> + Context.del ctxt.context k >>= fun context -> + return { ctxt with context } + +(* Do not verify before deleting *) +let remove ctxt k = + Context.del ctxt.context k >>= fun context -> + Lwt.return { ctxt with context } + +let set_option ctxt k = function + | None -> remove ctxt k + | Some v -> init_set ctxt k v + +let remove_rec ctxt k = + Context.remove_rec ctxt.context k >>= fun context -> + Lwt.return { ctxt with context } + +let fold ctxt k ~init ~f = + Context.fold ctxt.context k ~init ~f + +let keys ctxt k = + Context.keys ctxt.context k + +let fold_keys ctxt k ~init ~f = + Context.fold_keys ctxt.context k ~init ~f + +let project x = x diff --git a/src/proto/alpha/raw_context.mli b/src/proto/alpha/raw_context.mli new file mode 100644 index 000000000..cc4e82ddd --- /dev/null +++ b/src/proto/alpha/raw_context.mli @@ -0,0 +1,134 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(** {1 Errors} ****************************************************************) + +(** An internal storage error that should not happen *) +type storage_error = + | Incompatible_protocol_version of string + | Missing_key of string list * [`Get | `Set | `Del] + | Existing_key of string list + | Corrupted_data of string list + +type error += Storage_error of storage_error +type error += Failed_to_parse_sandbox_parameter of MBytes.t + +val storage_error: storage_error -> 'a tzresult Lwt.t + +(** {1 Abstract Context} **************************************************) + +(** Abstract view of the context *) +type t +type context = t +type root_context = t + +(** Retrieves the state of the database and gives its abstract view. + It also returns wether this is the first block validated + with this version of the protocol. *) +val prepare: + level: Int32.t -> + timestamp: Time.t -> + fitness: Fitness.t -> + Context.t -> (context * bool) tzresult Lwt.t + +val activate: context -> Protocol_hash.t -> t Lwt.t +val fork_test_network: context -> Protocol_hash.t -> Time.t -> t Lwt.t + +val register_resolvers: + 'a Base58.encoding -> (context -> string -> 'a list Lwt.t) -> unit + +val configure_sandbox: + Context.t -> Data_encoding.json option -> Context.t tzresult Lwt.t + +(** Returns the state of the database resulting of operations on its + abstract view *) +val recover: context -> Context.t + +val current_level: context -> Level_repr.t +val current_timestamp: context -> Time.t + +val current_fitness: context -> Int64.t +val set_current_fitness: context -> Int64.t -> t + +val constants: context -> Constants_repr.constants +val first_level: context -> Raw_level_repr.t + +(** {1 Generic accessors} *************************************************) + +type key = string list + +type value = MBytes.t + +module type T = sig + + type t + type context = t + + (** Tells if the key is already defined as a value. *) + val mem: context -> key -> bool Lwt.t + + (** Tells if the key is already defined as a directory. *) + val dir_mem: context -> key -> bool Lwt.t + + (** Retrieve the value from the storage bucket ; returns a + {!Storage_error Missing_key} if the key is not set. *) + val get: context -> key -> value tzresult Lwt.t + + (** Retrieves the value from the storage bucket ; returns [None] if + the data is not initialized. *) + val get_option: context -> key -> value option Lwt.t + + (** Allocates the storage bucket and initializes it ; returns a + {!Storage_error Existing_key} if the bucket exists. *) + val init: context -> key -> value -> context tzresult Lwt.t + + (** Updates the content of the bucket ; returns a {!Storage_error + Missing_key} if the value does not exists. *) + val set: context -> key -> value -> context tzresult Lwt.t + + (** Allocates the data and initializes it with a value ; just + updates it if the bucket exists. *) + val init_set: context -> key -> value -> context Lwt.t + + (** When the value is [Some v], allocates the data and initializes + it with [v] ; just updates it if the bucket exists. When the + valus is [None], delete the storage bucket when the value ; does + nothing if the bucket does not exists. *) + val set_option: context -> key -> value option -> context Lwt.t + + (** Delete the storage bucket ; returns a {!Storage_error + Missing_key} if the bucket does not exists. *) + val delete: context -> key -> context tzresult Lwt.t + + (** Removes the storage bucket and its contents ; does nothing if the + bucket does not exists. *) + val remove: context -> key -> context Lwt.t + + (** Recursively removes all the storage buckets and contents ; does + nothing if no bucket exists. *) + val remove_rec: context -> key -> context Lwt.t + + (** Iterator on all the items of a given directory. *) + val fold: + context -> key -> init:'a -> + f:([ `Key of key | `Dir of key ] -> 'a -> 'a Lwt.t) -> + 'a Lwt.t + + (** Recursively list all subkeys of a given key. *) + val keys: context -> key -> key list Lwt.t + + (** Recursive iterator on all the subkeys of a given key. *) + val fold_keys: + context -> key -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t + + val project: context -> root_context + +end + +include T with type t := t and type context := context diff --git a/src/proto/alpha/raw_level_repr.ml b/src/proto/alpha/raw_level_repr.ml index 0e067f1df..655165699 100644 --- a/src/proto/alpha/raw_level_repr.ml +++ b/src/proto/alpha/raw_level_repr.ml @@ -45,3 +45,15 @@ type error += Unexpected_level of Int32.t let of_int32 l = try Ok (of_int32_exn l) with _ -> Error [Unexpected_level l] + +module Index = struct + type t = raw_level + let path_length = 1 + let to_path level l = Int32.to_string level :: l + let of_path = function + | [s] -> begin + try Some (Int32.of_string s) + with _ -> None + end + | _ -> None +end diff --git a/src/proto/alpha/raw_level_repr.mli b/src/proto/alpha/raw_level_repr.mli index 2d20651cc..edb395d7f 100644 --- a/src/proto/alpha/raw_level_repr.mli +++ b/src/proto/alpha/raw_level_repr.mli @@ -24,3 +24,10 @@ val root: raw_level val succ: raw_level -> raw_level val pred: raw_level -> raw_level option + +module Index : sig + type t = raw_level + val path_length: int + val to_path: t -> string list -> string list + val of_path: string list -> t option +end diff --git a/src/proto/alpha/reward_storage.ml b/src/proto/alpha/reward_storage.ml index d2f384dbd..e01d00d2a 100644 --- a/src/proto/alpha/reward_storage.ml +++ b/src/proto/alpha/reward_storage.ml @@ -16,47 +16,44 @@ let record c delegate cycle amount = Storage.Rewards.Next.get c >>=? fun min_cycle -> fail_unless Cycle_repr.(min_cycle <= cycle) Too_late_reward_recording >>=? fun () -> - Storage.Rewards.Amount.get_option c (delegate, cycle) >>=? function + Storage.Rewards.Amount.get_option (c, cycle) delegate >>=? function | None -> - Storage.Rewards.Amount.init c (delegate, cycle) amount + Storage.Rewards.Amount.init (c, cycle) delegate amount | Some previous_amount -> Lwt.return Tez_repr.(previous_amount +? amount) >>=? fun amount -> - Storage.Rewards.Amount.set c (delegate, cycle) amount + Storage.Rewards.Amount.set (c, cycle) delegate amount let discard c delegate cycle amount = Storage.Rewards.Next.get c >>=? fun min_cycle -> fail_unless Cycle_repr.(min_cycle <= cycle) Too_late_reward_discarding >>=? fun () -> - Storage.Rewards.Amount.get_option c (delegate, cycle) >>=? function + Storage.Rewards.Amount.get_option (c, cycle) delegate >>=? function | None -> fail Incorrect_discard | Some previous_amount -> match Tez_repr.(previous_amount -? amount) with | Ok amount -> if Tez_repr.(amount = zero) then - Storage.Rewards.Amount.remove c (delegate, cycle) >>= fun ctxt -> + Storage.Rewards.Amount.remove (c, cycle) delegate >>= fun ctxt -> return ctxt else - Storage.Rewards.Amount.set c (delegate, cycle) amount + Storage.Rewards.Amount.set (c, cycle) delegate amount | Error _ -> fail Incorrect_discard let pay_rewards_for_cycle c cycle = - Storage.Rewards.Amount.fold c (Ok c) - ~f:(fun (delegate, reward_cycle) amount c -> + Storage.Rewards.Amount.fold (c, cycle) ~init:(Ok c) + ~f:(fun delegate amount c -> match c with | Error _ -> Lwt.return c | Ok c -> - if not Cycle_repr.(cycle = reward_cycle) - then return c - else - Storage.Rewards.Amount.remove c (delegate, reward_cycle) >>= fun c -> - Contract_storage.credit c - (Contract_repr.default_contract delegate) - amount) + Storage.Rewards.Amount.remove (c, cycle) delegate >>= fun c -> + Contract_storage.credit c + (Contract_repr.default_contract delegate) + amount) let pay_due_rewards c = - let timestamp = Storage.current_timestamp c in + let timestamp = Raw_context.current_timestamp c in let rec loop c cycle = Storage.Rewards.Date.get_option c cycle >>=? function | None -> diff --git a/src/proto/alpha/reward_storage.mli b/src/proto/alpha/reward_storage.mli index ad4e2ce80..51cfee360 100644 --- a/src/proto/alpha/reward_storage.mli +++ b/src/proto/alpha/reward_storage.mli @@ -8,14 +8,14 @@ (**************************************************************************) val record: - Storage.t -> Ed25519.Public_key_hash.t -> Cycle_repr.t -> Tez_repr.t -> Storage.t tzresult Lwt.t + Raw_context.t -> Ed25519.Public_key_hash.t -> Cycle_repr.t -> Tez_repr.t -> Raw_context.t tzresult Lwt.t val discard: - Storage.t -> Ed25519.Public_key_hash.t -> Cycle_repr.t -> Tez_repr.t -> Storage.t tzresult Lwt.t + Raw_context.t -> Ed25519.Public_key_hash.t -> Cycle_repr.t -> Tez_repr.t -> Raw_context.t tzresult Lwt.t -val pay_due_rewards: Storage.t -> Storage.t tzresult Lwt.t +val pay_due_rewards: Raw_context.t -> Raw_context.t tzresult Lwt.t val set_reward_time_for_cycle: - Storage.t -> Cycle_repr.t -> Time.t -> Storage.t tzresult Lwt.t + Raw_context.t -> Cycle_repr.t -> Time.t -> Raw_context.t tzresult Lwt.t -val init: Storage.t -> Storage.t tzresult Lwt.t +val init: Raw_context.t -> Raw_context.t tzresult Lwt.t diff --git a/src/proto/alpha/roll_repr.ml b/src/proto/alpha/roll_repr.ml index 740099bb1..7dfbd6ff4 100644 --- a/src/proto/alpha/roll_repr.ml +++ b/src/proto/alpha/roll_repr.ml @@ -21,3 +21,19 @@ let random sequence ~bound = let to_int32 v = v let (=) = Compare.Int32.(=) + +module Index = struct + type t = roll + let path_length = 3 + let nbyte_of_int32 i n = + Int32.to_string @@ + Int32.logand (Int32.shift_right i (8 * n)) (Int32.of_int 0xff) + let to_path roll l = + nbyte_of_int32 roll 0 :: nbyte_of_int32 roll 1 :: Int32.to_string roll :: l + let of_path = function + | _ :: _ :: s :: _ -> begin + try Some (Int32.of_string s) + with _ -> None + end + | _ -> None +end diff --git a/src/proto/alpha/roll_repr.mli b/src/proto/alpha/roll_repr.mli index 46e030d01..98387d948 100644 --- a/src/proto/alpha/roll_repr.mli +++ b/src/proto/alpha/roll_repr.mli @@ -21,3 +21,10 @@ val succ: roll -> roll val to_int32: roll -> Int32.t val (=): roll -> roll -> bool + +module Index : sig + type t = roll + val path_length: int + val to_path: t -> string list -> string list + val of_path: string list -> t option +end diff --git a/src/proto/alpha/roll_storage.ml b/src/proto/alpha/roll_storage.ml index 3aa2398d6..28844ed13 100644 --- a/src/proto/alpha/roll_storage.ml +++ b/src/proto/alpha/roll_storage.ml @@ -24,7 +24,7 @@ let clear_cycle c cycle = if Roll_repr.(roll = last) then return c else - Storage.Roll.Owner_for_cycle.delete c (cycle, roll) >>=? fun c -> + Storage.Roll.Owner_for_cycle.delete (c, cycle) roll >>=? fun c -> loop c (Roll_repr.succ roll) in loop c Roll_repr.first @@ -49,7 +49,7 @@ let freeze_rolls_for_cycle ctxt cycle = | None -> return acc | Some delegate -> Storage.Roll.Owner_for_cycle.init - ctxt (cycle, promoted_roll) delegate >>=? fun ctxt -> + (ctxt, cycle) promoted_roll delegate >>=? fun ctxt -> return (ctxt, Roll_repr.succ promoted_roll)) >>=? fun (ctxt, last_promoted_roll) -> Storage.Roll.Last_for_cycle.init ctxt cycle last_promoted_roll @@ -75,8 +75,8 @@ module Random = struct let rd = level_random random_seed kind level in let sequence = Seed_repr.sequence rd (Int32.of_int offset) in Storage.Roll.Last_for_cycle.get c cycle >>=? fun bound -> - let roll, _ = Roll_repr.random sequence bound in - Storage.Roll.Owner_for_cycle.get c (cycle, roll) + let roll, _ = Roll_repr.random sequence ~bound in + Storage.Roll.Owner_for_cycle.get (c, cycle) roll end @@ -94,10 +94,10 @@ module Contract = struct return (roll, c) let get_limbo_roll c = - Storage.Roll.Limbo.get c >>=? function + Storage.Roll.Limbo.get_option c >>=? function | None -> fresh_roll c >>=? fun (roll, c) -> - Storage.Roll.Limbo.set c (Some roll) >>=? fun c -> + Storage.Roll.Limbo.init c roll >>=? fun c -> return (roll, c) | Some roll -> return (roll, c) @@ -119,24 +119,24 @@ module Contract = struct contract : roll -> successor_roll -> ... limbo : limbo_head -> ... *) - Storage.Roll.Limbo.get c >>=? fun limbo_head -> - Storage.Roll.Contract_roll_list.get c contract >>=? function + Storage.Roll.Limbo.get_option c >>=? fun limbo_head -> + Storage.Roll.Contract_roll_list.get_option c contract >>=? function | None -> fail No_roll_in_contract | Some roll -> Storage.Roll.Owner.delete c roll >>=? fun c -> - Storage.Roll.Successor.get c roll >>=? fun successor_roll -> - Storage.Roll.Contract_roll_list.set c contract successor_roll >>=? fun c -> + Storage.Roll.Successor.get_option c roll >>=? fun successor_roll -> + Storage.Roll.Contract_roll_list.set_option c contract successor_roll >>= fun c -> (* contract : successor_roll -> ... roll ------^ limbo : limbo_head -> ... *) - Storage.Roll.Successor.set c roll limbo_head >>=? fun c -> + Storage.Roll.Successor.set_option c roll limbo_head >>= fun c -> (* contract : successor_roll -> ... roll ------v limbo : limbo_head -> ... *) - Storage.Roll.Limbo.set c (Some roll) >>=? fun c -> + Storage.Roll.Limbo.init_set c roll >>= fun c -> (* contract : successor_roll -> ... limbo : roll -> limbo_head -> ... *) - Lwt.return (Ok (roll, c)) + return (roll, c) let create_roll_in_contract c contract = consume_roll_change c contract >>=? fun c -> @@ -145,21 +145,22 @@ module Contract = struct contract : contract_head -> ... limbo : roll -> limbo_successor -> ... *) - Storage.Roll.Contract_roll_list.get c contract >>=? fun contract_head -> + Storage.Roll.Contract_roll_list.get_option c contract >>=? fun contract_head -> get_limbo_roll c >>=? fun (roll, c) -> Storage.Roll.Owner.init c roll contract >>=? fun c -> - Storage.Roll.Successor.get c roll >>=? fun limbo_successor -> - Storage.Roll.Limbo.set c limbo_successor >>=? fun c -> + Storage.Roll.Successor.get_option c roll >>=? fun limbo_successor -> + Storage.Roll.Limbo.set_option c limbo_successor >>= fun c -> (* contract : contract_head -> ... roll ------v limbo : limbo_successor -> ... *) - Storage.Roll.Successor.set c roll contract_head >>=? fun c -> + Storage.Roll.Successor.set_option c roll contract_head >>= fun c -> (* contract : contract_head -> ... roll ------^ limbo : limbo_successor -> ... *) - Storage.Roll.Contract_roll_list.set c contract (Some roll) - (* contract : roll -> contract_head -> ... - limbo : limbo_successor -> ... *) + Storage.Roll.Contract_roll_list.init_set c contract roll >>= fun c -> + (* contract : roll -> contract_head -> ... + limbo : limbo_successor -> ... *) + return c let init c contract = Storage.Roll.Contract_change.init c contract Tez_repr.zero diff --git a/src/proto/alpha/roll_storage.mli b/src/proto/alpha/roll_storage.mli index 133ee59da..ac9688adc 100644 --- a/src/proto/alpha/roll_storage.mli +++ b/src/proto/alpha/roll_storage.mli @@ -21,43 +21,43 @@ type error += | Consume_roll_change | No_roll_in_contract -val init : Storage.t -> Storage.t tzresult Lwt.t +val init : Raw_context.t -> Raw_context.t tzresult Lwt.t val fold : - Storage.t -> + Raw_context.t -> f:(Roll_repr.roll -> Contract_repr.t -> 'a -> 'a tzresult Lwt.t) -> 'a -> 'a tzresult Lwt.t val freeze_rolls_for_cycle : - Storage.t -> Cycle_repr.t -> Storage.t tzresult Lwt.t + Raw_context.t -> Cycle_repr.t -> Raw_context.t tzresult Lwt.t val clear_cycle : - Storage.t -> Cycle_repr.t -> Storage.t tzresult Lwt.t + Raw_context.t -> Cycle_repr.t -> Raw_context.t tzresult Lwt.t val baking_rights_owner : - Storage.t -> Level_repr.t -> priority:int -> + Raw_context.t -> Level_repr.t -> priority:int -> Ed25519.Public_key_hash.t tzresult Lwt.t val endorsement_rights_owner : - Storage.t -> Level_repr.t -> slot:int -> + Raw_context.t -> Level_repr.t -> slot:int -> Ed25519.Public_key_hash.t tzresult Lwt.t module Contract : sig val init : - Storage.t -> Contract_repr.t -> Storage.t tzresult Lwt.t + Raw_context.t -> Contract_repr.t -> Raw_context.t tzresult Lwt.t val add_amount : - Storage.t -> Contract_repr.t -> Tez_repr.t -> Storage.t tzresult Lwt.t + Raw_context.t -> Contract_repr.t -> Tez_repr.t -> Raw_context.t tzresult Lwt.t val remove_amount : - Storage.t -> Contract_repr.t -> Tez_repr.t -> Storage.t tzresult Lwt.t + Raw_context.t -> Contract_repr.t -> Tez_repr.t -> Raw_context.t tzresult Lwt.t - val assert_empty : Storage.t -> Contract_repr.t -> unit tzresult Lwt.t + val assert_empty : Raw_context.t -> Contract_repr.t -> unit tzresult Lwt.t end (**/**) val get_contract_delegate: - Storage.t -> Contract_repr.t -> Ed25519.Public_key_hash.t option tzresult Lwt.t + Raw_context.t -> Contract_repr.t -> Ed25519.Public_key_hash.t option tzresult Lwt.t diff --git a/src/proto/alpha/seed_repr.mli b/src/proto/alpha/seed_repr.mli index e6dfba555..268ce9c9b 100644 --- a/src/proto/alpha/seed_repr.mli +++ b/src/proto/alpha/seed_repr.mli @@ -67,7 +67,7 @@ val hash : nonce -> Nonce_hash.t val check_hash : nonce -> Nonce_hash.t -> bool (** For using nonce hashes as keys in the hierarchical database *) -val nonce_hash_key_part : Nonce_hash.t -> string list +val nonce_hash_key_part : Nonce_hash.t -> string list -> string list (** {2 Predefined nonce} *****************************************************) diff --git a/src/proto/alpha/seed_storage.mli b/src/proto/alpha/seed_storage.mli index 5ba100087..da95ec15e 100644 --- a/src/proto/alpha/seed_storage.mli +++ b/src/proto/alpha/seed_storage.mli @@ -12,12 +12,12 @@ type error += | Invalid_cycle val init: - Storage.t -> Storage.t tzresult Lwt.t + Raw_context.t -> Raw_context.t tzresult Lwt.t val compute_for_cycle: - Storage.t -> Cycle_repr.t -> Storage.t tzresult Lwt.t + Raw_context.t -> Cycle_repr.t -> Raw_context.t tzresult Lwt.t -val for_cycle: Storage.t -> Cycle_repr.t -> Seed_repr.seed tzresult Lwt.t +val for_cycle: Raw_context.t -> Cycle_repr.t -> Seed_repr.seed tzresult Lwt.t val clear_cycle: - Storage.t -> Cycle_repr.t -> Storage.t tzresult Lwt.t + Raw_context.t -> Cycle_repr.t -> Raw_context.t tzresult Lwt.t diff --git a/src/proto/alpha/services_registration.ml b/src/proto/alpha/services_registration.ml index ae1a7a9a1..b0a26a6dd 100644 --- a/src/proto/alpha/services_registration.ml +++ b/src/proto/alpha/services_registration.ml @@ -189,12 +189,15 @@ let get_key ctxt hash () = return (hash, pk) let () = register2 Services.Context.Key.get get_key -let () = register0 Services.Context.Key.list Delegates_pubkey.list +let () = + register0 Services.Context.Key.list + (fun t -> Delegates_pubkey.list t >>= return) (*-- Context.Contract --------------------------------------------------------*) let () = - register0 Services.Context.Contract.list Contract.list + register0 Services.Context.Contract.list + (fun ctxt -> Contract.list ctxt >>= return) let () = let register2 s f = diff --git a/src/proto/alpha/storage.ml b/src/proto/alpha/storage.ml index 1cdf00683..e2336a06d 100644 --- a/src/proto/alpha/storage.ml +++ b/src/proto/alpha/storage.ml @@ -10,368 +10,233 @@ open Tezos_hash open Storage_functors -(* This key should always be populated for every version of the - protocol. It's absence meaning that the context is empty. *) -let version_key = ["version"] -let version_value = "alpha" - -type error += Incompatiple_protocol_version - -let is_first_block ctxt = - Context.get ctxt version_key >>= function - | None -> - return true - | Some bytes -> - let s = MBytes.to_string bytes in - if Compare.String.(s = version_value) then - return false - else if Compare.String.(s = "genesis") then - return true - else - fail Incompatiple_protocol_version - -let version = "v1" -let first_level_key = [ version ; "first_level" ] -let sandboxed_key = [ version ; "sandboxed" ] - -type t = Storage_functors.context - -type error += Invalid_sandbox_parameter - -let current_level { level } = level -let current_timestamp { timestamp } = timestamp -let current_fitness { fitness } = fitness -let set_current_fitness c fitness = { c with fitness } - -let get_first_level ctxt = - Context.get ctxt first_level_key >>= function - | None -> failwith "Invalid context" - | Some bytes -> - match - Data_encoding.Binary.of_bytes Raw_level_repr.encoding bytes - with - | None -> failwith "Invalid context" - | Some level -> return level - -let set_first_level ctxt level = - let bytes = - Data_encoding.Binary.to_bytes Raw_level_repr.encoding level in - Context.set ctxt first_level_key bytes >>= fun ctxt -> - return ctxt - -let get_sandboxed c = - Context.get c sandboxed_key >>= function - | None -> return None - | Some bytes -> - match Data_encoding.Binary.of_bytes Data_encoding.json bytes with - | None -> fail Invalid_sandbox_parameter - | Some json -> return (Some json) - -let set_sandboxed c json = - Context.set c sandboxed_key - (Data_encoding.Binary.to_bytes Data_encoding.json json) - -let may_tag_first_block ctxt level = - is_first_block ctxt >>=? function - | false -> - get_first_level ctxt >>=? fun level -> - return (ctxt, false, level) - | true -> - Context.set ctxt version_key - (MBytes.of_string version_value) >>= fun ctxt -> - set_first_level ctxt level >>=? fun ctxt -> - return (ctxt, true, level) - -let prepare ~level ~timestamp ~fitness ctxt = - Lwt.return (Raw_level_repr.of_int32 level ) >>=? fun level -> - Lwt.return (Fitness_repr.to_int64 fitness) >>=? fun fitness -> - may_tag_first_block ctxt level >>=? fun (ctxt, first_block, first_level) -> - get_sandboxed ctxt >>=? fun sandbox -> - Constants_repr.read sandbox >>=? function constants -> - let level = - Level_repr.from_raw - ~first_level - ~cycle_length:constants.Constants_repr.cycle_length - ~voting_period_length:constants.Constants_repr.voting_period_length - level in - return ({ context = ctxt ; constants ; level ; - timestamp ; fitness ; first_level}, - first_block) -let recover { context } : Context.t = context - -let first_level { first_level } = first_level -let constants { constants } = constants - -module Key = struct - - let store_root tail = version :: "store" :: tail - - let global_counter = store_root ["global_counter"] - - let next_cycle_to_be_rewarded = store_root ["next_cycle_to_be_rewarded"] - let rewards = store_root ["rewards"] - - let public_keys = ["public_keys" ; "ed25519"] - - let nbyte_of_int32 i n = - Int32.to_string @@ - Int32.logand (Int32.shift_left i (8 * n)) (Int32.of_int 0xff) - - let roll_path roll l = - let i = Roll_repr.to_int32 roll in - nbyte_of_int32 i 0 :: nbyte_of_int32 i 1 :: Int32.to_string i :: l - - module Roll = struct - let store_root l = store_root ("rolls" :: l) - let next = store_root [ "next" ] - let limbo = store_root [ "limbo" ] - let roll_store roll l = - store_root @@ roll_path roll @@ l - let successor r = roll_store r ["successor"] - let owner r = roll_store r ["owner"] - end - - module Cycle = struct - let store_root l = store_root ("cycles" :: l) - let cycle_store c l = - store_root @@ Int32.to_string (Cycle_repr.to_int32 c) :: l - let last_roll c = cycle_store c [ "last_roll" ] - let random_seed c = cycle_store c [ "random_seed" ] - let reward_date c = cycle_store c [ "reward_date" ] - let roll_owner (c, r) = - cycle_store c @@ "roll_owners" :: roll_path r [] - let unrevealed_nonce_hash l = - let c = l.Level_repr.cycle in - cycle_store c [ "unrevealed_nonce_hash" ; - Int32.to_string l.Level_repr.cycle_position ] - end - - module Contract = struct - - let store_root l = store_root ("contracts" :: l) - let set = store_root ["set"] - let pubkey_contract l = store_root ("pubkey" :: l) - let generic_contract l = store_root ("generic" :: l) - let contract_store c l = - match c with - | Contract_repr.Default k -> - pubkey_contract @@ Ed25519.Public_key_hash.to_path k @ l - | Contract_repr.Originated h -> - generic_contract @@ Contract_hash.to_path h @ l - let roll_list c = contract_store c ["roll_list"] - let change c = contract_store c ["change"] - let balance c = contract_store c ["balance"] - let manager c = contract_store c ["manager"] - let spendable c = contract_store c ["spendable"] - let delegatable c = contract_store c ["delegatable"] - let delegate c = contract_store c ["delegate"] - let counter c = contract_store c ["counter"] - let code c = contract_store c ["code"] - let storage c = contract_store c ["storage"] - let code_fees c = contract_store c ["code_fees"] - let storage_fees c = contract_store c ["storage_fees"] - end - - module Vote = struct - let store_root l = store_root ("votes" :: l) - let period_kind = store_root ["current_period_kind"] - let quorum = store_root ["current_quorum"] - let proposition = store_root ["current_proposition"] - let proposals = store_root ["proposals"] - let ballots = store_root ["ballots"] - let listings_size = store_root ["listings_size"] - let listings = store_root ["listings"] - end - +module Int32 = struct + type t = Int32.t + let encoding = Data_encoding.int32 end -(** Rolls *) - -module Roll = struct - - module Next = - Make_single_data_storage(struct - type value = Roll_repr.t - let name = "next fresh roll" - let key = Key.Roll.next - let encoding = Roll_repr.encoding - end) - - module Limbo = - Make_single_optional_data_storage(struct - type value = Roll_repr.t - let name = "limbo" - let key = Key.Roll.limbo - let encoding = Roll_repr.encoding - end) - - module Last_for_cycle = - Make_indexed_data_storage(struct - type key = Cycle_repr.t - type value = Roll_repr.t - let name = "last roll for current cycle" - let key = Key.Cycle.last_roll - let encoding = Roll_repr.encoding - end) - - module Successor = - Make_indexed_optional_data_storage(struct - type key = Roll_repr.t - type value = Roll_repr.t - let name = "roll successor" - let key = Key.Roll.successor - let encoding = Roll_repr.encoding - end) - - module Owner = - Make_indexed_data_storage(struct - type key = Roll_repr.t - type value = Contract_repr.t - let name = "roll owner" - let key = Key.Roll.owner - let encoding = Contract_repr.encoding - end) - - module Owner_for_cycle = - Make_indexed_data_storage(struct - type key = Cycle_repr.t * Roll_repr.t - type value = Ed25519.Public_key_hash.t - let name = "roll owner for current cycle" - let key = Key.Cycle.roll_owner - let encoding = Ed25519.Public_key_hash.encoding - end) - - module Contract_roll_list = - Make_indexed_optional_data_storage(struct - type key = Contract_repr.t - type value = Roll_repr.t - let name = "contract roll list" - let key = Key.Contract.roll_list - let encoding = Roll_repr.encoding - end) - - module Contract_change = - Make_indexed_data_storage(struct - type key = Contract_repr.t - type value = Tez_repr.t - let name = "contract change" - let key = Key.Contract.change - let encoding = Tez_repr.encoding - end) - +module Bool = struct + type t = bool + let encoding = Data_encoding.bool end (** Contracts handling *) module Contract = struct - module Global_counter = - Make_single_data_storage(struct - type value = int32 - let name = "global counter" - let key = Key.global_counter - let encoding = Data_encoding.int32 - end) + module Raw_context = + Make_subcontext(Raw_context)(struct let name = ["contracts"] end) - (** FIXME REMOVE : use 'list' *) - module Set = - Make_data_set_storage(struct - type value = Contract_repr.t - let name = "contract set" - let key = Key.Contract.set - let encoding = Contract_repr.encoding - end) + module Global_counter = + Make_single_data_storage + (Raw_context) + (struct let name = ["global_counter"] end) + (Make_value(Int32)) + + (* module Set = *) + (* Make_data_set_storage *) + (* (Make_subcontext(Raw_context)(struct let name = ["set"] end)) *) + (* (Contract_repr.Index) *) + + module Indexed_context = + Make_indexed_subcontext + (Make_subcontext(Raw_context)(struct let name = ["index"] end)) + (Contract_repr.Index) + + let list = Indexed_context.keys module Balance = - Make_indexed_data_storage( - struct - type key = Contract_repr.t - type value = Tez_repr.t - let name = "contract balance" - let key = Key.Contract.balance - let encoding = Tez_repr.encoding - end) + Indexed_context.Make_map + (struct let name = ["balance"] end) + (Make_value(Tez_repr)) module Manager = - Make_indexed_data_storage(struct - type key = Contract_repr.t - type value = Manager_repr.t - let name = "contract manager" - let key = Key.Contract.manager - let encoding = Manager_repr.encoding - end) + Indexed_context.Make_map + (struct let name = ["manager"] end) + (Make_value(Manager_repr)) module Spendable = - Make_indexed_data_storage(struct - type key = Contract_repr.t - type value = bool - let name = "contract spendable" - let key = Key.Contract.spendable - let encoding = Data_encoding.bool - end) + Indexed_context.Make_map + (struct let name = ["spendable"] end) + (Make_value(Bool)) module Delegatable = - Make_indexed_data_storage(struct - type key = Contract_repr.t - type value = bool - let name = "contract delegatable" - let key = Key.Contract.delegatable - let encoding = Data_encoding.bool - end) + Indexed_context.Make_map + (struct let name = ["delegatable"] end) + (Make_value(Bool)) module Delegate = - Make_indexed_data_storage(struct - type key = Contract_repr.t - type value = Ed25519.Public_key_hash.t - let name = "contract delegate" - let key = Key.Contract.delegate - let encoding = Ed25519.Public_key_hash.encoding - end) + Indexed_context.Make_map + (struct let name = ["delegate"] end) + (Make_value(Ed25519.Public_key_hash)) module Counter = - Make_indexed_data_storage(struct - type key = Contract_repr.t - type value = Int32.t - let name = "contract counter" - let key = Key.Contract.counter - let encoding = Data_encoding.int32 - end) + Indexed_context.Make_map + (struct let name = ["counter"] end) + (Make_value(Int32)) module Code = - Make_indexed_data_storage(struct - type key = Contract_repr.t - type value = Script_repr.expr - let name = "contract code" - let key = Key.Contract.code - let encoding = Script_repr.expr_encoding - end) + Indexed_context.Make_map + (struct let name = ["code"] end) + (Make_value(struct + type t = Script_repr.expr + let encoding = Script_repr.expr_encoding + end)) module Storage = - Make_indexed_data_storage(struct - type key = Contract_repr.t - type value = Script_repr.expr - let name = "contract storage" - let key = Key.Contract.storage - let encoding = Script_repr.expr_encoding - end) + Indexed_context.Make_map + (struct let name = ["storage"] end) + (Make_value(struct + type t = Script_repr.expr + let encoding = Script_repr.expr_encoding + end)) module Code_fees = - Make_indexed_data_storage(struct - type key = Contract_repr.t - type value = Tez_repr.t - let name = "contract code fees" - let key = Key.Contract.code_fees - let encoding = Tez_repr.encoding - end) + Indexed_context.Make_map + (struct let name = ["code_fees"] end) + (Make_value(Tez_repr)) module Storage_fees = - Make_indexed_data_storage(struct - type key = Contract_repr.t - type value = Tez_repr.t - let name = "contract storage fees" - let key = Key.Contract.storage_fees - let encoding = Tez_repr.encoding - end) + Indexed_context.Make_map + (struct let name = ["storage_fees"] end) + (Make_value(Tez_repr)) + + module Roll_list = + Indexed_context.Make_map + (struct let name = ["roll_list"] end) + (Make_value(Roll_repr)) + + module Change = + Indexed_context.Make_map + (struct let name = ["change"] end) + (Make_value(Tez_repr)) + +end + +(** Rolls *) + +module Cycle = struct + + module Indexed_context = + Make_indexed_subcontext + (Make_subcontext(Raw_context)(struct let name = ["cycle"] end)) + (Cycle_repr.Index) + + module Last_roll = + Indexed_context.Make_map + (struct let name = ["last_roll"] end) + (Make_value(Roll_repr)) + + module Roll_owner = + Make_indexed_data_storage + (Make_subcontext + (Indexed_context.Raw_context) + (struct let name = ["roll_owners"] end)) + (Roll_repr.Index) + (Make_value(Ed25519.Public_key_hash)) + + type nonce_status = + | Unrevealed of { + nonce_hash: Nonce_hash.t ; + delegate_to_reward: Ed25519.Public_key_hash.t ; + reward_amount: Tez_repr.t ; + } + | Revealed of Seed_repr.nonce + + let nonce_status_encoding = + let open Data_encoding in + union [ + case ~tag:0 + (tup3 + Nonce_hash.encoding + Ed25519.Public_key_hash.encoding + Tez_repr.encoding) + (function + | Unrevealed { nonce_hash ; delegate_to_reward ; reward_amount } -> + Some (nonce_hash, delegate_to_reward, reward_amount) + | _ -> None) + (fun (nonce_hash, delegate_to_reward, reward_amount) -> + Unrevealed { nonce_hash ; delegate_to_reward ; reward_amount }) ; + case ~tag:1 + Seed_repr.nonce_encoding + (function + | Revealed nonce -> Some nonce + | _ -> None) + (fun nonce -> Revealed nonce) + ] + + module Nonce = + Make_indexed_data_storage + (Make_subcontext + (Indexed_context.Raw_context) + (struct let name = ["nonces"] end)) + (Raw_level_repr.Index) + (Make_value(struct + type t = nonce_status + let encoding = nonce_status_encoding + end)) + + module Seed = + Indexed_context.Make_map + (struct let name = ["random_seed"] end) + (Make_value(struct + type t = Seed_repr.seed + let encoding = Seed_repr.seed_encoding + end)) + + module Reward_date = + Indexed_context.Make_map + (struct let name = [ "reward_date" ] end) + (Make_value(Time_repr)) + + module Reward_amount = + Make_indexed_data_storage + (Make_subcontext + (Indexed_context.Raw_context) + (struct let name = [ "rewards" ] end)) + (Ed25519.Public_key_hash) + (Make_value(Tez_repr)) + +end + +module Roll = struct + + module Raw_context = + Make_subcontext(Raw_context)(struct let name = ["rolls"] end) + + module Indexed_context = + Make_indexed_subcontext + (Make_subcontext(Raw_context)(struct let name = ["index"] end)) + (Roll_repr.Index) + + module Next = + Make_single_data_storage + (Raw_context) + (struct let name = ["next"] end) + (Make_value(Roll_repr)) + + module Limbo = + Make_single_data_storage + (Raw_context) + (struct let name = ["limbo"] end) + (Make_value(Roll_repr)) + + module Contract_roll_list = Contract.Roll_list + + module Successor = + Indexed_context.Make_map + (struct let name = ["successor"] end) + (Make_value(Roll_repr)) + + module Contract_change = Contract.Change + + module Owner = + Indexed_context.Make_map + (struct let name = ["owner"] end) + (Make_value(Contract_repr)) + + module Last_for_cycle = Cycle.Last_roll + module Owner_for_cycle = Cycle.Roll_owner end @@ -379,130 +244,101 @@ end module Vote = struct + module Raw_context = + Make_subcontext(Raw_context)(struct let name = ["votes"] end) + module Current_period_kind = - Make_single_data_storage(struct - type value = Voting_period_repr.kind - let name = "current period kind" - let key = Key.Vote.period_kind - let encoding = Voting_period_repr.kind_encoding - end) + Make_single_data_storage + (Raw_context) + (struct let name = ["current_period_kind"] end) + (Make_value(struct + type t = Voting_period_repr.kind + let encoding = Voting_period_repr.kind_encoding + end)) module Current_quorum = - Make_single_data_storage(struct - type value = int32 - let name = "current quorum" - let key = Key.Vote.quorum - let encoding = Data_encoding.int32 - end) + Make_single_data_storage + (Raw_context) + (struct let name = ["current_quorum"] end) + (Make_value(Int32)) module Current_proposal = - Make_single_data_storage(struct - type value = Protocol_hash.t - let name = "current proposal" - let key = Key.Vote.proposition - let encoding = Protocol_hash.encoding - end) + Make_single_data_storage + (Raw_context) + (struct let name = ["current_proposal"] end) + (Make_value(Protocol_hash)) module Listings_size = - Make_single_data_storage(struct - type value = int32 - let name = "listing size" - let key = Key.Vote.listings_size - let encoding = Data_encoding.int32 - end) + Make_single_data_storage + (Raw_context) + (struct let name = ["listings_size"] end) + (Make_value(Int32)) module Listings = - Make_iterable_data_storage (Ed25519.Public_key_hash) - (struct - type value = int32 - let key = Key.Vote.listings - let name = "listings" - let encoding = Data_encoding.int32 - end) + Make_indexed_data_storage + (Make_subcontext(Raw_context)(struct let name = ["listings"] end)) + (Ed25519.Public_key_hash) + (Make_value(Int32)) module Proposals = Make_data_set_storage - (struct - type value = Protocol_hash.t * Ed25519.Public_key_hash.t - let name = "proposals" - let encoding = - Data_encoding.tup2 - Protocol_hash.encoding Ed25519.Public_key_hash.encoding - let key = Key.Vote.proposals - end) + (Make_subcontext(Raw_context)(struct let name = ["proposals"] end)) + (Pair(Protocol_hash)(Ed25519.Public_key_hash)) module Ballots = - Make_iterable_data_storage (Ed25519.Public_key_hash) - (struct - type value = Vote_repr.ballot - let key = Key.Vote.ballots - let name = "ballot" - let encoding = Vote_repr.ballot_encoding - end) + Make_indexed_data_storage + (Make_subcontext(Raw_context)(struct let name = ["ballots"] end)) + (Ed25519.Public_key_hash) + (Make_value(struct + type t = Vote_repr.ballot + let encoding = Vote_repr.ballot_encoding + end)) end (** Keys *) module Public_key = - Make_iterable_data_storage (Ed25519.Public_key_hash) - (struct - type value = Ed25519.Public_key.t - let key = Key.public_keys - let name = "public keys" - let encoding = Ed25519.Public_key.encoding - end) + Make_indexed_data_storage + (Make_subcontext + (Raw_context) + (struct let name = ["public_keys"; "ed25519"] end)) + (Ed25519.Public_key_hash) + (Make_value(Ed25519.Public_key)) (** Seed *) module Seed = struct - type nonce_status = + type nonce_status = Cycle.nonce_status = | Unrevealed of { - nonce_hash: Tezos_hash.Nonce_hash.t ; + nonce_hash: Nonce_hash.t ; delegate_to_reward: Ed25519.Public_key_hash.t ; reward_amount: Tez_repr.t ; } | Revealed of Seed_repr.nonce - module Nonce = - Make_indexed_data_storage(struct - type key = Level_repr.level - type value = nonce_status - let name = "unrevealed nonce hash" - let key = Key.Cycle.unrevealed_nonce_hash - let encoding = - let open Data_encoding in - union [ - case ~tag:0 - (tup3 - Nonce_hash.encoding - Ed25519.Public_key_hash.encoding - Tez_repr.encoding - ) - (function - | Unrevealed { nonce_hash ; delegate_to_reward ; reward_amount } -> - Some (nonce_hash, delegate_to_reward, reward_amount) - | _ -> None) - (fun (nonce_hash, delegate_to_reward, reward_amount) -> - Unrevealed { nonce_hash ; delegate_to_reward ; reward_amount }) ; - case ~tag:1 - Seed_repr.nonce_encoding - (function - | Revealed nonce -> Some nonce - | _ -> None) - (fun nonce -> Revealed nonce) - ] - end) - - module For_cycle = - Make_indexed_data_storage(struct - type key = Cycle_repr.t - type value = Seed_repr.seed - let name = "cycle random seed" - let key = Key.Cycle.random_seed - let encoding = Seed_repr.seed_encoding - end) + module Nonce = struct + open Level_repr + type context = Raw_context.t + let mem ctxt l = Cycle.Nonce.mem (ctxt, l.cycle) l.level + let get ctxt l = Cycle.Nonce.get (ctxt, l.cycle) l.level + let get_option ctxt l = Cycle.Nonce.get_option (ctxt, l.cycle) l.level + let set ctxt l v = Cycle.Nonce.set (ctxt, l.cycle) l.level v + let init ctxt l v = Cycle.Nonce.init (ctxt, l.cycle) l.level v + let init_set ctxt l v = Cycle.Nonce.init_set (ctxt, l.cycle) l.level v + let set_option ctxt l v = Cycle.Nonce.set_option (ctxt, l.cycle) l.level v + let delete ctxt l = Cycle.Nonce.delete (ctxt, l.cycle) l.level + let remove ctxt l = Cycle.Nonce.remove (ctxt, l.cycle) l.level + (* We don't need the follwing iterators and I am kind of busy + defining a signature "Non_iterable_indexed_data_storage" *) + let clear _ctxt = assert false + let keys _ctxt = assert false + let bindings _ctxt = assert false + let fold _ctxt = assert false + let fold_keys _ctxt = assert false + end + module For_cycle = Cycle.Seed end @@ -511,61 +347,36 @@ end module Rewards = struct module Next = - Make_single_data_storage(struct - type value = Cycle_repr.t - let name = "reward cycle" - let key = Key.next_cycle_to_be_rewarded - let encoding = Cycle_repr.encoding - end) + Make_single_data_storage + (Raw_context) + (struct let name = ["next_cycle_to_be_rewarded"] end) + (Make_value(Cycle_repr)) - module Date = - Make_indexed_data_storage(struct - type key = Cycle_repr.t - type value = Time_repr.t - let name = "reward timestamp" - let key = Key.Cycle.reward_date - let encoding = Time_repr.encoding - end) - - module Amount = - Raw_make_iterable_data_storage(struct - type t = Ed25519.Public_key_hash.t * Cycle_repr.t - let prefix = Key.rewards - let length = Ed25519.Public_key_hash.path_length + 1 - let to_path (pkh, c) = - Ed25519.Public_key_hash.to_path pkh @ - [Int32.to_string (Cycle_repr.to_int32 c)] - let of_path p = - match List.rev p with - | [] -> assert false - | cycle :: rev_pkh -> - (Ed25519.Public_key_hash.of_path_exn (List.rev rev_pkh), - Cycle_repr.of_int32_exn @@ Int32.of_string cycle) - let compare (pkh1, c1) (pkh2, c2) = - let cmp1 = Ed25519.Public_key_hash.compare pkh1 pkh2 in - if Compare.Int.(cmp1 = 0) then Cycle_repr.compare c1 c2 - else cmp1 - end)(struct - type value = Tez_repr.t - let name = "level baker contract" - let encoding = Tez_repr.encoding - end) + module Date = Cycle.Reward_date + module Amount = Cycle.Reward_amount end -let activate ({ context = c } as s) h = - Updater.activate c h >>= fun c -> Lwt.return { s with context = c } -let fork_test_network ({ context = c } as s) protocol expiration = - Updater.fork_test_network c ~protocol ~expiration >>= fun c -> - Lwt.return { s with context = c } - (** Resolver *) let () = - Storage_functors.register_resolvers - (module Contract_hash) - [ Key.Contract.generic_contract [] ] ; - Storage_functors.register_resolvers - (module Ed25519.Public_key_hash) - [ Key.Contract.pubkey_contract [] ; - Key.public_keys ] + Raw_context.register_resolvers + Contract_hash.b58check_encoding + (fun ctxt p -> + let p = Contract_repr.Index.contract_prefix p in + Contract.Indexed_context.resolve ctxt p >|= fun l -> + List.map + (function + | Contract_repr.Default _ -> assert false + | Contract_repr.Originated s -> s) + l) ; + Raw_context.register_resolvers + Ed25519.Public_key_hash.b58check_encoding + (fun ctxt p -> + let p = Contract_repr.Index.pkh_prefix p in + Contract.Indexed_context.resolve ctxt p >|= fun l -> + List.map + (function + | Contract_repr.Default s -> s + | Contract_repr.Originated _ -> assert false) + l) diff --git a/src/proto/alpha/storage.mli b/src/proto/alpha/storage.mli index 54ec6f657..516f98a6a 100644 --- a/src/proto/alpha/storage.mli +++ b/src/proto/alpha/storage.mli @@ -7,7 +7,7 @@ (* *) (**************************************************************************) -(** Tezos Protocol Implementation - Typed storage accessors +(** Tezos Protocol Implementation - Typed storage This module hides the hierarchical (key x value) database under pre-allocated typed accessors for all persistent entities of the @@ -18,42 +18,6 @@ a complete view over the database contents and avoid key collisions. *) - -(** {1 Abstract Context} *****************************************************) - -(** Abstract view of the database *) -type t - -(** Is first block validated with this version of the protocol ? *) -val is_first_block: Context.t -> bool tzresult Lwt.t - -(** Retrieves the state of the database and gives its abstract view. - It also returns wether this is the first block validated - with this version of the protocol. *) -val prepare : - level: Int32.t -> - timestamp: Time.t -> - fitness: Fitness.t -> - Context.t -> (t * bool) tzresult Lwt.t - -(** Returns the state of the database resulting of operations on its - abstract view *) -val recover : t -> Context.t - -val get_sandboxed : Context.t -> Data_encoding.json option tzresult Lwt.t -val set_sandboxed : Context.t -> Data_encoding.json -> Context.t Lwt.t - -val current_level : t -> Level_repr.t -val current_timestamp : t -> Time.t - -val current_fitness : t -> Int64.t -val set_current_fitness : t -> Int64.t -> t - -val constants : t -> Constants_repr.constants -val first_level : t -> Raw_level_repr.t - -(** {1 Entity Accessors} *****************************************************) - open Storage_sigs module Roll : sig @@ -64,50 +28,50 @@ module Roll : sig module Owner : Indexed_data_storage with type key = Roll_repr.t and type value = Contract_repr.t - and type context := t + and type t := Raw_context.t (** The next roll to be allocated. *) module Next : Single_data_storage with type value = Roll_repr.t - and type context := t + and type t := Raw_context.t (** Rolls linked lists represent both account owned and free rolls. All rolls belongs either to the limbo list or to an owned list. *) (** Head of the linked list of rolls in limbo *) - module Limbo : Single_optional_data_storage + module Limbo : Single_data_storage with type value = Roll_repr.t - and type context := t + and type t := Raw_context.t (** Rolls associated to contracts, a linked list per contract *) - module Contract_roll_list : Indexed_optional_data_storage + module Contract_roll_list : Indexed_data_storage with type key = Contract_repr.t and type value = Roll_repr.t - and type context := t + and type t := Raw_context.t (** Use this to iter on a linked list of rolls *) - module Successor : Indexed_optional_data_storage + module Successor : Indexed_data_storage with type key = Roll_repr.t and type value = Roll_repr.t - and type context := t + and type t := Raw_context.t (** The tez of a contract that are not assigned to rolls *) module Contract_change : Indexed_data_storage with type key = Contract_repr.t and type value = Tez_repr.t - and type context := t + and type t := Raw_context.t (** Frozen rolls per cycle *) module Last_for_cycle : Indexed_data_storage with type key = Cycle_repr.t and type value = Roll_repr.t - and type context := t + and type t := Raw_context.t module Owner_for_cycle : Indexed_data_storage - with type key = Cycle_repr.t * Roll_repr.t + with type key = Roll_repr.t and type value = Ed25519.Public_key_hash.t - and type context := t + and type t = Raw_context.t * Cycle_repr.t end @@ -117,68 +81,66 @@ module Contract : sig module `Contract`. *) module Global_counter : sig - val get : t -> int32 tzresult Lwt.t - val set : t -> int32 -> t tzresult Lwt.t - val init : t -> int32 -> t tzresult Lwt.t + val get : Raw_context.t -> int32 tzresult Lwt.t + val set : Raw_context.t -> int32 -> Raw_context.t tzresult Lwt.t + val init : Raw_context.t -> int32 -> Raw_context.t tzresult Lwt.t end (** The domain of alive contracts *) - module Set : Data_set_storage - with type value = Contract_repr.t - and type context := t + val list : Raw_context.t -> Contract_repr.t list Lwt.t (** All the tez possesed by a contract, including rolls and change *) module Balance : Indexed_data_storage with type key = Contract_repr.t and type value = Tez_repr.t - and type context := t + and type t := Raw_context.t (** The manager of a contract *) module Manager : Indexed_data_storage with type key = Contract_repr.t and type value = Manager_repr.t - and type context := t + and type t := Raw_context.t (** The delegate of a contract, if any. *) module Delegate : Indexed_data_storage with type key = Contract_repr.t and type value = Ed25519.Public_key_hash.t - and type context := t + and type t := Raw_context.t module Spendable : Indexed_data_storage with type key = Contract_repr.t and type value = bool - and type context := t + and type t := Raw_context.t module Delegatable : Indexed_data_storage with type key = Contract_repr.t and type value = bool - and type context := t + and type t := Raw_context.t module Counter : Indexed_data_storage with type key = Contract_repr.t and type value = int32 - and type context := t + and type t := Raw_context.t module Code : Indexed_data_storage with type key = Contract_repr.t and type value = Script_repr.expr - and type context := t + and type t := Raw_context.t module Storage : Indexed_data_storage with type key = Contract_repr.t and type value = Script_repr.expr - and type context := t + and type t := Raw_context.t module Code_fees : Indexed_data_storage with type key = Contract_repr.t and type value = Tez_repr.t - and type context := t + and type t := Raw_context.t module Storage_fees : Indexed_data_storage with type key = Contract_repr.t and type value = Tez_repr.t - and type context := t + and type t := Raw_context.t end @@ -188,43 +150,43 @@ module Vote : sig module Current_period_kind : Single_data_storage with type value = Voting_period_repr.kind - and type context := t + and type t := Raw_context.t module Current_quorum : Single_data_storage with type value = int32 (* in centile of percentage *) - and type context := t + and type t := Raw_context.t module Current_proposal : Single_data_storage with type value = Protocol_hash.t - and type context := t + and type t := Raw_context.t module Listings_size : Single_data_storage with type value = int32 (* total number of rolls in the listing. *) - and type context := t + and type t := Raw_context.t - module Listings : Iterable_data_storage + module Listings : Indexed_data_storage with type key = Ed25519.Public_key_hash.t and type value = int32 (* number of rolls for the key. *) - and type context := t + and type t := Raw_context.t module Proposals : Data_set_storage - with type value = Protocol_hash.t * Ed25519.Public_key_hash.t - and type context := t + with type elt = Protocol_hash.t * Ed25519.Public_key_hash.t + and type t := Raw_context.t - module Ballots : Iterable_data_storage + module Ballots : Indexed_data_storage with type key = Ed25519.Public_key_hash.t and type value = Vote_repr.ballot - and type context := t + and type t := Raw_context.t end (** Keys *) -module Public_key : Iterable_data_storage +module Public_key : Indexed_data_storage with type key = Ed25519.Public_key_hash.t and type value = Ed25519.Public_key.t - and type context := t + and type t := Raw_context.t (** Seed *) @@ -242,14 +204,14 @@ module Seed : sig | Revealed of Seed_repr.nonce module Nonce : Indexed_data_storage - with type key = Level_repr.t - and type value = nonce_status - and type context := t + with type key := Level_repr.t + and type value := nonce_status + and type t := Raw_context.t module For_cycle : sig - val init : t -> Cycle_repr.t -> Seed_repr.seed -> t tzresult Lwt.t - val get : t -> Cycle_repr.t -> Seed_repr.seed tzresult Lwt.t - val delete : t -> Cycle_repr.t -> t tzresult Lwt.t + val init : Raw_context.t -> Cycle_repr.t -> Seed_repr.seed -> Raw_context.t tzresult Lwt.t + val get : Raw_context.t -> Cycle_repr.t -> Seed_repr.seed tzresult Lwt.t + val delete : Raw_context.t -> Cycle_repr.t -> Raw_context.t tzresult Lwt.t end end @@ -260,19 +222,16 @@ module Rewards : sig module Next : Single_data_storage with type value = Cycle_repr.t - and type context := t + and type t := Raw_context.t module Date : Indexed_data_storage with type key = Cycle_repr.t and type value = Time.t - and type context := t + and type t := Raw_context.t - module Amount : Iterable_data_storage - with type key = Ed25519.Public_key_hash.t * Cycle_repr.t + module Amount : Indexed_data_storage + with type key = Ed25519.Public_key_hash.t and type value = Tez_repr.t - and type context := t + and type t = Raw_context.t * Cycle_repr.t end - -val activate: t -> Protocol_hash.t -> t Lwt.t -val fork_test_network: t -> Protocol_hash.t -> Time.t -> t Lwt.t diff --git a/src/proto/alpha/storage_functors.ml b/src/proto/alpha/storage_functors.ml index ac6285f6f..fea8b0001 100644 --- a/src/proto/alpha/storage_functors.ml +++ b/src/proto/alpha/storage_functors.ml @@ -7,399 +7,441 @@ (* *) (**************************************************************************) -(* Tezos Protocol Implementation - Typed storage accessor builders *) +open Storage_sigs -open Misc - -type context = { - context: Context.t ; - constants: Constants_repr.constants ; - first_level: Raw_level_repr.t ; - level: Level_repr.t ; - timestamp: Time.t ; - fitness: Int64.t ; -} - -(*-- Errors ------------------------------------------------------------------*) - -type error += Storage_error of string - -let () = - let open Data_encoding in - register_error_kind `Permanent - ~id:"storageError" - ~title: "Storage error (fatal internal error)" - ~description: - "An error that should never happen unless something \ - has been deleted or corrupted in the database" - ~pp:(fun ppf msg -> - Format.fprintf ppf "@[Storage error:@ %a@]" - pp_print_paragraph msg) - (obj1 (req "msg" string)) - (function Storage_error msg -> Some msg | _ -> None) - (fun msg -> Storage_error msg) - -(*-- Generic data accessor ---------------------------------------------------*) - -module type Raw_data_description = sig - type key - type value - val name : string - val key : key -> string list - val of_bytes : MBytes.t -> value tzresult - val to_bytes : value -> MBytes.t +module type ENCODED_VALUE = sig + type t + val encoding: t Data_encoding.t end -module Make_raw_data_storage (P : Raw_data_description) = struct - - type key = P.key - type value = P.value - - let key k = P.key k - - let key_to_string l = String.concat "/" (key l) - - let get { context = c } k = - Context.get c (key k) >>= function - | None -> - let msg = - "cannot get undefined " ^ P.name ^ " key " ^ key_to_string k in - fail (Storage_error msg) - | Some bytes -> - Lwt.return (P.of_bytes bytes) - - let mem { context = c } k = Context.mem c (key k) - - let get_option { context = c } k = - Context.get c (key k) >>= function - | None -> return None - | Some bytes -> - Lwt.return (P.of_bytes bytes >|? fun v -> Some v) - - (* Verify that the key is present before modifying *) - let set ({ context = c } as s) k v = - let key = key k in - Context.get c key >>= function - | None -> - let msg = - "cannot set undefined " ^ P.name ^ " key " ^ key_to_string k in - fail (Storage_error msg) - | Some old -> - let bytes = P.to_bytes v in - if MBytes.(old = bytes) then - return { s with context = c } - else - Context.set c key (P.to_bytes v) >>= fun c -> - return { s with context = c } - - (* Verify that the key is not present before inserting *) - let init ({ context = c } as s) k v = - let key = key k in - Context.get c key >>= - function - | Some _ -> - let msg - = "cannot init existing " ^ P.name ^ " key " ^ key_to_string k in - fail (Storage_error msg) - | None -> - Context.set c key (P.to_bytes v) >>= fun c -> - return { s with context = c } - - (* Does not verify that the key is present or not *) - let init_set ({ context = c } as s) k v = - Context.set c (key k) (P.to_bytes v) >>= fun c -> - return { s with context = c } - - (* Verify that the key is present before deleting *) - let delete ({ context = c } as s) k = - let key = key k in - Context.get c key >>= function - | Some _ -> - Context.del c key >>= fun c -> - return { s with context = c } - | None -> - let msg = - "cannot delete undefined " ^ P.name ^ " key " ^ key_to_string k in - fail (Storage_error msg) - - (* Do not verify before deleting *) - let remove ({ context = c } as s) k = - Context.del c (key k) >>= fun c -> - Lwt.return { s with context = c } - -end - -(*-- Indexed data accessor ---------------------------------------------------*) - -module type Data_description = sig - type value - val name : string - val encoding : value Data_encoding.t -end - -module type Indexed_data_description = sig - type key - val key : key -> string list - include Data_description -end - -module Make_indexed_data_storage (P : Indexed_data_description) = - Make_raw_data_storage(struct - include P - - let of_bytes b = - match Data_encoding.Binary.of_bytes P.encoding b with - | None -> - let msg = - "cannot deserialize " ^ P.name ^ " value" in - error (Storage_error msg) - | Some v -> Ok v - let to_bytes v = Data_encoding.Binary.to_bytes P.encoding v - end) - -module Make_indexed_optional_data_storage (P : Indexed_data_description) = struct - module Raw = Make_indexed_data_storage(P) - type key = P.key - type value = P.value - let get = Raw.get_option - let mem = Raw.mem - let set c k r = - match r with - | None -> Raw.remove c k >>= fun c -> return c - | Some r -> Raw.init_set c k r -end - -(*-- Single data accessor ----------------------------------------------------*) - -module type Single_data_description = sig - val key : string list - include Data_description -end - -module Make_single_data_storage (P : Single_data_description) = struct - module Single_desc = struct - type value = P.value - type key = unit - let encoding = P.encoding - let name = P.name - let key () = P.key - end - include Make_indexed_data_storage(Single_desc) - let get c = get c () - let mem c = mem c () - let get_option c = get_option c () - let set c r = set c () r - let init c r = init c () r - let init_set c r = init_set c () r - let remove c = remove c () - let delete c = delete c () -end - -module Make_single_optional_data_storage (P : Single_data_description) = struct - module Raw = Make_single_data_storage (P) - type value = P.value - let get = Raw.get_option - let mem = Raw.mem - let set c r = - match r with - | None -> Raw.remove c >>= fun c -> return c - | Some r -> Raw.init_set c r -end - -(*-- Data set (set of homogeneous data under a key prefix) -------------------*) - -module Make_data_set_storage (P : Single_data_description) = struct - - module Key = struct - include Hash.Make_minimal_Blake2B(struct - let name = P.name - let title = ("A " ^ P.name ^ "key") - let size = None - end) - let of_path = of_path_exn - let prefix = P.key - let length = path_length - end - - module HashTbl = - Persist.MakePersistentMap(Context)(Key)(Persist.RawValue) - - type value = P.value - - let serial v = - let data = Data_encoding.Binary.to_bytes P.encoding v in - Key.hash_bytes [data], data - - let unserial b = - match Data_encoding.Binary.of_bytes P.encoding b with - | None -> - let msg = - "cannot deserialize " ^ P.name ^ " value" in - error (Storage_error msg) +module Make_value (V : ENCODED_VALUE) = struct + type t = V.t + let of_bytes b = + match Data_encoding.Binary.of_bytes V.encoding b with + | None -> Error [Raw_context.Storage_error (Corrupted_data [(* FIXME??*)])] | Some v -> Ok v - - let add ({ context = c } as s) v = - let hash, data = serial v in - HashTbl.mem c hash >>= function - | true -> - return { s with context = c } - | false -> - HashTbl.set c hash data >>= fun c -> - return { s with context = c } - - let del ({ context = c } as s) v = - let hash, _ = serial v in - HashTbl.mem c hash >>= function - | false -> - return { s with context = c } - | true -> - HashTbl.del c hash >>= fun c -> - return { s with context = c } - - let mem { context = c } v = - let hash, _ = serial v in - HashTbl.mem c hash >>= fun v -> - return v - - let elements { context = c } = - HashTbl.bindings c >>= fun elts -> - map_s (fun (_, data) -> Lwt.return (unserial data)) elts - - let fold { context = c } init ~f = - HashTbl.fold c ~init:(ok init) - ~f:(fun _ data acc -> - match acc with - | Error _ -> Lwt.return acc - | Ok acc -> - match unserial data with - | Error _ as err -> Lwt.return err - | Ok data -> - f data acc >>= fun acc -> - return acc) - - let clear ({ context = c } as s) = - HashTbl.fold c ~init:c ~f:(fun hash _ c -> HashTbl.del c hash) >>= fun c -> - return { s with context = c } - + let to_bytes v = + try Data_encoding.Binary.to_bytes V.encoding v + with _ -> MBytes.create 0 end -module Raw_make_iterable_data_storage - (K: Persist.KEY) - (P: Data_description) = struct +module Raw_value = struct + type t = MBytes.t + let of_bytes b = ok b + let to_bytes b = b +end - type key = K.t - type value = P.value +let map_key f = function + | `Key k -> `Key (f k) + | `Dir k -> `Dir (f k) - module HashTbl = - Persist.MakePersistentMap(Context)(K)(struct - type t = P.value - let of_bytes b = Data_encoding.Binary.of_bytes P.encoding b - let to_bytes v = Data_encoding.Binary.to_bytes P.encoding v - end) +let map_option f = function + | None -> None + | Some x -> Some (f x) - let key_to_string k = String.concat "/" (K.to_path k) +module Make_subcontext (C : Raw_context.T) (N : NAME) + : Raw_context.T with type t = C.t = struct + type t = C.t + type context = t + let name_length = List.length N.name + let to_key k = N.name @ k + let of_key k = Misc.remove_elem_from_list name_length k + let mem t k = C.mem t (to_key k) + let dir_mem t k = C.dir_mem t (to_key k) + let get t k = C.get t (to_key k) + let get_option t k = C.get_option t (to_key k) + let init t k v = C.init t (to_key k) v + let set t k v = C.set t (to_key k) v + let init_set t k v = C.init_set t (to_key k) v + let set_option t k v = C.set_option t (to_key k) v + let delete t k = C.delete t (to_key k) + let remove t k = C.remove t (to_key k) + let remove_rec t k = C.remove_rec t (to_key k) + let fold t k ~init ~f = + C.fold t (to_key k) ~init + ~f:(fun k acc -> f (map_key of_key k) acc) + let keys t k = C.keys t (to_key k) >|= fun keys -> List.map of_key keys + let fold_keys t k ~init ~f = + C.fold_keys t (to_key k) ~init ~f:(fun k acc -> f (of_key k) acc) + let project = C.project +end - let get { context = c } k = - HashTbl.get c k >>= function - | None -> - let msg = - "cannot get undefined " ^ P.name ^ " key " ^ key_to_string k in - fail (Storage_error msg) - | Some v -> - return v - - let mem { context = c } k = HashTbl.mem c k - - let get_option { context = c } k = - HashTbl.get c k >>= function +module Make_single_data_storage (C : Raw_context.T) (N : NAME) (V : VALUE) + : Single_data_storage with type t = C.t + and type value = V.t = struct + type t = C.t + type context = t + type value = V.t + let mem t = + C.mem t N.name + let get t = + C.get t N.name >>=? fun b -> + Lwt.return (V.of_bytes b) + let get_option t = + C.get_option t N.name >>= function | None -> return None - | Some v -> return (Some v) + | Some b -> + match V.of_bytes b with + | Ok v -> return (Some v) + | Error _ as err -> Lwt.return err + let init t v = + C.init t N.name (V.to_bytes v) >>=? fun t -> + return (C.project t) + let set t v = + C.set t N.name (V.to_bytes v) >>=? fun t -> + return (C.project t) + let init_set t v = + C.init_set t N.name (V.to_bytes v) >>= fun t -> + Lwt.return (C.project t) + let set_option t v = + C.set_option t N.name (map_option V.to_bytes v) >>= fun t -> + Lwt.return (C.project t) + let remove t = + C.remove t N.name >>= fun t -> + Lwt.return (C.project t) + let delete t = + C.delete t N.name >>=? fun t -> + return (C.project t) +end - (* Verify that the key is present before modifying *) - let set ({ context = c } as s) k v = - HashTbl.get c k >>= function - | None -> - let msg = - "cannot set undefined " ^ P.name ^ " key " ^ key_to_string k in - fail (Storage_error msg) - | Some _ -> - HashTbl.set c k v >>= fun c -> - return { s with context = c } +module type INDEX = sig + type t + val path_length: int + val to_path: t -> string list -> string list + val of_path: string list -> t option +end - (* Verify that the key is not present before inserting *) - let init ({ context = c } as s) k v = - HashTbl.get c k >>= - function - | Some _ -> - let msg - = "cannot init existing " ^ P.name ^ " key " ^ key_to_string k in - fail (Storage_error msg) - | None -> - HashTbl.set c k v >>= fun c -> - return { s with context = c } +module Pair(I1 : INDEX)(I2 : INDEX) + : INDEX with type t = I1.t * I2.t = struct + type t = I1.t * I2.t + let path_length = I1.path_length + I2.path_length + let to_path (x, y) l = I1.to_path x (I2.to_path y l) + let of_path l = + match Misc.take I1.path_length l with + | None -> None + | Some (l1, l2) -> + match I1.of_path l1, I2.of_path l2 with + | Some x, Some y -> Some (x, y) + | _ -> None +end - (* Does not verify that the key is present or not *) - let init_set ({ context = c } as s) k v = - HashTbl.set c k v >>= fun c -> - return { s with context = c } +module Make_data_set_storage (C : Raw_context.T) (I : INDEX) + : Data_set_storage with type t = C.t and type elt = I.t = struct - (* Verify that the key is present before deleting *) - let delete ({ context = c } as s) k = - HashTbl.get c k >>= function - | Some _ -> - HashTbl.del c k >>= fun c -> - return { s with context = c } - | None -> - let msg = - "cannot delete undefined " ^ P.name ^ " key " ^ key_to_string k in - fail (Storage_error msg) + type t = C.t + type context = t + type elt = I.t - (* Do not verify before deleting *) - let remove ({ context = c } as s) k = - HashTbl.del c k >>= fun c -> - Lwt.return { s with context = c } + let inited = MBytes.of_string "inited" - let clear ({ context = c } as s) = - HashTbl.clear c >>= fun c -> - Lwt.return { s with context = c } + let mem s i = + C.mem s (I.to_path i []) + let add s i = + C.init_set s (I.to_path i []) inited >>= fun t -> + Lwt.return (C.project t) + let del s i = + C.remove s (I.to_path i []) >>= fun t -> + Lwt.return (C.project t) + let clear s = + C.remove_rec s [] >>= fun t -> + Lwt.return (C.project t) - let fold { context = c } x ~f = HashTbl.fold c ~init:x ~f:(fun k v acc -> f k v acc) - let iter { context = c } ~f = HashTbl.fold c ~init:() ~f:(fun k v () -> f k v) + let fold s ~init ~f = + let rec dig i path acc = + if Compare.Int.(i <= 1) then + C.fold s path ~init:acc ~f:begin fun k acc -> + match k with + | `Dir _ -> Lwt.return acc + | `Key file -> + match I.of_path file with + | None -> assert false + | Some p -> f p acc + end + else + C.fold s path ~init:acc ~f:begin fun k acc -> + match k with + | `Dir k -> + dig (i-1) k acc + | `Key _ -> + Lwt.return acc + end in + dig I.path_length [] init + + let elements s = + fold s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc)) end -module Make_iterable_data_storage (H: HASH) (P: Single_data_description) = - Raw_make_iterable_data_storage(struct - include H - let of_path = H.of_path_exn - let prefix = P.key - let length = path_length - end)(P) +module Make_indexed_data_storage + (C : Raw_context.T) (I : INDEX) (V : VALUE) + : Indexed_data_storage with type t = C.t + and type key = I.t + and type value = V.t = struct + type t = C.t + type context = t + type key = I.t + type value = V.t + let mem s i = + C.mem s (I.to_path i []) + let get s i = + C.get s (I.to_path i []) >>=? fun b -> + Lwt.return (V.of_bytes b) + let get_option s i = + C.get_option s (I.to_path i []) >>= function + | None -> return None + | Some b -> + match V.of_bytes b with + | Ok v -> return (Some v) + | Error _ as err -> Lwt.return err + let set s i v = + C.set s (I.to_path i []) (V.to_bytes v) >>=? fun t -> + return (C.project t) + let init s i v = + C.init s (I.to_path i []) (V.to_bytes v) >>=? fun t -> + return (C.project t) + let init_set s i v = + C.init_set s (I.to_path i []) (V.to_bytes v) >>= fun t -> + Lwt.return (C.project t) + let set_option s i v = + C.set_option s (I.to_path i []) (map_option V.to_bytes v) >>= fun t -> + Lwt.return (C.project t) + let remove s i = + C.remove s (I.to_path i []) >>= fun t -> + Lwt.return (C.project t) + let delete s i = + C.delete s (I.to_path i []) >>=? fun t -> + return (C.project t) + let clear s = + C.remove_rec s [] >>= fun t -> + Lwt.return (C.project t) + let fold s ~init ~f = + let rec dig i path acc = + if Compare.Int.(i <= 1) then + C.fold s path ~init:acc ~f:begin fun k acc -> + match k with + | `Dir _ -> Lwt.return acc + | `Key file -> + C.get_option s file >>= function + | None -> Lwt.return acc + | Some b -> + match V.of_bytes b with + | Error _ -> + (* Silently ignore unparsable data *) + Lwt.return acc + | Ok v -> + match I.of_path file with + | None -> assert false + | Some path -> f path v acc + end + else + C.fold s path ~init:acc ~f:begin fun k acc -> + match k with + | `Dir k -> dig (i-1) k acc + | `Key _ -> Lwt.return acc + end in + dig I.path_length [] init -let register_resolvers (module H : Hash.HASH) prefixes = + let bindings s = + fold s ~init:[] ~f:(fun p v acc -> Lwt.return ((p,v) :: acc)) + let fold_keys s ~init ~f = + C.fold s [] ~init + ~f:(fun p acc -> + match p with + | `Dir _ -> Lwt.return acc + | `Key p -> + match I.of_path p with + | None -> assert false + | Some path -> f path acc) + let keys s = + fold_keys s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc)) - let module Set = H.Set in +end - let resolvers = - List.map - (fun prefix -> - let module R = Persist.MakeHashResolver(struct - include Context - let prefix = prefix - end)(H) in - R.resolve) - prefixes in +module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) + : Indexed_raw_context with type t = C.t + and type key = I.t = struct - let resolve c m = - match resolvers with - | [resolve] -> resolve c m - | resolvers -> - Lwt_list.map_p (fun resolve -> resolve c m) resolvers >|= fun hs -> - List.fold_left - (fun acc hs -> List.fold_left (fun acc h -> Set.add h acc) acc hs) - Set.empty hs |> - Set.elements in + type t = C.t + type context = t + type key = I.t - Context.register_resolver H.b58check_encoding resolve + module Raw_context = struct + type t = C.t * I.t + type context = t + let to_key i k = I.to_path i k + let of_key k = Misc.remove_elem_from_list I.path_length k + let mem (t, i) k = C.mem t (to_key i k) + let dir_mem (t, i) k = C.dir_mem t (to_key i k) + let get (t, i) k = C.get t (to_key i k) + let get_option (t, i) k = C.get_option t (to_key i k) + let init (t, i) k v = + C.init t (to_key i k) v >>=? fun t -> return (t, i) + let set (t, i) k v = + C.set t (to_key i k) v >>=? fun t -> return (t, i) + let init_set (t, i) k v = + C.init_set t (to_key i k) v >>= fun t -> Lwt.return (t, i) + let set_option (t, i) k v = + C.set_option t (to_key i k) v >>= fun t -> Lwt.return (t, i) + let delete (t, i) k = + C.delete t (to_key i k) >>=? fun t -> return (t, i) + let remove (t, i) k = + C.remove t (to_key i k) >>= fun t -> Lwt.return (t, i) + let remove_rec (t, i) k = + C.remove_rec t (to_key i k) >>= fun t -> Lwt.return (t, i) + let fold (t, i) k ~init ~f = + C.fold t (to_key i k) ~init + ~f:(fun k acc -> f (map_key of_key k) acc) + let keys (t, i) k = C.keys t (to_key i k) >|= fun keys -> List.map of_key keys + let fold_keys (t, i) k ~init ~f = + C.fold_keys t (to_key i k) ~init ~f:(fun k acc -> f (of_key k) acc) + let project (t, _) = C.project t + end + let clear t i = + Raw_context.remove_rec (t, i) [] >>= fun (t, _) -> + Lwt.return (C.project t) + let fold_keys t ~init ~f = + let rec dig i path acc = + if Compare.Int.(i <= 0) then + match I.of_path path with + | None -> assert false + | Some path -> f path acc + else + C.fold t path ~init:acc ~f:begin fun k acc -> + match k with + | `Dir k -> dig (i-1) k acc + | `Key _ -> Lwt.return acc + end in + dig I.path_length [] init + + let keys t = + fold_keys t ~init:[] ~f:(fun i acc -> Lwt.return (i :: acc)) + + let list t k = C.fold t k ~init:[] ~f:(fun k acc -> Lwt.return (k :: acc)) + let resolve t prefix = + let rec loop i prefix = function + | [] when Compare.Int.(i = I.path_length) -> begin + match I.of_path prefix with + | None -> assert false + | Some path -> Lwt.return [path] + end + | [] -> + list t prefix >>= fun prefixes -> + Lwt_list.map_p (function + | `Key prefix | `Dir prefix -> loop (i+1) prefix []) prefixes + >|= List.flatten + | [d] when Compare.Int.(i = I.path_length - 1) -> + if Compare.Int.(i >= I.path_length) then invalid_arg "IO.resolve" ; + list t prefix >>= fun prefixes -> + Lwt_list.map_p (function + | `Key prefix | `Dir prefix -> + match Misc.remove_prefix ~prefix:d (List.hd (List.rev prefix)) with + | None -> Lwt.return_nil + | Some _ -> loop (i+1) prefix []) + prefixes + >|= List.flatten + | "" :: ds -> + list t prefix >>= fun prefixes -> + Lwt_list.map_p (function + | `Key prefix | `Dir prefix -> loop (i+1) prefix ds) prefixes + >|= List.flatten + | d :: ds -> + if Compare.Int.(i >= I.path_length) then invalid_arg "IO.resolve" ; + C.dir_mem t (prefix @ [d]) >>= function + | true -> loop (i+1) (prefix @ [d]) ds + | false -> Lwt.return_nil in + loop 0 [] prefix + + module Make_set (N : NAME) = struct + type t = C.t + type context = t + type elt = I.t + let inited = MBytes.of_string "inited" + let mem s i = Raw_context.mem (s, i) N.name + let add s i = + Raw_context.init_set (s, i) N.name inited >>= fun (s, _) -> + Lwt.return (C.project s) + let del s i = + Raw_context.remove (s, i) N.name >>= fun (s, _) -> + Lwt.return (C.project s) + let clear s = + fold_keys s + ~init:s + ~f:begin fun i s -> + Raw_context.remove (s, i) N.name >>= fun (s, _) -> + Lwt.return s + end >>= fun t -> + Lwt.return (C.project t) + let fold s ~init ~f = + fold_keys s ~init + ~f:(fun i acc -> + mem s i >>= function + | true -> f i acc + | false -> Lwt.return acc) + let elements s = + fold s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc)) + end + + module Make_map (N : NAME) (V : VALUE) = struct + type t = C.t + type context = t + type key = I.t + type value = V.t + let mem s i = + Raw_context.mem (s,i) N.name + let get s i = + Raw_context.get (s,i) N.name >>=? fun b -> + Lwt.return (V.of_bytes b) + let get_option s i = + Raw_context.get_option (s,i) N.name >>= function + | None -> return None + | Some b -> + match V.of_bytes b with + | Ok v -> return (Some v) + | Error _ as err -> Lwt.return err + let set s i v = + Raw_context.set (s,i) N.name (V.to_bytes v) >>=? fun (s, _) -> + return (C.project s) + let init s i v = + Raw_context.init (s,i) N.name (V.to_bytes v) >>=? fun (s, _) -> + return (C.project s) + let init_set s i v = + Raw_context.init_set (s,i) N.name (V.to_bytes v) >>= fun (s, _) -> + Lwt.return (C.project s) + let set_option s i v = + Raw_context.set_option (s,i) + N.name (map_option V.to_bytes v) >>= fun (s, _) -> + Lwt.return (C.project s) + let remove s i = + Raw_context.remove (s,i) N.name >>= fun (s, _) -> + Lwt.return (C.project s) + let delete s i = + Raw_context.delete (s,i) N.name >>=? fun (s, _) -> + return (C.project s) + let clear s = + fold_keys s ~init:s + ~f:begin fun i s -> + Raw_context.remove (s,i) N.name >>= fun (s, _) -> + Lwt.return s + end >>= fun t -> + Lwt.return (C.project t) + let fold s ~init ~f = + fold_keys s ~init + ~f:(fun i acc -> + get s i >>= function + | Error _ -> Lwt.return acc + | Ok v -> f i v acc) + let bindings s = + fold s ~init:[] ~f:(fun p v acc -> Lwt.return ((p,v) :: acc)) + let fold_keys s ~init ~f = + fold_keys s ~init + ~f:(fun i acc -> + mem s i >>= function + | false -> Lwt.return acc + | true -> f i acc) + let keys s = + fold_keys s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc)) + end + +end diff --git a/src/proto/alpha/storage_functors.mli b/src/proto/alpha/storage_functors.mli index b043234f7..2f2e4c714 100644 --- a/src/proto/alpha/storage_functors.mli +++ b/src/proto/alpha/storage_functors.mli @@ -7,103 +7,43 @@ (* *) (**************************************************************************) -(** Tezos Protocol Implementation - Typed storage accessor builders - - This module hides the hierarchical (key x value) database under - three kinds of typed data accessors (single typed data, homgeneous - indexed data and homgeneous data set). *) - - -type context = { - context: Context.t ; - constants: Constants_repr.constants ; - first_level: Raw_level_repr.t ; - level: Level_repr.t ; - timestamp: Time.t ; - fitness: Int64.t ; -} +(** Tezos Protocol Implementation - Typed storage builders. *) open Storage_sigs -(** {1 Errors} ****************************************************************) - -(** An internal storage error that should not happen *) -type error += Storage_error of string - -(** {1 Data Accessor Parameters} *********************************************) - -(** Description of a single data typed accessor. *) -module type Data_description = sig - (** The OCaml type of value contents *) - type value - - (** A name (only used for error messages) *) - val name : string - - (** The serialization format *) - val encoding : value Data_encoding.t +module type ENCODED_VALUE = sig + type t + val encoding: t Data_encoding.t end -module type Single_data_description = sig +module Make_value (V : ENCODED_VALUE) : VALUE with type t = V.t - (** The concrete key in the hierarchical database *) - val key : string list +module Raw_value : VALUE with type t = MBytes.t - include Data_description +module Make_subcontext (C : Raw_context.T) (N : NAME) + : Raw_context.T with type t = C.t +module Make_single_data_storage (C : Raw_context.T) (N : NAME) (V : VALUE) + : Single_data_storage with type t = C.t + and type value = V.t + +module type INDEX = sig + type t + val path_length: int + val to_path: t -> string list -> string list + val of_path: string list -> t option end -(** Describes how to map abstract OCaml types for some (key x value) - pair to the concrete path in the hierarchical database structure - and the serialization format. *) -module type Indexed_data_description = sig +module Pair(I1 : INDEX)(I2 : INDEX) : INDEX with type t = I1.t * I2.t - (** The OCaml type for keys *) - type key +module Make_data_set_storage (C : Raw_context.T) (I : INDEX) + : Data_set_storage with type t = C.t and type elt = I.t - (** How to produce a concrete key from an abstract one *) - val key : key -> string list - - include Data_description - -end - -(** {1 Data Accessor Builders} ***********************************************) - -(** Single data typed accessor builder *) -module Make_single_data_storage (P : Single_data_description) : - Single_data_storage with type value = P.value - and type context := context - -module Make_single_optional_data_storage (P : Single_data_description) : - Single_optional_data_storage with type value = P.value - and type context := context - -(** Indexed data accessor builder *) -module Make_indexed_data_storage (P : Indexed_data_description) : - Indexed_data_storage with type key = P. key - and type value = P.value - and type context := context - -module Make_indexed_optional_data_storage (P : Indexed_data_description) : - Indexed_optional_data_storage with type key = P. key - and type value = P.value - and type context := context - -(** Data set builder (set of homogeneous data under a key prefix) *) -module Make_data_set_storage (P : Single_data_description) : - Data_set_storage with type value = P.value - and type context := context - -module Make_iterable_data_storage (H : HASH) (P: Single_data_description) : - Iterable_data_storage with type key = H.t - and type value = P.value - and type context := context - -module Raw_make_iterable_data_storage (K: Persist.KEY) (P: Data_description) : - Iterable_data_storage with type key = K.t - and type value = P.value - and type context := context - -val register_resolvers: (module Hash.HASH) -> string list list -> unit +module Make_indexed_data_storage (C : Raw_context.T) (I : INDEX) (V : VALUE) + : Indexed_data_storage with type t = C.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/storage_sigs.ml b/src/proto/alpha/storage_sigs.ml index 36051009d..7624760df 100644 --- a/src/proto/alpha/storage_sigs.ml +++ b/src/proto/alpha/storage_sigs.ml @@ -9,66 +9,56 @@ (** {1 Entity Accessor Signatures} ****************************************) -module type Single_optional_data_storage = sig - type context - type value - val get : context -> value option tzresult Lwt.t - val mem : context -> bool Lwt.t - val set : context -> value option -> context tzresult Lwt.t -end - (** The generic signature of a single data accessor (a single value bound to a specific key in the hierarchical (key x value) database). *) module type Single_data_storage = sig - type context + type t + type context = t (** The type of the value *) type value + (** Tells if the data is already defined *) + val mem: context -> bool Lwt.t + (** Retrieve the value from the storage bucket ; returns a {!Storage_error} if the key is not set or if the deserialisation fails *) - val get : context -> value tzresult Lwt.t + val get: context -> value tzresult Lwt.t (** Retrieves the value from the storage bucket ; returns [None] if the data is not initialized, or {!Storage_helpers.Storage_error} if the deserialisation fails *) - val get_option : context -> value option tzresult Lwt.t - - (** Tells if the data is already defined *) - val mem : context -> bool Lwt.t - - (** Updates the content of the bucket ; returns a {!Storage_Error} - if the value does not exists *) - val set : context -> value -> context tzresult Lwt.t + val get_option: context -> value option tzresult Lwt.t (** Allocates the storage bucket and initializes it ; returns a - {!Storage_error} if the bucket exists *) - val init : context -> value -> context tzresult Lwt.t + {!Storage_error Missing_key} if the bucket exists *) + val init: context -> value -> Raw_context.t tzresult Lwt.t - (** Delete the storage bucket ; returns a {!Storage_error} if the - bucket does not exists *) - val delete : context -> context tzresult Lwt.t + (** Updates the content of the bucket ; returns a {!Storage_Error + Existing_key} if the value does not exists *) + val set: context -> value -> Raw_context.t tzresult Lwt.t (** Allocates the data and initializes it with a value ; just updates it if the bucket exists *) - val init_set : context -> value -> context tzresult Lwt.t + val init_set: context -> value -> Raw_context.t Lwt.t - (** Removes the storage bucket and its contents ; does nothing if the - bucket does not exists *) - val remove : context -> context Lwt.t + (** When the value is [Some v], allocates the data and initializes + it with [v] ; just updates it if the bucket exists. When the + valus is [None], delete the storage bucket when the value ; does + nothing if the bucket does not exists. *) + val set_option: context -> value option -> Raw_context.t Lwt.t -end + (** Delete the storage bucket ; returns a {!Storage_error + Missing_key} if the bucket does not exists *) + val delete: context -> Raw_context.t tzresult Lwt.t + + (** Removes the storage bucket and its contents ; does nothing if + the bucket does not exists *) + val remove: context -> Raw_context.t Lwt.t -module type Indexed_optional_data_storage = sig - type context - type key - type value - val get : context -> key -> value option tzresult Lwt.t - val mem : context -> key -> bool Lwt.t - val set : context -> key -> value option -> context tzresult Lwt.t end (** The generic signature of indexed data accessors (a set of values @@ -76,7 +66,8 @@ end hierarchical (key x value) database). *) module type Indexed_data_storage = sig - type context + type t + type context = t (** An abstract type for keys *) type key @@ -84,46 +75,56 @@ module type Indexed_data_storage = sig (** The type of values *) type value - (** Retrieve a value from the storage bucket at a given key ; - returns a {!Storage_error} if the key is not set or if the - deserialisation fails *) - val get : context -> key -> value tzresult Lwt.t - (** Tells if a given key is already bound to a storage bucket *) - val mem : context -> key -> bool Lwt.t + val mem: context -> key -> bool Lwt.t (** Retrieve a value from the storage bucket at a given key ; - returns [None] if the value is not set an error if the - deserialisation fails *) - val get_option : context -> key -> value option tzresult Lwt.t + returns {!Storage_error Missing_key} if the key is not set ; + returns {!Storage_error Corrupted_data} if the deserialisation + fails. *) + val get: context -> key -> value tzresult Lwt.t - (** Updates the content of a bucket ; returns A {!Storage_Error} if - the value does not exists *) - val set : context -> key -> value -> context tzresult Lwt.t + (** Retrieve a value from the storage bucket at a given key ; + returns [None] if the value is not set ; returns {!Storage_error + Corrupted_data} if the deserialisation fails. *) + val get_option: context -> key -> value option tzresult Lwt.t + + (** Updates the content of a bucket ; returns A {!Storage_Error + Missing_key} if the value does not exists. *) + val set: context -> key -> value -> Raw_context.t tzresult Lwt.t (** Allocates a storage bucket at the given key and initializes it ; - returns a {!Storage_error} if the bucket exists *) - val init : context -> key -> value -> context tzresult Lwt.t - - (** Delete a storage bucket and its contents ; returns a - {!Storage_error} if the bucket does not exists *) - val delete : context -> key -> context tzresult Lwt.t + returns a {!Storage_error Existing_key} if the bucket exists. *) + val init: context -> key -> value -> Raw_context.t tzresult Lwt.t (** Allocates a storage bucket at the given key and initializes it - with a value ; just updates it if the bucket exists *) - val init_set : context -> key -> value -> context tzresult Lwt.t + with a value ; just updates it if the bucket exists. *) + val init_set: context -> key -> value -> Raw_context.t Lwt.t + + (** When the value is [Some v], allocates the data and initializes + it with [v] ; just updates it if the bucket exists. When the + valus is [None], delete the storage bucket when the value ; does + nothing if the bucket does not exists. *) + val set_option: context -> key -> value option -> Raw_context.t Lwt.t + + (** Delete a storage bucket and its contents ; returns a + {!Storage_error Missing_key} if the bucket does not exists. *) + val delete: context -> key -> Raw_context.t tzresult Lwt.t (** Removes a storage bucket and its contents ; does nothing if the - bucket does not exists *) - val remove : context -> key -> context Lwt.t + bucket does not exists. *) + val remove: context -> key -> Raw_context.t Lwt.t -end + val clear: context -> Raw_context.t Lwt.t + + val keys: context -> key list Lwt.t + val bindings: context -> (key * value) list Lwt.t + + val fold: + context -> init:'a -> f:(key -> value -> 'a -> 'a Lwt.t) -> 'a Lwt.t + val fold_keys: + context -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t -module type Iterable_data_storage = sig - include Indexed_data_storage - val iter : context -> f:(key -> value -> unit Lwt.t) -> unit Lwt.t - val fold : context -> 'a -> f:(key -> value -> 'a -> 'a Lwt.t) -> 'a Lwt.t - val clear : context -> context Lwt.t end (** The generic signature of a data set accessor (a set of values @@ -131,28 +132,65 @@ end database). *) module type Data_set_storage = sig - type context + type t + type context = t - (** The type of values *) - type value + (** The type of elements. *) + type elt - (** Tells if a value is a member of the set *) - val mem : context -> value -> bool tzresult Lwt.t + (** Tells if a elt is a member of the set *) + val mem: context -> elt -> bool Lwt.t - (** Adds a value is a member of the set *) - val add : context -> value -> context tzresult Lwt.t + (** Adds a elt is a member of the set *) + val add: context -> elt -> Raw_context.t Lwt.t - (** Removes a value of the set ; does nothing if not a member *) - val del : context -> value -> context tzresult Lwt.t + (** Removes a elt of the set ; does nothing if not a member *) + val del: context -> elt -> Raw_context.t Lwt.t (** Returns the elements of the set, deserialized in a list in no - particular order ; returns a {!Storage_helpers.Storage_error} if - a deserialization error occurs *) - val elements : context -> value list tzresult Lwt.t + particular order. *) + val elements: context -> elt list Lwt.t - val fold : - context -> 'a -> f:(value -> 'a -> 'a Lwt.t) -> 'a tzresult Lwt.t + val fold: context -> init:'a -> f:(elt -> 'a -> 'a Lwt.t) -> 'a Lwt.t (** Removes all elements in the set *) - val clear : context -> context tzresult Lwt.t + val clear: context -> Raw_context.t Lwt.t + +end + +module type NAME = sig + val name: Raw_context.key +end + +module type VALUE = sig + type t + val of_bytes: MBytes.t -> t tzresult + val to_bytes: t -> MBytes.t +end + +module type Indexed_raw_context = sig + + type t + type context = t + type key + + val clear: context -> key -> Raw_context.t Lwt.t + + val fold_keys: + context -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t + val keys: context -> key list Lwt.t + + val resolve: context -> string list -> key list Lwt.t + + module Make_set (N : NAME) + : Data_set_storage with type t = t + and type elt = key + + module Make_map (N : NAME) (V : VALUE) + : Indexed_data_storage with type t = t + and type key = key + and type value = V.t + + module Raw_context : Raw_context.T with type t = t * key + end diff --git a/src/proto/alpha/tezos_context.ml b/src/proto/alpha/tezos_context.ml index 2908d343d..ea563379f 100644 --- a/src/proto/alpha/tezos_context.ml +++ b/src/proto/alpha/tezos_context.ml @@ -7,7 +7,7 @@ (* *) (**************************************************************************) -type t = Storage.t +type t = Raw_context.t type context = t module type BASIC_DATA = sig @@ -22,7 +22,7 @@ module Period = Period_repr module Timestamp = struct include Time_repr - let current = Storage.current_timestamp + let current = Raw_context.current_timestamp end include Operation_repr @@ -41,7 +41,7 @@ module Script_int = Script_int_repr module Script_timestamp = struct include Script_timestamp_repr let now ctxt = - Storage.current_timestamp ctxt + Raw_context.current_timestamp ctxt |> Timestamp.to_seconds |> of_int64 end @@ -59,31 +59,31 @@ include Tezos_hash module Constants = struct include Constants_repr let cycle_length c = - let constants = Storage.constants c in + let constants = Raw_context.constants c in constants.cycle_length let voting_period_length c = - let constants = Storage.constants c in + let constants = Raw_context.constants c in constants.voting_period_length let time_before_reward c = - let constants = Storage.constants c in + let constants = Raw_context.constants c in constants.time_before_reward let slot_durations c = - let constants = Storage.constants c in + let constants = Raw_context.constants c in constants.slot_durations let first_free_baking_slot c = - let constants = Storage.constants c in + let constants = Raw_context.constants c in constants.first_free_baking_slot let max_signing_slot c = - let constants = Storage.constants c in + let constants = Raw_context.constants c in constants.max_signing_slot let instructions_per_transaction c = - let constants = Storage.constants c in + let constants = Raw_context.constants c in constants.instructions_per_transaction let proof_of_work_threshold c = - let constants = Storage.constants c in + let constants = Raw_context.constants c in constants.proof_of_work_threshold let dictator_pubkey c = - let constants = Storage.constants c in + let constants = Raw_context.constants c in constants.dictator_pubkey end @@ -124,10 +124,10 @@ let init = Init_storage.may_initialize let finalize ?commit_message:message c = let fitness = Fitness.from_int64 (Fitness.current c) in - let context = Storage.recover c in + let context = Raw_context.recover c in { Updater.context ; fitness ; message ; max_operations_ttl = 60 } -let configure_sandbox = Init_storage.configure_sandbox +let configure_sandbox = Raw_context.configure_sandbox -let activate = Storage.activate -let fork_test_network = Storage.fork_test_network +let activate = Raw_context.activate +let fork_test_network = Raw_context.fork_test_network diff --git a/src/proto/alpha/tezos_context.mli b/src/proto/alpha/tezos_context.mli index 7dc7a9e26..15e440179 100644 --- a/src/proto/alpha/tezos_context.mli +++ b/src/proto/alpha/tezos_context.mli @@ -295,7 +295,7 @@ module Delegates_pubkey : sig context -> public_key_hash -> context Lwt.t val list: - context -> (public_key_hash * public_key) list tzresult Lwt.t + context -> (public_key_hash * public_key) list Lwt.t end @@ -413,7 +413,7 @@ module Contract : sig val exists: context -> contract -> bool tzresult Lwt.t val must_exist: context -> contract -> unit tzresult Lwt.t - val list: context -> contract list tzresult Lwt.t + val list: context -> contract list Lwt.t type origination_nonce @@ -485,10 +485,10 @@ module Vote : sig val record_proposal: context -> Protocol_hash.t -> public_key_hash -> - context tzresult Lwt.t + context Lwt.t val get_proposals: - context -> int32 Protocol_hash.Map.t tzresult Lwt.t - val clear_proposals: context -> context tzresult Lwt.t + context -> int32 Protocol_hash.Map.t Lwt.t + val clear_proposals: context -> context Lwt.t val freeze_listings: context -> context tzresult Lwt.t val clear_listings: context -> context tzresult Lwt.t @@ -504,7 +504,7 @@ module Vote : sig } val record_ballot: - context -> public_key_hash -> ballot -> context tzresult Lwt.t + context -> public_key_hash -> ballot -> context Lwt.t val get_ballots: context -> ballots tzresult Lwt.t val clear_ballots: context -> context Lwt.t diff --git a/src/proto/alpha/vote_storage.ml b/src/proto/alpha/vote_storage.ml index 8c04df24a..a42058c66 100644 --- a/src/proto/alpha/vote_storage.ml +++ b/src/proto/alpha/vote_storage.ml @@ -11,7 +11,8 @@ let record_proposal ctxt delegate proposal = Storage.Vote.Proposals.add ctxt (delegate, proposal) let get_proposals ctxt = - Storage.Vote.Proposals.fold ctxt Protocol_hash.Map.empty + Storage.Vote.Proposals.fold ctxt + ~init:Protocol_hash.Map.empty ~f:(fun (proposal, _delegate) acc -> let previous = try Protocol_hash.Map.find proposal acc @@ -41,7 +42,7 @@ let get_ballots ctxt = | Nay -> ok { ballots with nay = count ballots.nay } | Pass -> ok { ballots with pass = count ballots.pass } end) - (ok { yay = 0l ; nay = 0l; pass = 0l }) + ~init:(ok { yay = 0l ; nay = 0l; pass = 0l }) let clear_ballots = Storage.Vote.Ballots.clear @@ -57,7 +58,7 @@ let freeze_listings ctxt = | Some count -> return count end >>=? fun count -> Storage.Vote.Listings.init_set - ctxt delegate (Int32.succ count) >>=? fun ctxt -> + ctxt delegate (Int32.succ count) >>= fun ctxt -> return (ctxt, Int32.succ total)) >>=? fun (ctxt, total) -> Storage.Vote.Listings_size.init ctxt total >>=? fun ctxt -> return ctxt diff --git a/src/proto/alpha/vote_storage.mli b/src/proto/alpha/vote_storage.mli index d6de70328..7a4020ac7 100644 --- a/src/proto/alpha/vote_storage.mli +++ b/src/proto/alpha/vote_storage.mli @@ -8,13 +8,13 @@ (**************************************************************************) val record_proposal: - Storage.t -> Protocol_hash.t -> Ed25519.Public_key_hash.t -> - Storage.t tzresult Lwt.t + Raw_context.t -> Protocol_hash.t -> Ed25519.Public_key_hash.t -> + Raw_context.t Lwt.t val get_proposals: - Storage.t -> int32 Protocol_hash.Map.t tzresult Lwt.t + Raw_context.t -> int32 Protocol_hash.Map.t Lwt.t -val clear_proposals: Storage.t -> Storage.t tzresult Lwt.t +val clear_proposals: Raw_context.t -> Raw_context.t Lwt.t type ballots = { yay: int32 ; @@ -23,30 +23,30 @@ type ballots = { } val record_ballot: - Storage.t -> Ed25519.Public_key_hash.t -> Vote_repr.ballot -> - Storage.t tzresult Lwt.t -val get_ballots: Storage.t -> ballots tzresult Lwt.t -val clear_ballots: Storage.t -> Storage.t Lwt.t + Raw_context.t -> Ed25519.Public_key_hash.t -> Vote_repr.ballot -> + Raw_context.t Lwt.t +val get_ballots: Raw_context.t -> ballots tzresult Lwt.t +val clear_ballots: Raw_context.t -> Raw_context.t Lwt.t -val freeze_listings: Storage.t -> Storage.t tzresult Lwt.t -val clear_listings: Storage.t -> Storage.t tzresult Lwt.t +val freeze_listings: Raw_context.t -> Raw_context.t tzresult Lwt.t +val clear_listings: Raw_context.t -> Raw_context.t tzresult Lwt.t -val listing_size: Storage.t -> int32 tzresult Lwt.t +val listing_size: Raw_context.t -> int32 tzresult Lwt.t val in_listings: - Storage.t -> Ed25519.Public_key_hash.t -> bool Lwt.t + Raw_context.t -> Ed25519.Public_key_hash.t -> bool Lwt.t -val get_current_quorum: Storage.t -> int32 tzresult Lwt.t -val set_current_quorum: Storage.t -> int32 -> Storage.t tzresult Lwt.t +val get_current_quorum: Raw_context.t -> int32 tzresult Lwt.t +val set_current_quorum: Raw_context.t -> int32 -> Raw_context.t tzresult Lwt.t val get_current_period_kind: - Storage.t -> Voting_period_repr.kind tzresult Lwt.t + Raw_context.t -> Voting_period_repr.kind tzresult Lwt.t val set_current_period_kind: - Storage.t -> Voting_period_repr.kind -> Storage.t tzresult Lwt.t + Raw_context.t -> Voting_period_repr.kind -> Raw_context.t tzresult Lwt.t val get_current_proposal: - Storage.t -> Protocol_hash.t tzresult Lwt.t + Raw_context.t -> Protocol_hash.t tzresult Lwt.t val init_current_proposal: - Storage.t -> Protocol_hash.t -> Storage.t tzresult Lwt.t -val clear_current_proposal: Storage.t -> Storage.t tzresult Lwt.t + Raw_context.t -> Protocol_hash.t -> Raw_context.t tzresult Lwt.t +val clear_current_proposal: Raw_context.t -> Raw_context.t tzresult Lwt.t -val init: Storage.t -> Storage.t tzresult Lwt.t +val init: Raw_context.t -> Raw_context.t tzresult Lwt.t diff --git a/src/utils/hash.ml b/src/utils/hash.ml index 862035519..de3fc64ea 100644 --- a/src/utils/hash.ml +++ b/src/utils/hash.ml @@ -54,7 +54,7 @@ module type MINIMAL_HASH = sig val read: MBytes.t -> int -> t val write: MBytes.t -> int -> t -> unit - val to_path: t -> string list + val to_path: t -> string list -> string list val of_path: string list -> t option val of_path_exn: string list -> t @@ -226,11 +226,11 @@ module Make_minimal_Blake2B (K : Name) = struct loop init off let path_length = 6 - let to_path key = + let to_path key l = let key = to_hex key in - [ String.sub key 0 2 ; String.sub key 2 2 ; - String.sub key 4 2 ; String.sub key 6 2 ; - String.sub key 8 2 ; String.sub key 10 (size * 2 - 10) ] + String.sub key 0 2 :: String.sub key 2 2 :: + String.sub key 4 2 :: String.sub key 6 2 :: + String.sub key 8 2 :: String.sub key 10 (size * 2 - 10) :: l let of_path path = let path = String.concat "" path in of_hex path @@ -677,7 +677,7 @@ module Net_id = struct loop init off let path_length = 1 - let to_path key = [to_hex key] + let to_path key l = to_hex key :: l let of_path path = let path = String.concat "" path in of_hex path diff --git a/src/utils/hash.mli b/src/utils/hash.mli index d1617648c..2f151dea1 100644 --- a/src/utils/hash.mli +++ b/src/utils/hash.mli @@ -48,7 +48,7 @@ module type MINIMAL_HASH = sig val read: MBytes.t -> int -> t val write: MBytes.t -> int -> t -> unit - val to_path: t -> string list + val to_path: t -> string list -> string list val of_path: string list -> t option val of_path_exn: string list -> t diff --git a/test/proto_alpha/proto_alpha_helpers.ml b/test/proto_alpha/proto_alpha_helpers.ml index 0bda22cb2..3e242575e 100644 --- a/test/proto_alpha/proto_alpha_helpers.ml +++ b/test/proto_alpha/proto_alpha_helpers.ml @@ -342,9 +342,8 @@ module Assert = struct Assert.contain_error ~msg ~f:(ecoproto_error (fun _ -> true)) let unknown_contract ~msg = - let open Storage_functors in Assert.contain_error ~msg ~f:begin ecoproto_error (function - | Storage_error _ -> true + | Raw_context.Storage_error _ -> true | _ -> false) end