balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Proto: reimplements Storage_functors with iterable indexes

Browse Source 
The new `Storage_functors` is now a "functional" equivalent of the
"imperative" `Store_helpers` used in the shell.
This commit is contained in:
Grégoire Henry 2017-11-16 16:45:22 +01:00 committed by Benjamin Canou
parent b6b59be5fd
commit 17644e0fa3
49 changed files with 1671 additions and 1960 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
src/environment/v1/context.mli
View File

@ -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

2
src/environment/v1/hash.mli
View File

@ -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

20
src/node/db/store_helpers.ml
View File

@ -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

2
src/node/db/store_sigs.ml
View File

@ -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

2
src/proto/alpha/TEZOS_PROTOCOL
View File

@ -26,7 +26,7 @@
"Manager_repr",
"Block_header_repr",
"Persist",
"Raw_context",
"Storage_sigs",
"Storage_functors",
"Storage",

10
src/proto/alpha/amendment.ml
View File

@ -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 ->

4
src/proto/alpha/bootstrap_storage.ml
View File

@ -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 ->

6
src/proto/alpha/bootstrap_storage.mli
View File

@ -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

30
src/proto/alpha/contract_repr.ml
View File

@ -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

9
src/proto/alpha/contract_repr.mli
View File

@ -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

11
src/proto/alpha/contract_storage.ml
View File

@ -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 ->

48
src/proto/alpha/contract_storage.mli
View File

@ -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

13
src/proto/alpha/cycle_repr.ml
View File

@ -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

8
src/proto/alpha/cycle_repr.mli
View File

@ -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

4
src/proto/alpha/fitness_storage.ml
View File

@ -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)

24
src/proto/alpha/init_storage.ml
View File

@ -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

1
src/proto/alpha/level_repr.ml
View File

@ -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

12
src/proto/alpha/level_storage.ml
View File

@ -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

16
src/proto/alpha/level_storage.mli
View File

@ -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

10
src/proto/alpha/nonce_storage.mli
View File

@ -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

422
src/proto/alpha/persist.ml
View File

@ -1,422 +0,0 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2017. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* 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

218
src/proto/alpha/persist.mli
View File

@ -1,218 +0,0 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2017. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* 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

10
src/proto/alpha/public_key_storage.ml
View File

@ -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

10
src/proto/alpha/public_key_storage.mli
View File

@ -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

339
src/proto/alpha/raw_context.ml Normal file
View File

@ -0,0 +1,339 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2017. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* 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
"@[<v 2>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
"@[<v 2>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

134
src/proto/alpha/raw_context.mli Normal file
View File

@ -0,0 +1,134 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2017. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* 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

12
src/proto/alpha/raw_level_repr.ml
View File

@ -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

7
src/proto/alpha/raw_level_repr.mli
View File

@ -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

29
src/proto/alpha/reward_storage.ml
View File

@ -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 ->

10
src/proto/alpha/reward_storage.mli
View File

@ -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

16
src/proto/alpha/roll_repr.ml
View File

@ -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

7
src/proto/alpha/roll_repr.mli
View File

@ -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

41
src/proto/alpha/roll_storage.ml
View File

@ -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

22
src/proto/alpha/roll_storage.mli
View File

@ -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

2
src/proto/alpha/seed_repr.mli
View File

@ -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} *****************************************************)

8
src/proto/alpha/seed_storage.mli
View File

@ -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

7
src/proto/alpha/services_registration.ml
View File

@ -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 =

765
src/proto/alpha/storage.ml
View File

@ -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)

141
src/proto/alpha/storage.mli
View File

@ -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

778
src/proto/alpha/storage_functors.ml
View File

@ -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 "@[<v 2>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

114
src/proto/alpha/storage_functors.mli
View File

@ -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

196
src/proto/alpha/storage_sigs.ml
View File

@ -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

32
src/proto/alpha/tezos_context.ml
View File

@ -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

12
src/proto/alpha/tezos_context.mli
View File

@ -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

7
src/proto/alpha/vote_storage.ml
View File

@ -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

40
src/proto/alpha/vote_storage.mli
View File

@ -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

12
src/utils/hash.ml
View File

@ -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

2
src/utils/hash.mli
View File

@ -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

3
test/proto_alpha/proto_alpha_helpers.ml
View File

@ -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