upgrade to babylon
This commit is contained in:
parent
e497af2313
commit
56269231b3
@ -32,24 +32,24 @@ module Ty = struct
|
|||||||
let mutez = Mutez_t None
|
let mutez = Mutez_t None
|
||||||
let string = String_t None
|
let string = String_t None
|
||||||
let key = Key_t None
|
let key = Key_t None
|
||||||
let list a = List_t (a, None)
|
let list a = List_t (a, None , has_big_map a)
|
||||||
let set a = Set_t (a, None)
|
let set a = Set_t (a, None)
|
||||||
let address = Address_t None
|
let address = Address_t None
|
||||||
let option a = Option_t ((a, None), None, None)
|
let option a = Option_t (a, None , has_big_map a)
|
||||||
let contract a = Contract_t (a, None)
|
let contract a = Contract_t (a, None)
|
||||||
let lambda a b = Lambda_t (a, b, None)
|
let lambda a b = Lambda_t (a, b, None)
|
||||||
let timestamp = Timestamp_t None
|
let timestamp = Timestamp_t None
|
||||||
let map a b = Map_t (a, b, None)
|
let map a b = Map_t (a, b, None , has_big_map b)
|
||||||
let pair a b = Pair_t ((a, None, None), (b, None, None), None)
|
let pair a b = Pair_t ((a, None, None), (b, None, None), None , has_big_map a || has_big_map b)
|
||||||
let union a b = Union_t ((a, None), (b, None), None)
|
let union a b = Union_t ((a, None), (b, None), None , has_big_map a || has_big_map b)
|
||||||
|
|
||||||
let field_annot = Option.map (fun ann -> `Field_annot ann)
|
let field_annot = Option.map (fun ann -> `Field_annot ann)
|
||||||
|
|
||||||
let union_ann (anna, a) (annb, b) =
|
let union_ann (anna, a) (annb, b) =
|
||||||
Union_t ((a, field_annot anna), (b, field_annot annb), None)
|
Union_t ((a, field_annot anna), (b, field_annot annb), None , has_big_map a || has_big_map b)
|
||||||
|
|
||||||
let pair_ann (anna, a) (annb, b) =
|
let pair_ann (anna, a) (annb, b) =
|
||||||
Pair_t ((a, field_annot anna, None), (b, field_annot annb, None), None)
|
Pair_t ((a, field_annot anna, None), (b, field_annot annb, None), None , has_big_map a || has_big_map b)
|
||||||
|
|
||||||
let not_comparable name () = error (thunk "not a comparable type") (fun () -> name) ()
|
let not_comparable name () = error (thunk "not a comparable type") (fun () -> name) ()
|
||||||
let not_compilable_type name () = error (thunk "not a compilable type") (fun () -> name) ()
|
let not_compilable_type name () = error (thunk "not a compilable type") (fun () -> name) ()
|
||||||
|
@ -8,16 +8,16 @@ open Script_ir_translator
|
|||||||
|
|
||||||
let rec translate_value ?bm_opt (Ex_typed_value (ty, value)) : value result =
|
let rec translate_value ?bm_opt (Ex_typed_value (ty, value)) : value result =
|
||||||
match (ty, value) with
|
match (ty, value) with
|
||||||
| Pair_t ((a_ty, _, _), (b_ty, _, _), _), (a, b) -> (
|
| Pair_t ((a_ty, _, _), (b_ty, _, _), _ , _), (a, b) -> (
|
||||||
let%bind a = translate_value ?bm_opt @@ Ex_typed_value(a_ty, a) in
|
let%bind a = translate_value ?bm_opt @@ Ex_typed_value(a_ty, a) in
|
||||||
let%bind b = translate_value ?bm_opt @@ Ex_typed_value(b_ty, b) in
|
let%bind b = translate_value ?bm_opt @@ Ex_typed_value(b_ty, b) in
|
||||||
ok @@ D_pair(a, b)
|
ok @@ D_pair(a, b)
|
||||||
)
|
)
|
||||||
| Union_t ((a_ty, _), _, _), L a -> (
|
| Union_t ((a_ty, _), _, _ , _), L a -> (
|
||||||
let%bind a = translate_value ?bm_opt @@ Ex_typed_value(a_ty, a) in
|
let%bind a = translate_value ?bm_opt @@ Ex_typed_value(a_ty, a) in
|
||||||
ok @@ D_left a
|
ok @@ D_left a
|
||||||
)
|
)
|
||||||
| Union_t (_, (b_ty, _), _), R b -> (
|
| Union_t (_, (b_ty, _), _ , _), R b -> (
|
||||||
let%bind b = translate_value ?bm_opt @@ Ex_typed_value(b_ty, b) in
|
let%bind b = translate_value ?bm_opt @@ Ex_typed_value(b_ty, b) in
|
||||||
ok @@ D_right b
|
ok @@ D_right b
|
||||||
)
|
)
|
||||||
@ -47,16 +47,16 @@ let rec translate_value ?bm_opt (Ex_typed_value (ty, value)) : value result =
|
|||||||
ok @@ D_string s
|
ok @@ D_string s
|
||||||
| (Bytes_t _), b ->
|
| (Bytes_t _), b ->
|
||||||
ok @@ D_bytes (Tezos_stdlib.MBytes.to_bytes b)
|
ok @@ D_bytes (Tezos_stdlib.MBytes.to_bytes b)
|
||||||
| (Address_t _), s ->
|
| (Address_t _), (s , _) ->
|
||||||
ok @@ D_string (Alpha_context.Contract.to_b58check s)
|
ok @@ D_string (Alpha_context.Contract.to_b58check s)
|
||||||
| (Unit_t _), () ->
|
| (Unit_t _), () ->
|
||||||
ok @@ D_unit
|
ok @@ D_unit
|
||||||
| (Option_t _), None ->
|
| (Option_t _), None ->
|
||||||
ok @@ D_none
|
ok @@ D_none
|
||||||
| (Option_t ((o_ty, _), _, _)), Some s ->
|
| (Option_t (o_ty, _, _)), Some s ->
|
||||||
let%bind s' = translate_value @@ Ex_typed_value (o_ty, s) in
|
let%bind s' = translate_value @@ Ex_typed_value (o_ty, s) in
|
||||||
ok @@ D_some s'
|
ok @@ D_some s'
|
||||||
| (Map_t (k_cty, v_ty, _)), m ->
|
| (Map_t (k_cty, v_ty, _ , _)), m ->
|
||||||
let k_ty = Script_ir_translator.ty_of_comparable_ty k_cty in
|
let k_ty = Script_ir_translator.ty_of_comparable_ty k_cty in
|
||||||
let lst =
|
let lst =
|
||||||
let aux k v acc = (k, v) :: acc in
|
let aux k v acc = (k, v) :: acc in
|
||||||
@ -95,7 +95,7 @@ let rec translate_value ?bm_opt (Ex_typed_value (ty, value)) : value result =
|
|||||||
| None -> ok orig_rem in
|
| None -> ok orig_rem in
|
||||||
bind_fold_list aux original_big_map lst in
|
bind_fold_list aux original_big_map lst in
|
||||||
ok @@ D_big_map lst'
|
ok @@ D_big_map lst'
|
||||||
| (List_t (ty, _)), lst ->
|
| (List_t (ty, _ , _)), lst ->
|
||||||
let%bind lst' =
|
let%bind lst' =
|
||||||
let aux = fun t -> translate_value (Ex_typed_value (ty, t)) in
|
let aux = fun t -> translate_value (Ex_typed_value (ty, t)) in
|
||||||
bind_map_list aux lst
|
bind_map_list aux lst
|
||||||
@ -113,7 +113,7 @@ let rec translate_value ?bm_opt (Ex_typed_value (ty, value)) : value result =
|
|||||||
in
|
in
|
||||||
ok @@ D_set lst''
|
ok @@ D_set lst''
|
||||||
)
|
)
|
||||||
| (Operation_t _) , op ->
|
| (Operation_t _) , (op , _) ->
|
||||||
ok @@ D_operation op
|
ok @@ D_operation op
|
||||||
| ty, v ->
|
| ty, v ->
|
||||||
let%bind error =
|
let%bind error =
|
||||||
|
@ -92,6 +92,11 @@ let arity : prim -> int option = function
|
|||||||
| I_ISNAT -> Some 1
|
| I_ISNAT -> Some 1
|
||||||
| I_CAST -> None
|
| I_CAST -> None
|
||||||
| I_RENAME -> None
|
| I_RENAME -> None
|
||||||
|
| I_CHAIN_ID -> Some 0
|
||||||
|
| I_EMPTY_BIG_MAP -> Some 0
|
||||||
|
| I_APPLY -> None
|
||||||
|
| I_DIG -> None
|
||||||
|
| I_DUG -> None
|
||||||
|
|
||||||
| K_parameter
|
| K_parameter
|
||||||
| K_storage
|
| K_storage
|
||||||
@ -126,7 +131,9 @@ let arity : prim -> int option = function
|
|||||||
| T_timestamp
|
| T_timestamp
|
||||||
| T_unit
|
| T_unit
|
||||||
| T_operation
|
| T_operation
|
||||||
| T_address -> None
|
| T_address
|
||||||
|
| T_chain_id
|
||||||
|
-> None
|
||||||
|
|
||||||
let is_nullary_op (p : prim) : bool =
|
let is_nullary_op (p : prim) : bool =
|
||||||
match arity p with
|
match arity p with
|
||||||
|
2
vendors/ligo-utils/memory-proto-alpha/dune
vendored
2
vendors/ligo-utils/memory-proto-alpha/dune
vendored
@ -3,6 +3,6 @@
|
|||||||
(public_name tezos-memory-proto-alpha)
|
(public_name tezos-memory-proto-alpha)
|
||||||
(libraries
|
(libraries
|
||||||
tezos-protocol-environment
|
tezos-protocol-environment
|
||||||
tezos-protocol-alpha
|
tezos-protocol-005-PsBabyM1
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
|
@ -1,9 +1,9 @@
|
|||||||
module Name = struct let name = "alpha" end
|
module Name = struct let name = "alpha" end
|
||||||
module Alpha_environment = Tezos_protocol_alpha.Protocol.Environment
|
module Alpha_environment = Tezos_protocol_005_PsBabyM1.Protocol.Environment
|
||||||
|
|
||||||
|
|
||||||
type alpha_error = Alpha_environment.Error_monad.error
|
type alpha_error = Alpha_environment.Error_monad.error
|
||||||
type 'a alpha_tzresult = 'a Alpha_environment.Error_monad.tzresult
|
type 'a alpha_tzresult = 'a Alpha_environment.Error_monad.tzresult
|
||||||
module Alpha_error_monad = Alpha_environment.Error_monad
|
module Alpha_error_monad = Alpha_environment.Error_monad
|
||||||
module Proto = Tezos_protocol_alpha
|
module Proto = Tezos_protocol_005_PsBabyM1
|
||||||
include Proto
|
include Proto
|
||||||
|
@ -10,7 +10,7 @@ bug-reports: "https://gitlab.com/ligolang/tezos/issues"
|
|||||||
depends: [
|
depends: [
|
||||||
"dune"
|
"dune"
|
||||||
"tezos-protocol-environment"
|
"tezos-protocol-environment"
|
||||||
"tezos-protocol-alpha"
|
"tezos-protocol-005-PsBabyM1"
|
||||||
]
|
]
|
||||||
build: [
|
build: [
|
||||||
["dune" "build" "-p" name]
|
["dune" "build" "-p" name]
|
||||||
|
109
vendors/ligo-utils/proto-alpha-utils/cast.ml
vendored
109
vendors/ligo-utils/proto-alpha-utils/cast.ml
vendored
@ -56,13 +56,14 @@ include struct
|
|||||||
open Michelson_v1_primitives
|
open Michelson_v1_primitives
|
||||||
open Protocol.Environment
|
open Protocol.Environment
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
let rec unparse_data_generic
|
let rec unparse_data_generic
|
||||||
: type a. context -> ?mapper:(ex_typed_value -> Script.node option tzresult Lwt.t) ->
|
: type a. context -> ?mapper:_ -> unparsing_mode -> a ty -> a -> (Script.node * context) tzresult Lwt.t
|
||||||
unparsing_mode -> a ty -> a -> (Script.node * context) tzresult Lwt.t
|
|
||||||
= fun ctxt ?(mapper = fun _ -> return None) mode ty a ->
|
= fun ctxt ?(mapper = fun _ -> return None) mode ty a ->
|
||||||
Lwt.return (Gas.consume ctxt Unparse_costs.cycle) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt Unparse_costs.cycle) >>=? fun ctxt ->
|
||||||
mapper (Ex_typed_value (ty, a)) >>=? function
|
mapper (Ex_typed_value (ty, a)) >>=? function
|
||||||
| Some x -> return (x, ctxt)
|
| Some x -> return (x , ctxt)
|
||||||
| None -> (
|
| None -> (
|
||||||
match ty, a with
|
match ty, a with
|
||||||
| Unit_t _, () ->
|
| Unit_t _, () ->
|
||||||
@ -96,23 +97,37 @@ include struct
|
|||||||
| None -> return (Int (-1, Script_timestamp.to_zint t), ctxt)
|
| None -> return (Int (-1, Script_timestamp.to_zint t), ctxt)
|
||||||
| Some s -> return (String (-1, s), ctxt)
|
| Some s -> return (String (-1, s), ctxt)
|
||||||
end
|
end
|
||||||
| Address_t _, c ->
|
| Address_t _, (c, entrypoint) ->
|
||||||
Lwt.return (Gas.consume ctxt Unparse_costs.contract) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt Unparse_costs.contract) >>=? fun ctxt ->
|
||||||
begin
|
begin
|
||||||
match mode with
|
match mode with
|
||||||
| Optimized ->
|
| Optimized ->
|
||||||
let bytes = Data_encoding.Binary.to_bytes_exn Contract.encoding c in
|
let entrypoint = match entrypoint with "default" -> "" | name -> name in
|
||||||
|
let bytes = Data_encoding.Binary.to_bytes_exn
|
||||||
|
Data_encoding.(tup2 Contract.encoding Variable.string)
|
||||||
|
(c, entrypoint) in
|
||||||
return (Bytes (-1, bytes), ctxt)
|
return (Bytes (-1, bytes), ctxt)
|
||||||
| Readable -> return (String (-1, Contract.to_b58check c), ctxt)
|
| Readable ->
|
||||||
|
let notation = match entrypoint with
|
||||||
|
| "default" -> Contract.to_b58check c
|
||||||
|
| entrypoint -> Contract.to_b58check c ^ "%" ^ entrypoint in
|
||||||
|
return (String (-1, notation), ctxt)
|
||||||
end
|
end
|
||||||
| Contract_t _, (_, c) ->
|
| Contract_t _, (_, (c, entrypoint)) ->
|
||||||
Lwt.return (Gas.consume ctxt Unparse_costs.contract) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt Unparse_costs.contract) >>=? fun ctxt ->
|
||||||
begin
|
begin
|
||||||
match mode with
|
match mode with
|
||||||
| Optimized ->
|
| Optimized ->
|
||||||
let bytes = Data_encoding.Binary.to_bytes_exn Contract.encoding c in
|
let entrypoint = match entrypoint with "default" -> "" | name -> name in
|
||||||
|
let bytes = Data_encoding.Binary.to_bytes_exn
|
||||||
|
Data_encoding.(tup2 Contract.encoding Variable.string)
|
||||||
|
(c, entrypoint) in
|
||||||
return (Bytes (-1, bytes), ctxt)
|
return (Bytes (-1, bytes), ctxt)
|
||||||
| Readable -> return (String (-1, Contract.to_b58check c), ctxt)
|
| Readable ->
|
||||||
|
let notation = match entrypoint with
|
||||||
|
| "default" -> Contract.to_b58check c
|
||||||
|
| entrypoint -> Contract.to_b58check c ^ "%" ^ entrypoint in
|
||||||
|
return (String (-1, notation), ctxt)
|
||||||
end
|
end
|
||||||
| Signature_t _, s ->
|
| Signature_t _, s ->
|
||||||
Lwt.return (Gas.consume ctxt Unparse_costs.signature) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt Unparse_costs.signature) >>=? fun ctxt ->
|
||||||
@ -147,35 +162,39 @@ include struct
|
|||||||
| Readable ->
|
| Readable ->
|
||||||
return (String (-1, Signature.Public_key_hash.to_b58check k), ctxt)
|
return (String (-1, Signature.Public_key_hash.to_b58check k), ctxt)
|
||||||
end
|
end
|
||||||
| Operation_t _, op ->
|
| Operation_t _, (op, _big_map_diff) ->
|
||||||
let bytes = Data_encoding.Binary.to_bytes_exn Alpha_context.Operation.internal_operation_encoding op in
|
let bytes = Data_encoding.Binary.to_bytes_exn Alpha_context.Operation.internal_operation_encoding op in
|
||||||
Lwt.return (Gas.consume ctxt (Unparse_costs.operation bytes)) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt (Unparse_costs.operation bytes)) >>=? fun ctxt ->
|
||||||
return (Bytes (-1, bytes), ctxt)
|
return (Bytes (-1, bytes), ctxt)
|
||||||
| Pair_t ((tl, _, _), (tr, _, _), _), (l, r) ->
|
| Chain_id_t _, chain_id ->
|
||||||
|
let bytes = Data_encoding.Binary.to_bytes_exn Chain_id.encoding chain_id in
|
||||||
|
Lwt.return (Gas.consume ctxt (Unparse_costs.chain_id bytes)) >>=? fun ctxt ->
|
||||||
|
return (Bytes (-1, bytes), ctxt)
|
||||||
|
| Pair_t ((tl, _, _), (tr, _, _), _, _), (l, r) ->
|
||||||
Lwt.return (Gas.consume ctxt Unparse_costs.pair) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt Unparse_costs.pair) >>=? fun ctxt ->
|
||||||
unparse_data_generic ~mapper ctxt mode tl l >>=? fun (l, ctxt) ->
|
unparse_data_generic ctxt mode tl l >>=? fun (l, ctxt) ->
|
||||||
unparse_data_generic ~mapper ctxt mode tr r >>=? fun (r, ctxt) ->
|
unparse_data_generic ctxt mode tr r >>=? fun (r, ctxt) ->
|
||||||
return (Prim (-1, D_Pair, [ l; r ], []), ctxt)
|
return (Prim (-1, D_Pair, [ l; r ], []), ctxt)
|
||||||
| Union_t ((tl, _), _, _), L l ->
|
| Union_t ((tl, _), _, _, _), L l ->
|
||||||
Lwt.return (Gas.consume ctxt Unparse_costs.union) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt Unparse_costs.union) >>=? fun ctxt ->
|
||||||
unparse_data_generic ~mapper ctxt mode tl l >>=? fun (l, ctxt) ->
|
unparse_data_generic ctxt mode tl l >>=? fun (l, ctxt) ->
|
||||||
return (Prim (-1, D_Left, [ l ], []), ctxt)
|
return (Prim (-1, D_Left, [ l ], []), ctxt)
|
||||||
| Union_t (_, (tr, _), _), R r ->
|
| Union_t (_, (tr, _), _, _), R r ->
|
||||||
Lwt.return (Gas.consume ctxt Unparse_costs.union) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt Unparse_costs.union) >>=? fun ctxt ->
|
||||||
unparse_data_generic ~mapper ctxt mode tr r >>=? fun (r, ctxt) ->
|
unparse_data_generic ctxt mode tr r >>=? fun (r, ctxt) ->
|
||||||
return (Prim (-1, D_Right, [ r ], []), ctxt)
|
return (Prim (-1, D_Right, [ r ], []), ctxt)
|
||||||
| Option_t ((t, _), _, _), Some v ->
|
| Option_t (t, _, _), Some v ->
|
||||||
Lwt.return (Gas.consume ctxt Unparse_costs.some) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt Unparse_costs.some) >>=? fun ctxt ->
|
||||||
unparse_data_generic ~mapper ctxt mode t v >>=? fun (v, ctxt) ->
|
unparse_data_generic ctxt mode t v >>=? fun (v, ctxt) ->
|
||||||
return (Prim (-1, D_Some, [ v ], []), ctxt)
|
return (Prim (-1, D_Some, [ v ], []), ctxt)
|
||||||
| Option_t _, None ->
|
| Option_t _, None ->
|
||||||
Lwt.return (Gas.consume ctxt Unparse_costs.none) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt Unparse_costs.none) >>=? fun ctxt ->
|
||||||
return (Prim (-1, D_None, [], []), ctxt)
|
return (Prim (-1, D_None, [], []), ctxt)
|
||||||
| List_t (t, _), items ->
|
| List_t (t, _, _), items ->
|
||||||
fold_left_s
|
fold_left_s
|
||||||
(fun (l, ctxt) element ->
|
(fun (l, ctxt) element ->
|
||||||
Lwt.return (Gas.consume ctxt Unparse_costs.list_element) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt Unparse_costs.list_element) >>=? fun ctxt ->
|
||||||
unparse_data_generic ~mapper ctxt mode t element >>=? fun (unparsed, ctxt) ->
|
unparse_data_generic ctxt mode t element >>=? fun (unparsed, ctxt) ->
|
||||||
return (unparsed :: l, ctxt))
|
return (unparsed :: l, ctxt))
|
||||||
([], ctxt)
|
([], ctxt)
|
||||||
items >>=? fun (items, ctxt) ->
|
items >>=? fun (items, ctxt) ->
|
||||||
@ -185,39 +204,60 @@ include struct
|
|||||||
fold_left_s
|
fold_left_s
|
||||||
(fun (l, ctxt) item ->
|
(fun (l, ctxt) item ->
|
||||||
Lwt.return (Gas.consume ctxt Unparse_costs.set_element) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt Unparse_costs.set_element) >>=? fun ctxt ->
|
||||||
unparse_data_generic ~mapper ctxt mode t item >>=? fun (item, ctxt) ->
|
unparse_data_generic ctxt mode t item >>=? fun (item, ctxt) ->
|
||||||
return (item :: l, ctxt))
|
return (item :: l, ctxt))
|
||||||
([], ctxt)
|
([], ctxt)
|
||||||
(set_fold (fun e acc -> e :: acc) set []) >>=? fun (items, ctxt) ->
|
(set_fold (fun e acc -> e :: acc) set []) >>=? fun (items, ctxt) ->
|
||||||
return (Micheline.Seq (-1, items), ctxt)
|
return (Micheline.Seq (-1, items), ctxt)
|
||||||
| Map_t (kt, vt, _), map ->
|
| Map_t (kt, vt, _, _), map ->
|
||||||
let kt = ty_of_comparable_ty kt in
|
let kt = ty_of_comparable_ty kt in
|
||||||
fold_left_s
|
fold_left_s
|
||||||
(fun (l, ctxt) (k, v) ->
|
(fun (l, ctxt) (k, v) ->
|
||||||
Lwt.return (Gas.consume ctxt Unparse_costs.map_element) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt Unparse_costs.map_element) >>=? fun ctxt ->
|
||||||
unparse_data_generic ~mapper ctxt mode kt k >>=? fun (key, ctxt) ->
|
unparse_data_generic ctxt mode kt k >>=? fun (key, ctxt) ->
|
||||||
unparse_data_generic ~mapper ctxt mode vt v >>=? fun (value, ctxt) ->
|
unparse_data_generic ctxt mode vt v >>=? fun (value, ctxt) ->
|
||||||
return (Prim (-1, D_Elt, [ key ; value ], []) :: l, ctxt))
|
return (Prim (-1, D_Elt, [ key ; value ], []) :: l, ctxt))
|
||||||
([], ctxt)
|
([], ctxt)
|
||||||
(map_fold (fun k v acc -> (k, v) :: acc) map []) >>=? fun (items, ctxt) ->
|
(map_fold (fun k v acc -> (k, v) :: acc) map []) >>=? fun (items, ctxt) ->
|
||||||
return (Micheline.Seq (-1, items), ctxt)
|
return (Micheline.Seq (-1, items), ctxt)
|
||||||
| Big_map_t (_kt, _kv, _), _map ->
|
| Big_map_t (kt, vt, _), { id = None ; diff = (module Diff) ; _ } ->
|
||||||
return (Micheline.Seq (-1, []), ctxt)
|
(* this branch is to allow roundtrip of big map literals *)
|
||||||
|
let kt = ty_of_comparable_ty kt in
|
||||||
|
fold_left_s
|
||||||
|
(fun (l, ctxt) (k, v) ->
|
||||||
|
Lwt.return (Gas.consume ctxt Unparse_costs.map_element) >>=? fun ctxt ->
|
||||||
|
unparse_data_generic ctxt mode kt k >>=? fun (key, ctxt) ->
|
||||||
|
unparse_data_generic ctxt mode vt v >>=? fun (value, ctxt) ->
|
||||||
|
return (Prim (-1, D_Elt, [ key ; value ], []) :: l, ctxt))
|
||||||
|
([], ctxt)
|
||||||
|
(Diff.OPS.fold
|
||||||
|
(fun k v acc -> match v with | None -> acc | Some v -> (k, v) :: acc)
|
||||||
|
(fst Diff.boxed) []) >>=? fun (items, ctxt) ->
|
||||||
|
return (Micheline.Seq (-1, items), ctxt)
|
||||||
|
| Big_map_t (_kt, _kv, _), { id = Some id ; diff = (module Diff) ; _ } ->
|
||||||
|
if Compare.Int.(Diff.OPS.cardinal (fst Diff.boxed) = 0) then
|
||||||
|
return (Micheline.Int (-1, id), ctxt)
|
||||||
|
else
|
||||||
|
(* this can only be the result of an execution and the map
|
||||||
|
must have been flushed at this point *)
|
||||||
|
assert false
|
||||||
| Lambda_t _, Lam (_, original_code) ->
|
| Lambda_t _, Lam (_, original_code) ->
|
||||||
unparse_code_generic ~mapper ctxt mode (root original_code)
|
unparse_code_generic ctxt ~mapper mode original_code
|
||||||
)
|
)
|
||||||
|
|
||||||
and unparse_code_generic ctxt ?mapper mode = function
|
and unparse_code_generic ctxt ?mapper mode =
|
||||||
|
let legacy = true in
|
||||||
|
function
|
||||||
| Prim (loc, I_PUSH, [ ty ; data ], annot) ->
|
| Prim (loc, I_PUSH, [ ty ; data ], annot) ->
|
||||||
Lwt.return (parse_ty ctxt ~allow_big_map:false ~allow_operation:false ty) >>=? fun (Ex_ty t, ctxt) ->
|
Lwt.return (parse_packable_ty ctxt ~legacy ty) >>=? fun (Ex_ty t, ctxt) ->
|
||||||
parse_data ctxt t data >>=? fun (data, ctxt) ->
|
parse_data ctxt ~legacy t data >>=? fun (data, ctxt) ->
|
||||||
unparse_data_generic ?mapper ctxt mode t data >>=? fun (data, ctxt) ->
|
unparse_data_generic ctxt ?mapper mode t data >>=? fun (data, ctxt) ->
|
||||||
Lwt.return (Gas.consume ctxt (Unparse_costs.prim_cost 2 annot)) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt (Unparse_costs.prim_cost 2 annot)) >>=? fun ctxt ->
|
||||||
return (Prim (loc, I_PUSH, [ ty ; data ], annot), ctxt)
|
return (Prim (loc, I_PUSH, [ ty ; data ], annot), ctxt)
|
||||||
| Seq (loc, items) ->
|
| Seq (loc, items) ->
|
||||||
fold_left_s
|
fold_left_s
|
||||||
(fun (l, ctxt) item ->
|
(fun (l, ctxt) item ->
|
||||||
unparse_code_generic ?mapper ctxt mode item >>=? fun (item, ctxt) ->
|
unparse_code_generic ctxt ?mapper mode item >>=? fun (item, ctxt) ->
|
||||||
return (item :: l, ctxt))
|
return (item :: l, ctxt))
|
||||||
([], ctxt) items >>=? fun (items, ctxt) ->
|
([], ctxt) items >>=? fun (items, ctxt) ->
|
||||||
Lwt.return (Gas.consume ctxt (Unparse_costs.seq_cost (List.length items))) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt (Unparse_costs.seq_cost (List.length items))) >>=? fun ctxt ->
|
||||||
@ -225,14 +265,13 @@ include struct
|
|||||||
| Prim (loc, prim, items, annot) ->
|
| Prim (loc, prim, items, annot) ->
|
||||||
fold_left_s
|
fold_left_s
|
||||||
(fun (l, ctxt) item ->
|
(fun (l, ctxt) item ->
|
||||||
unparse_code_generic ?mapper ctxt mode item >>=? fun (item, ctxt) ->
|
unparse_code_generic ctxt ?mapper mode item >>=? fun (item, ctxt) ->
|
||||||
return (item :: l, ctxt))
|
return (item :: l, ctxt))
|
||||||
([], ctxt) items >>=? fun (items, ctxt) ->
|
([], ctxt) items >>=? fun (items, ctxt) ->
|
||||||
Lwt.return (Gas.consume ctxt (Unparse_costs.prim_cost 3 annot)) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt (Unparse_costs.prim_cost 3 annot)) >>=? fun ctxt ->
|
||||||
return (Prim (loc, prim, List.rev items, annot), ctxt)
|
return (Prim (loc, prim, List.rev items, annot), ctxt)
|
||||||
| Int _ | String _ | Bytes _ as atom -> return (atom, ctxt)
|
| Int _ | String _ | Bytes _ as atom -> return (atom, ctxt)
|
||||||
|
|
||||||
|
|
||||||
end
|
end
|
||||||
|
|
||||||
let rec mapper (Ex_typed_value (ty, a)) =
|
let rec mapper (Ex_typed_value (ty, a)) =
|
||||||
|
2
vendors/ligo-utils/proto-alpha-utils/dune
vendored
2
vendors/ligo-utils/proto-alpha-utils/dune
vendored
@ -4,7 +4,7 @@
|
|||||||
(libraries
|
(libraries
|
||||||
tezos-error-monad
|
tezos-error-monad
|
||||||
tezos-stdlib-unix
|
tezos-stdlib-unix
|
||||||
tezos-protocol-alpha-parameters
|
tezos-protocol-005-PsBabyM1-parameters
|
||||||
tezos-memory-proto-alpha
|
tezos-memory-proto-alpha
|
||||||
simple-utils
|
simple-utils
|
||||||
tezos-utils
|
tezos-utils
|
||||||
|
@ -96,26 +96,6 @@ module Context_init = struct
|
|||||||
return context
|
return context
|
||||||
|
|
||||||
let genesis
|
let genesis
|
||||||
?(preserved_cycles = Constants_repr.default.preserved_cycles)
|
|
||||||
?(blocks_per_cycle = Constants_repr.default.blocks_per_cycle)
|
|
||||||
?(blocks_per_commitment = Constants_repr.default.blocks_per_commitment)
|
|
||||||
?(blocks_per_roll_snapshot = Constants_repr.default.blocks_per_roll_snapshot)
|
|
||||||
?(blocks_per_voting_period = Constants_repr.default.blocks_per_voting_period)
|
|
||||||
?(time_between_blocks = Constants_repr.default.time_between_blocks)
|
|
||||||
?(endorsers_per_block = Constants_repr.default.endorsers_per_block)
|
|
||||||
?(hard_gas_limit_per_operation = Constants_repr.default.hard_gas_limit_per_operation)
|
|
||||||
?(hard_gas_limit_per_block = Constants_repr.default.hard_gas_limit_per_block)
|
|
||||||
?(proof_of_work_threshold = Int64.(neg one))
|
|
||||||
?(tokens_per_roll = Constants_repr.default.tokens_per_roll)
|
|
||||||
?(michelson_maximum_type_size = Constants_repr.default.michelson_maximum_type_size)
|
|
||||||
?(seed_nonce_revelation_tip = Constants_repr.default.seed_nonce_revelation_tip)
|
|
||||||
?(origination_size = Constants_repr.default.origination_size)
|
|
||||||
?(block_security_deposit = Constants_repr.default.block_security_deposit)
|
|
||||||
?(endorsement_security_deposit = Constants_repr.default.endorsement_security_deposit)
|
|
||||||
?(block_reward = Constants_repr.default.block_reward)
|
|
||||||
?(endorsement_reward = Constants_repr.default.endorsement_reward)
|
|
||||||
?(cost_per_byte = Constants_repr.default.cost_per_byte)
|
|
||||||
?(hard_storage_limit_per_operation = Constants_repr.default.hard_storage_limit_per_operation)
|
|
||||||
?(commitments = [])
|
?(commitments = [])
|
||||||
?(security_deposit_ramp_up_cycles = None)
|
?(security_deposit_ramp_up_cycles = None)
|
||||||
?(no_reward_cycles = None)
|
?(no_reward_cycles = None)
|
||||||
@ -125,45 +105,7 @@ module Context_init = struct
|
|||||||
Pervasives.failwith "Must have one account with a roll to bake";
|
Pervasives.failwith "Must have one account with a roll to bake";
|
||||||
|
|
||||||
(* Check there is at least one roll *)
|
(* Check there is at least one roll *)
|
||||||
let open Tezos_base.TzPervasives.Error_monad in
|
let constants : Constants_repr.parametric = Tezos_protocol_005_PsBabyM1_parameters.Default_parameters.constants_test in
|
||||||
begin try
|
|
||||||
let (>>?=) x y = match x with
|
|
||||||
| Ok(a) -> y a
|
|
||||||
| Error(b) -> fail @@ List.hd b in
|
|
||||||
fold_left_s (fun acc (_, amount) ->
|
|
||||||
Alpha_environment.wrap_error @@
|
|
||||||
Tez_repr.(+?) acc amount >>?= fun acc ->
|
|
||||||
if acc >= tokens_per_roll then
|
|
||||||
raise Exit
|
|
||||||
else return acc
|
|
||||||
) Tez_repr.zero initial_accounts >>=? fun _ ->
|
|
||||||
failwith "Insufficient tokens in initial accounts to create one roll"
|
|
||||||
with Exit -> return ()
|
|
||||||
end >>=? fun () ->
|
|
||||||
|
|
||||||
let constants : Constants_repr.parametric = Tezos_protocol_alpha_parameters.Default_parameters.({
|
|
||||||
preserved_cycles ;
|
|
||||||
blocks_per_cycle ;
|
|
||||||
blocks_per_commitment ;
|
|
||||||
blocks_per_roll_snapshot ;
|
|
||||||
blocks_per_voting_period ;
|
|
||||||
time_between_blocks ;
|
|
||||||
endorsers_per_block ;
|
|
||||||
hard_gas_limit_per_operation ;
|
|
||||||
hard_gas_limit_per_block ;
|
|
||||||
proof_of_work_threshold ;
|
|
||||||
tokens_per_roll ;
|
|
||||||
michelson_maximum_type_size ;
|
|
||||||
seed_nonce_revelation_tip ;
|
|
||||||
origination_size ;
|
|
||||||
block_security_deposit ;
|
|
||||||
endorsement_security_deposit ;
|
|
||||||
block_reward ;
|
|
||||||
endorsement_reward ;
|
|
||||||
cost_per_byte ;
|
|
||||||
hard_storage_limit_per_operation ;
|
|
||||||
test_chain_duration = constants_mainnet.test_chain_duration ;
|
|
||||||
}) in
|
|
||||||
check_constants_consistency constants >>=? fun () ->
|
check_constants_consistency constants >>=? fun () ->
|
||||||
|
|
||||||
let hash =
|
let hash =
|
||||||
@ -187,8 +129,6 @@ module Context_init = struct
|
|||||||
|
|
||||||
let init
|
let init
|
||||||
?(slow=false)
|
?(slow=false)
|
||||||
?preserved_cycles
|
|
||||||
?endorsers_per_block
|
|
||||||
?commitments
|
?commitments
|
||||||
n =
|
n =
|
||||||
let open Error_monad in
|
let open Error_monad in
|
||||||
@ -198,18 +138,10 @@ module Context_init = struct
|
|||||||
begin
|
begin
|
||||||
if slow then
|
if slow then
|
||||||
genesis
|
genesis
|
||||||
?preserved_cycles
|
|
||||||
?endorsers_per_block
|
|
||||||
?commitments
|
?commitments
|
||||||
accounts
|
accounts
|
||||||
else
|
else
|
||||||
genesis
|
genesis
|
||||||
?preserved_cycles
|
|
||||||
~blocks_per_cycle:32l
|
|
||||||
~blocks_per_commitment:4l
|
|
||||||
~blocks_per_roll_snapshot:8l
|
|
||||||
~blocks_per_voting_period:(Int32.mul 32l 8l)
|
|
||||||
?endorsers_per_block
|
|
||||||
?commitments
|
?commitments
|
||||||
accounts
|
accounts
|
||||||
end >>=? fun ctxt ->
|
end >>=? fun ctxt ->
|
||||||
|
@ -42,7 +42,7 @@ depends: [
|
|||||||
"tezos-data-encoding"
|
"tezos-data-encoding"
|
||||||
"tezos-protocol-environment"
|
"tezos-protocol-environment"
|
||||||
"tezos-protocol-alpha"
|
"tezos-protocol-alpha"
|
||||||
"tezos-protocol-alpha-parameters"
|
"tezos-protocol-005-PsBabyM1-parameters"
|
||||||
"michelson-parser"
|
"michelson-parser"
|
||||||
"simple-utils"
|
"simple-utils"
|
||||||
"tezos-utils"
|
"tezos-utils"
|
||||||
|
File diff suppressed because it is too large
Load Diff
@ -25,86 +25,90 @@
|
|||||||
|
|
||||||
open Protocol
|
open Protocol
|
||||||
|
|
||||||
let constants_mainnet =
|
let constants_mainnet = Constants_repr.{
|
||||||
Constants_repr.
|
preserved_cycles = 5 ;
|
||||||
{
|
blocks_per_cycle = 4096l ;
|
||||||
preserved_cycles = 5;
|
blocks_per_commitment = 32l ;
|
||||||
blocks_per_cycle = 4096l;
|
blocks_per_roll_snapshot = 256l ;
|
||||||
blocks_per_commitment = 32l;
|
blocks_per_voting_period = 32768l ;
|
||||||
blocks_per_roll_snapshot = 256l;
|
time_between_blocks =
|
||||||
blocks_per_voting_period = 32768l;
|
List.map Period_repr.of_seconds_exn [ 60L ; 40L ] ;
|
||||||
time_between_blocks = List.map Period_repr.of_seconds_exn [60L; 75L];
|
endorsers_per_block = 32 ;
|
||||||
endorsers_per_block = 32;
|
hard_gas_limit_per_operation = Z.of_int 800_000 ;
|
||||||
hard_gas_limit_per_operation = Z.of_int 800_000;
|
hard_gas_limit_per_block = Z.of_int 8_000_000 ;
|
||||||
hard_gas_limit_per_block = Z.of_int 8_000_000;
|
proof_of_work_threshold =
|
||||||
proof_of_work_threshold = Int64.(sub (shift_left 1L 46) 1L);
|
Int64.(sub (shift_left 1L 46) 1L) ;
|
||||||
tokens_per_roll = Tez_repr.(mul_exn one 8_000);
|
tokens_per_roll = Tez_repr.(mul_exn one 8_000) ;
|
||||||
michelson_maximum_type_size = 1000;
|
michelson_maximum_type_size = 1000 ;
|
||||||
seed_nonce_revelation_tip =
|
seed_nonce_revelation_tip = begin
|
||||||
(match Tez_repr.(one /? 8L) with Ok c -> c | Error _ -> assert false);
|
match Tez_repr.(one /? 8L) with
|
||||||
origination_size = 257;
|
| Ok c -> c
|
||||||
block_security_deposit = Tez_repr.(mul_exn one 512);
|
| Error _ -> assert false
|
||||||
endorsement_security_deposit = Tez_repr.(mul_exn one 64);
|
end ;
|
||||||
block_reward = Tez_repr.(mul_exn one 16);
|
origination_size = 257 ;
|
||||||
endorsement_reward = Tez_repr.(mul_exn one 2);
|
block_security_deposit = Tez_repr.(mul_exn one 512) ;
|
||||||
hard_storage_limit_per_operation = Z.of_int 60_000;
|
endorsement_security_deposit = Tez_repr.(mul_exn one 64) ;
|
||||||
cost_per_byte = Tez_repr.of_mutez_exn 1_000L;
|
block_reward = Tez_repr.(mul_exn one 16) ;
|
||||||
test_chain_duration = Int64.mul 32768L 60L;
|
endorsement_reward = Tez_repr.(mul_exn one 2) ;
|
||||||
|
hard_storage_limit_per_operation = Z.of_int 60_000 ;
|
||||||
|
cost_per_byte = Tez_repr.of_mutez_exn 1_000L ;
|
||||||
|
test_chain_duration = Int64.mul 32768L 60L ;
|
||||||
|
quorum_min = 20_00l ; (* quorum is in centile of a percentage *)
|
||||||
|
quorum_max = 70_00l ;
|
||||||
|
min_proposal_quorum = 5_00l ;
|
||||||
|
initial_endorsers = 24 ;
|
||||||
|
delay_per_missing_endorsement = Period_repr.of_seconds_exn 8L ;
|
||||||
}
|
}
|
||||||
|
|
||||||
let constants_sandbox =
|
let constants_sandbox = Constants_repr.{
|
||||||
Constants_repr.
|
|
||||||
{
|
|
||||||
constants_mainnet with
|
constants_mainnet with
|
||||||
preserved_cycles = 2;
|
preserved_cycles = 2 ;
|
||||||
blocks_per_cycle = 8l;
|
blocks_per_cycle = 8l ;
|
||||||
blocks_per_commitment = 4l;
|
blocks_per_commitment = 4l ;
|
||||||
blocks_per_roll_snapshot = 4l;
|
blocks_per_roll_snapshot = 4l ;
|
||||||
blocks_per_voting_period = 64l;
|
blocks_per_voting_period = 64l ;
|
||||||
time_between_blocks = List.map Period_repr.of_seconds_exn [1L; 0L];
|
time_between_blocks =
|
||||||
proof_of_work_threshold = Int64.of_int (-1);
|
List.map Period_repr.of_seconds_exn [ 1L ; 0L ] ;
|
||||||
|
proof_of_work_threshold = Int64.of_int (-1) ;
|
||||||
|
initial_endorsers = 1 ;
|
||||||
|
delay_per_missing_endorsement = Period_repr.of_seconds_exn 1L ;
|
||||||
}
|
}
|
||||||
|
|
||||||
let constants_test =
|
let constants_test = Constants_repr.{
|
||||||
Constants_repr.
|
|
||||||
{
|
|
||||||
constants_mainnet with
|
constants_mainnet with
|
||||||
blocks_per_cycle = 128l;
|
blocks_per_cycle = 128l ;
|
||||||
blocks_per_commitment = 4l;
|
blocks_per_commitment = 4l ;
|
||||||
blocks_per_roll_snapshot = 32l;
|
blocks_per_roll_snapshot = 32l ;
|
||||||
blocks_per_voting_period = 256l;
|
blocks_per_voting_period = 256l ;
|
||||||
time_between_blocks = List.map Period_repr.of_seconds_exn [1L; 0L];
|
time_between_blocks =
|
||||||
proof_of_work_threshold = Int64.of_int (-1);
|
List.map Period_repr.of_seconds_exn [ 1L ; 0L ] ;
|
||||||
|
proof_of_work_threshold = Int64.of_int (-1) ;
|
||||||
|
initial_endorsers = 1 ;
|
||||||
|
delay_per_missing_endorsement = Period_repr.of_seconds_exn 1L ;
|
||||||
}
|
}
|
||||||
|
|
||||||
let bootstrap_accounts_strings =
|
let bootstrap_accounts_strings = [
|
||||||
[ "edpkuBknW28nW72KG6RoHtYW7p12T6GKc7nAbwYX5m8Wd9sDVC9yav";
|
"edpkuBknW28nW72KG6RoHtYW7p12T6GKc7nAbwYX5m8Wd9sDVC9yav" ;
|
||||||
"edpktzNbDAUjUk697W7gYg2CRuBQjyPxbEg8dLccYYwKSKvkPvjtV9";
|
"edpktzNbDAUjUk697W7gYg2CRuBQjyPxbEg8dLccYYwKSKvkPvjtV9" ;
|
||||||
"edpkuTXkJDGcFd5nh6VvMz8phXxU3Bi7h6hqgywNFi1vZTfQNnS1RV";
|
"edpkuTXkJDGcFd5nh6VvMz8phXxU3Bi7h6hqgywNFi1vZTfQNnS1RV" ;
|
||||||
"edpkuFrRoDSEbJYgxRtLx2ps82UdaYc1WwfS9sE11yhauZt5DgCHbU";
|
"edpkuFrRoDSEbJYgxRtLx2ps82UdaYc1WwfS9sE11yhauZt5DgCHbU" ;
|
||||||
"edpkv8EUUH68jmo3f7Um5PezmfGrRF24gnfLpH3sVNwJnV5bVCxL2n" ]
|
"edpkv8EUUH68jmo3f7Um5PezmfGrRF24gnfLpH3sVNwJnV5bVCxL2n" ;
|
||||||
|
]
|
||||||
let boostrap_balance = Tez_repr.of_mutez_exn 4_000_000_000_000L
|
let boostrap_balance = Tez_repr.of_mutez_exn 4_000_000_000_000L
|
||||||
|
let bootstrap_accounts = List.map (fun s ->
|
||||||
let bootstrap_accounts =
|
|
||||||
List.map
|
|
||||||
(fun s ->
|
|
||||||
let public_key = Signature.Public_key.of_b58check_exn s in
|
let public_key = Signature.Public_key.of_b58check_exn s in
|
||||||
let public_key_hash = Signature.Public_key.hash public_key in
|
let public_key_hash = Signature.Public_key.hash public_key in
|
||||||
Parameters_repr.
|
Parameters_repr.{
|
||||||
{
|
public_key_hash ;
|
||||||
public_key_hash;
|
public_key = Some public_key ;
|
||||||
public_key = Some public_key;
|
amount = boostrap_balance ;
|
||||||
amount = boostrap_balance;
|
|
||||||
})
|
})
|
||||||
bootstrap_accounts_strings
|
bootstrap_accounts_strings
|
||||||
|
|
||||||
(* TODO this could be generated from OCaml together with the faucet
|
(* TODO this could be generated from OCaml together with the faucet
|
||||||
for now these are harcoded values in the tests *)
|
for now these are harcoded values in the tests *)
|
||||||
let commitments =
|
let commitments =
|
||||||
let json_result =
|
let json_result = Data_encoding.Json.from_string {json|
|
||||||
Data_encoding.Json.from_string
|
|
||||||
{json|
|
|
||||||
[
|
[
|
||||||
[ "btz1bRL4X5BWo2Fj4EsBdUwexXqgTf75uf1qa", "23932454669343" ],
|
[ "btz1bRL4X5BWo2Fj4EsBdUwexXqgTf75uf1qa", "23932454669343" ],
|
||||||
[ "btz1SxjV1syBgftgKy721czKi3arVkVwYUFSv", "72954577464032" ],
|
[ "btz1SxjV1syBgftgKy721czKi3arVkVwYUFSv", "72954577464032" ],
|
||||||
@ -119,27 +123,26 @@ let commitments =
|
|||||||
]|json}
|
]|json}
|
||||||
in
|
in
|
||||||
match json_result with
|
match json_result with
|
||||||
| Error err ->
|
| Error err -> raise (Failure err)
|
||||||
raise (Failure err)
|
| Ok json -> Data_encoding.Json.destruct
|
||||||
| Ok json ->
|
(Data_encoding.list Commitment_repr.encoding) json
|
||||||
Data_encoding.Json.destruct
|
|
||||||
(Data_encoding.list Commitment_repr.encoding)
|
|
||||||
json
|
|
||||||
|
|
||||||
let make_bootstrap_account (pkh, pk, amount) =
|
let make_bootstrap_account (pkh, pk, amount) =
|
||||||
Parameters_repr.{public_key_hash = pkh; public_key = Some pk; amount}
|
Parameters_repr.{ public_key_hash = pkh ; public_key = Some pk ; amount }
|
||||||
|
|
||||||
let parameters_of_constants ?(bootstrap_accounts = bootstrap_accounts)
|
let parameters_of_constants
|
||||||
?(bootstrap_contracts = []) ?(with_commitments = false) constants =
|
?(bootstrap_accounts = bootstrap_accounts)
|
||||||
|
?(bootstrap_contracts = [])
|
||||||
|
?(with_commitments = false)
|
||||||
|
constants =
|
||||||
let commitments = if with_commitments then commitments else [] in
|
let commitments = if with_commitments then commitments else [] in
|
||||||
Parameters_repr.
|
Parameters_repr.{
|
||||||
{
|
bootstrap_accounts ;
|
||||||
bootstrap_accounts;
|
bootstrap_contracts ;
|
||||||
bootstrap_contracts;
|
commitments ;
|
||||||
commitments;
|
constants ;
|
||||||
constants;
|
security_deposit_ramp_up_cycles = None ;
|
||||||
security_deposit_ramp_up_cycles = None;
|
no_reward_cycles = None ;
|
||||||
no_reward_cycles = None;
|
|
||||||
}
|
}
|
||||||
|
|
||||||
let json_of_parameters parameters =
|
let json_of_parameters parameters =
|
||||||
|
@ -25,21 +25,18 @@
|
|||||||
|
|
||||||
open Protocol
|
open Protocol
|
||||||
|
|
||||||
val constants_mainnet : Constants_repr.parametric
|
val constants_mainnet: Constants_repr.parametric
|
||||||
|
val constants_sandbox: Constants_repr.parametric
|
||||||
|
val constants_test: Constants_repr.parametric
|
||||||
|
|
||||||
val constants_sandbox : Constants_repr.parametric
|
val make_bootstrap_account:
|
||||||
|
|
||||||
val constants_test : Constants_repr.parametric
|
|
||||||
|
|
||||||
val make_bootstrap_account :
|
|
||||||
Signature.public_key_hash * Signature.public_key * Tez_repr.t ->
|
Signature.public_key_hash * Signature.public_key * Tez_repr.t ->
|
||||||
Parameters_repr.bootstrap_account
|
Parameters_repr.bootstrap_account
|
||||||
|
|
||||||
val parameters_of_constants :
|
val parameters_of_constants:
|
||||||
?bootstrap_accounts:Parameters_repr.bootstrap_account list ->
|
?bootstrap_accounts:Parameters_repr.bootstrap_account list ->
|
||||||
?bootstrap_contracts:Parameters_repr.bootstrap_contract list ->
|
?bootstrap_contracts:Parameters_repr.bootstrap_contract list ->
|
||||||
?with_commitments:bool ->
|
?with_commitments:bool ->
|
||||||
Constants_repr.parametric ->
|
Constants_repr.parametric -> Parameters_repr.t
|
||||||
Parameters_repr.t
|
|
||||||
|
|
||||||
val json_of_parameters : Parameters_repr.t -> Data_encoding.json
|
val json_of_parameters: Parameters_repr.t -> Data_encoding.json
|
||||||
|
@ -1,22 +1,22 @@
|
|||||||
(library
|
(library
|
||||||
(name tezos_protocol_alpha_parameters)
|
(name tezos_protocol_005_PsBabyM1_parameters)
|
||||||
(public_name tezos-protocol-alpha-parameters)
|
(public_name tezos-protocol-005-PsBabyM1-parameters)
|
||||||
(modules :standard \ gen)
|
(modules :standard \ gen)
|
||||||
(libraries tezos-base
|
(libraries tezos-base
|
||||||
tezos-protocol-environment
|
tezos-protocol-environment
|
||||||
tezos-protocol-alpha)
|
tezos-protocol-005-PsBabyM1)
|
||||||
(flags (:standard -open Tezos_base__TzPervasives
|
(flags (:standard -open Tezos_base__TzPervasives
|
||||||
-open Tezos_protocol_alpha
|
-open Tezos_protocol_005_PsBabyM1
|
||||||
-linkall))
|
-linkall))
|
||||||
)
|
)
|
||||||
|
|
||||||
(executable
|
(executable
|
||||||
(name gen)
|
(name gen)
|
||||||
(libraries tezos-base
|
(libraries tezos-base
|
||||||
tezos-protocol-alpha-parameters)
|
tezos-protocol-005-PsBabyM1-parameters)
|
||||||
(modules gen)
|
(modules gen)
|
||||||
(flags (:standard -open Tezos_base__TzPervasives
|
(flags (:standard -open Tezos_base__TzPervasives
|
||||||
-open Tezos_protocol_alpha_parameters
|
-open Tezos_protocol_005_PsBabyM1_parameters
|
||||||
-linkall)))
|
-linkall)))
|
||||||
|
|
||||||
(rule
|
(rule
|
||||||
|
@ -29,19 +29,18 @@
|
|||||||
|
|
||||||
let () =
|
let () =
|
||||||
let print_usage_and_fail s =
|
let print_usage_and_fail s =
|
||||||
Printf.eprintf "Usage: %s [ --sandbox | --test | --mainnet ]" Sys.argv.(0) ;
|
Printf.eprintf "Usage: %s [ --sandbox | --test | --mainnet ]"
|
||||||
|
Sys.argv.(0) ;
|
||||||
raise (Invalid_argument s)
|
raise (Invalid_argument s)
|
||||||
in
|
in
|
||||||
let dump parameters file =
|
let dump parameters file =
|
||||||
let str =
|
let str = Data_encoding.Json.to_string
|
||||||
Data_encoding.Json.to_string
|
(Default_parameters.json_of_parameters parameters) in
|
||||||
(Default_parameters.json_of_parameters parameters)
|
|
||||||
in
|
|
||||||
let fd = open_out file in
|
let fd = open_out file in
|
||||||
output_string fd str ; close_out fd
|
output_string fd str ;
|
||||||
|
close_out fd
|
||||||
in
|
in
|
||||||
if Array.length Sys.argv < 2 then print_usage_and_fail ""
|
if Array.length Sys.argv < 2 then print_usage_and_fail "" else
|
||||||
else
|
|
||||||
match Sys.argv.(1) with
|
match Sys.argv.(1) with
|
||||||
| "--sandbox" ->
|
| "--sandbox" ->
|
||||||
dump
|
dump
|
||||||
@ -49,13 +48,10 @@ let () =
|
|||||||
"sandbox-parameters.json"
|
"sandbox-parameters.json"
|
||||||
| "--test" ->
|
| "--test" ->
|
||||||
dump
|
dump
|
||||||
Default_parameters.(
|
Default_parameters.(parameters_of_constants ~with_commitments:true constants_sandbox)
|
||||||
parameters_of_constants ~with_commitments:true constants_sandbox)
|
|
||||||
"test-parameters.json"
|
"test-parameters.json"
|
||||||
| "--mainnet" ->
|
| "--mainnet" ->
|
||||||
dump
|
dump
|
||||||
Default_parameters.(
|
Default_parameters.(parameters_of_constants ~with_commitments:true constants_mainnet)
|
||||||
parameters_of_constants ~with_commitments:true constants_mainnet)
|
|
||||||
"mainnet-parameters.json"
|
"mainnet-parameters.json"
|
||||||
| s ->
|
| s -> print_usage_and_fail s
|
||||||
print_usage_and_fail s
|
|
||||||
|
@ -1,5 +1,4 @@
|
|||||||
opam-version: "2.0"
|
opam-version: "2.0"
|
||||||
version: "dev"
|
|
||||||
maintainer: "contact@tezos.com"
|
maintainer: "contact@tezos.com"
|
||||||
authors: [ "Tezos devteam" ]
|
authors: [ "Tezos devteam" ]
|
||||||
homepage: "https://www.tezos.com/"
|
homepage: "https://www.tezos.com/"
|
||||||
@ -12,10 +11,9 @@ depends: [
|
|||||||
"dune" { build & >= "1.7" }
|
"dune" { build & >= "1.7" }
|
||||||
"tezos-base"
|
"tezos-base"
|
||||||
"tezos-protocol-environment"
|
"tezos-protocol-environment"
|
||||||
"tezos-protocol-alpha"
|
"tezos-protocol-005-PsBabyM1"
|
||||||
]
|
]
|
||||||
build: [
|
build: [
|
||||||
["dune" "build" "-p" name "-j" jobs]
|
[ "dune" "build" "-p" name "-j" jobs ]
|
||||||
["dune" "runtest" "-p" name "-j" jobs] {with-test}
|
|
||||||
]
|
]
|
||||||
synopsis: "Tezos/Protocol: parameters"
|
synopsis: "Tezos/Protocol: parameters"
|
@ -1,5 +1,5 @@
|
|||||||
{
|
{
|
||||||
"hash": "ProtoALphaALphaALphaALphaALphaALphaALphaALphaDdp3zK",
|
"hash": "PsBabyM1eUXZseaJdmXFApDSBqj8YBfwELoxZHHW77EMcAbbwAS",
|
||||||
"modules": [
|
"modules": [
|
||||||
"Misc",
|
"Misc",
|
||||||
"Storage_description",
|
"Storage_description",
|
||||||
@ -25,6 +25,7 @@
|
|||||||
"Script_timestamp_repr",
|
"Script_timestamp_repr",
|
||||||
"Michelson_v1_primitives",
|
"Michelson_v1_primitives",
|
||||||
"Script_repr",
|
"Script_repr",
|
||||||
|
"Legacy_script_support_repr",
|
||||||
"Contract_repr",
|
"Contract_repr",
|
||||||
"Roll_repr",
|
"Roll_repr",
|
||||||
"Vote_repr",
|
"Vote_repr",
|
||||||
|
@ -62,7 +62,14 @@ module Script_int = Script_int_repr
|
|||||||
module Script_timestamp = struct
|
module Script_timestamp = struct
|
||||||
include Script_timestamp_repr
|
include Script_timestamp_repr
|
||||||
let now ctxt =
|
let now ctxt =
|
||||||
Raw_context.current_timestamp ctxt
|
let { Constants_repr.time_between_blocks ; _ } =
|
||||||
|
Raw_context.constants ctxt in
|
||||||
|
match time_between_blocks with
|
||||||
|
| [] -> failwith "Internal error: 'time_between_block' constants \
|
||||||
|
is an empty list."
|
||||||
|
| first_delay :: _ ->
|
||||||
|
let current_timestamp = Raw_context.predecessor_timestamp ctxt in
|
||||||
|
Time.add current_timestamp (Period_repr.to_seconds first_delay)
|
||||||
|> Timestamp.to_seconds
|
|> Timestamp.to_seconds
|
||||||
|> of_int64
|
|> of_int64
|
||||||
end
|
end
|
||||||
@ -79,6 +86,7 @@ module Script = struct
|
|||||||
(Script_repr.force_bytes lexpr >>? fun (b, cost) ->
|
(Script_repr.force_bytes lexpr >>? fun (b, cost) ->
|
||||||
Raw_context.consume_gas ctxt cost >|? fun ctxt ->
|
Raw_context.consume_gas ctxt cost >|? fun ctxt ->
|
||||||
(b, ctxt))
|
(b, ctxt))
|
||||||
|
module Legacy_support = Legacy_script_support_repr
|
||||||
end
|
end
|
||||||
module Fees = Fees_storage
|
module Fees = Fees_storage
|
||||||
|
|
||||||
@ -113,13 +121,30 @@ module Contract = struct
|
|||||||
include Contract_repr
|
include Contract_repr
|
||||||
include Contract_storage
|
include Contract_storage
|
||||||
|
|
||||||
let originate c contract ~balance ~manager ?script ~delegate
|
let originate c contract ~balance ~script ~delegate =
|
||||||
~spendable ~delegatable =
|
originate c contract ~balance ~script ~delegate
|
||||||
originate c contract ~balance ~manager ?script ~delegate
|
|
||||||
~spendable ~delegatable
|
|
||||||
let init_origination_nonce = Raw_context.init_origination_nonce
|
let init_origination_nonce = Raw_context.init_origination_nonce
|
||||||
let unset_origination_nonce = Raw_context.unset_origination_nonce
|
let unset_origination_nonce = Raw_context.unset_origination_nonce
|
||||||
end
|
end
|
||||||
|
module Big_map = struct
|
||||||
|
type id = Z.t
|
||||||
|
let fresh = Storage.Big_map.Next.incr
|
||||||
|
let fresh_temporary = Raw_context.fresh_temporary_big_map
|
||||||
|
let mem c m k = Storage.Big_map.Contents.mem (c, m) k
|
||||||
|
let get_opt c m k = Storage.Big_map.Contents.get_option (c, m) k
|
||||||
|
let rpc_arg = Storage.Big_map.rpc_arg
|
||||||
|
let cleanup_temporary c =
|
||||||
|
Raw_context.temporary_big_maps c Storage.Big_map.remove_rec c >>= fun c ->
|
||||||
|
Lwt.return (Raw_context.reset_temporary_big_map c)
|
||||||
|
let exists c id =
|
||||||
|
Lwt.return (Raw_context.consume_gas c (Gas_limit_repr.read_bytes_cost Z.zero)) >>=? fun c ->
|
||||||
|
Storage.Big_map.Key_type.get_option c id >>=? fun kt ->
|
||||||
|
match kt with
|
||||||
|
| None -> return (c, None)
|
||||||
|
| Some kt ->
|
||||||
|
Storage.Big_map.Value_type.get c id >>=? fun kv ->
|
||||||
|
return (c, Some (kt, kv))
|
||||||
|
end
|
||||||
module Delegate = Delegate_storage
|
module Delegate = Delegate_storage
|
||||||
module Roll = struct
|
module Roll = struct
|
||||||
include Roll_repr
|
include Roll_repr
|
||||||
@ -148,8 +173,8 @@ module Commitment = struct
|
|||||||
end
|
end
|
||||||
|
|
||||||
module Global = struct
|
module Global = struct
|
||||||
let get_last_block_priority = Storage.Last_block_priority.get
|
let get_block_priority = Storage.Block_priority.get
|
||||||
let set_last_block_priority = Storage.Last_block_priority.set
|
let set_block_priority = Storage.Block_priority.set
|
||||||
end
|
end
|
||||||
|
|
||||||
let prepare_first_block = Init_storage.prepare_first_block
|
let prepare_first_block = Init_storage.prepare_first_block
|
||||||
@ -169,6 +194,7 @@ let fork_test_chain = Raw_context.fork_test_chain
|
|||||||
let record_endorsement = Raw_context.record_endorsement
|
let record_endorsement = Raw_context.record_endorsement
|
||||||
let allowed_endorsements = Raw_context.allowed_endorsements
|
let allowed_endorsements = Raw_context.allowed_endorsements
|
||||||
let init_endorsements = Raw_context.init_endorsements
|
let init_endorsements = Raw_context.init_endorsements
|
||||||
|
let included_endorsements = Raw_context.included_endorsements
|
||||||
|
|
||||||
let reset_internal_nonce = Raw_context.reset_internal_nonce
|
let reset_internal_nonce = Raw_context.reset_internal_nonce
|
||||||
let fresh_internal_nonce = Raw_context.fresh_internal_nonce
|
let fresh_internal_nonce = Raw_context.fresh_internal_nonce
|
||||||
|
@ -65,11 +65,13 @@ module Period : sig
|
|||||||
|
|
||||||
include BASIC_DATA
|
include BASIC_DATA
|
||||||
type period = t
|
type period = t
|
||||||
|
val rpc_arg: period RPC_arg.arg
|
||||||
|
|
||||||
val of_seconds: int64 -> period tzresult
|
val of_seconds: int64 -> period tzresult
|
||||||
val to_seconds: period -> int64
|
val to_seconds: period -> int64
|
||||||
val mult: int32 -> period -> period tzresult
|
val mult: int32 -> period -> period tzresult
|
||||||
|
|
||||||
|
val zero: period
|
||||||
val one_second: period
|
val one_second: period
|
||||||
val one_minute: period
|
val one_minute: period
|
||||||
val one_hour: period
|
val one_hour: period
|
||||||
@ -81,6 +83,7 @@ module Timestamp : sig
|
|||||||
include BASIC_DATA with type t = Time.t
|
include BASIC_DATA with type t = Time.t
|
||||||
type time = t
|
type time = t
|
||||||
val (+?) : time -> Period.t -> time tzresult
|
val (+?) : time -> Period.t -> time tzresult
|
||||||
|
val (-?) : time -> time -> Period.t tzresult
|
||||||
|
|
||||||
val of_notation: string -> time option
|
val of_notation: string -> time option
|
||||||
val to_notation: time -> string
|
val to_notation: time -> string
|
||||||
@ -143,6 +146,7 @@ module Gas : sig
|
|||||||
type error += Gas_limit_too_high (* `Permanent *)
|
type error += Gas_limit_too_high (* `Permanent *)
|
||||||
|
|
||||||
val free : cost
|
val free : cost
|
||||||
|
val atomic_step_cost : int -> cost
|
||||||
val step_cost : int -> cost
|
val step_cost : int -> cost
|
||||||
val alloc_cost : int -> cost
|
val alloc_cost : int -> cost
|
||||||
val alloc_bytes_cost : int -> cost
|
val alloc_bytes_cost : int -> cost
|
||||||
@ -209,6 +213,7 @@ module Script : sig
|
|||||||
| I_BALANCE
|
| I_BALANCE
|
||||||
| I_CAR
|
| I_CAR
|
||||||
| I_CDR
|
| I_CDR
|
||||||
|
| I_CHAIN_ID
|
||||||
| I_CHECK_SIGNATURE
|
| I_CHECK_SIGNATURE
|
||||||
| I_COMPARE
|
| I_COMPARE
|
||||||
| I_CONCAT
|
| I_CONCAT
|
||||||
@ -220,10 +225,12 @@ module Script : sig
|
|||||||
| I_DROP
|
| I_DROP
|
||||||
| I_DUP
|
| I_DUP
|
||||||
| I_EDIV
|
| I_EDIV
|
||||||
|
| I_EMPTY_BIG_MAP
|
||||||
| I_EMPTY_MAP
|
| I_EMPTY_MAP
|
||||||
| I_EMPTY_SET
|
| I_EMPTY_SET
|
||||||
| I_EQ
|
| I_EQ
|
||||||
| I_EXEC
|
| I_EXEC
|
||||||
|
| I_APPLY
|
||||||
| I_FAILWITH
|
| I_FAILWITH
|
||||||
| I_GE
|
| I_GE
|
||||||
| I_GET
|
| I_GET
|
||||||
@ -275,6 +282,8 @@ module Script : sig
|
|||||||
| I_ISNAT
|
| I_ISNAT
|
||||||
| I_CAST
|
| I_CAST
|
||||||
| I_RENAME
|
| I_RENAME
|
||||||
|
| I_DIG
|
||||||
|
| I_DUG
|
||||||
| T_bool
|
| T_bool
|
||||||
| T_contract
|
| T_contract
|
||||||
| T_int
|
| T_int
|
||||||
@ -297,6 +306,8 @@ module Script : sig
|
|||||||
| T_unit
|
| T_unit
|
||||||
| T_operation
|
| T_operation
|
||||||
| T_address
|
| T_address
|
||||||
|
| T_chain_id
|
||||||
|
|
||||||
|
|
||||||
type location = Micheline.canonical_location
|
type location = Micheline.canonical_location
|
||||||
|
|
||||||
@ -336,6 +347,27 @@ module Script : sig
|
|||||||
val minimal_deserialize_cost : lazy_expr -> Gas.cost
|
val minimal_deserialize_cost : lazy_expr -> Gas.cost
|
||||||
val force_decode : context -> lazy_expr -> (expr * context) tzresult Lwt.t
|
val force_decode : context -> lazy_expr -> (expr * context) tzresult Lwt.t
|
||||||
val force_bytes : context -> lazy_expr -> (MBytes.t * context) tzresult Lwt.t
|
val force_bytes : context -> lazy_expr -> (MBytes.t * context) tzresult Lwt.t
|
||||||
|
|
||||||
|
val unit_parameter : lazy_expr
|
||||||
|
|
||||||
|
module Legacy_support : sig
|
||||||
|
val manager_script_code: lazy_expr
|
||||||
|
val add_do:
|
||||||
|
manager_pkh: Signature.Public_key_hash.t ->
|
||||||
|
script_code: lazy_expr ->
|
||||||
|
script_storage: lazy_expr ->
|
||||||
|
(lazy_expr * lazy_expr) tzresult Lwt.t
|
||||||
|
val add_set_delegate:
|
||||||
|
manager_pkh: Signature.Public_key_hash.t ->
|
||||||
|
script_code: lazy_expr ->
|
||||||
|
script_storage: lazy_expr ->
|
||||||
|
(lazy_expr * lazy_expr) tzresult Lwt.t
|
||||||
|
val has_default_entrypoint: lazy_expr -> bool
|
||||||
|
val add_root_entrypoint:
|
||||||
|
script_code: lazy_expr ->
|
||||||
|
lazy_expr tzresult Lwt.t
|
||||||
|
end
|
||||||
|
|
||||||
end
|
end
|
||||||
|
|
||||||
module Constants : sig
|
module Constants : sig
|
||||||
@ -380,6 +412,11 @@ module Constants : sig
|
|||||||
cost_per_byte: Tez.t ;
|
cost_per_byte: Tez.t ;
|
||||||
hard_storage_limit_per_operation: Z.t ;
|
hard_storage_limit_per_operation: Z.t ;
|
||||||
test_chain_duration: int64;
|
test_chain_duration: int64;
|
||||||
|
quorum_min: int32 ;
|
||||||
|
quorum_max: int32 ;
|
||||||
|
min_proposal_quorum : int32 ;
|
||||||
|
initial_endorsers: int ;
|
||||||
|
delay_per_missing_endorsement : Period.t ;
|
||||||
}
|
}
|
||||||
val parametric_encoding: parametric Data_encoding.t
|
val parametric_encoding: parametric Data_encoding.t
|
||||||
val parametric: context -> parametric
|
val parametric: context -> parametric
|
||||||
@ -390,6 +427,8 @@ module Constants : sig
|
|||||||
val blocks_per_voting_period: context -> int32
|
val blocks_per_voting_period: context -> int32
|
||||||
val time_between_blocks: context -> Period.t list
|
val time_between_blocks: context -> Period.t list
|
||||||
val endorsers_per_block: context -> int
|
val endorsers_per_block: context -> int
|
||||||
|
val initial_endorsers: context -> int
|
||||||
|
val delay_per_missing_endorsement: context -> Period.t
|
||||||
val hard_gas_limit_per_operation: context -> Z.t
|
val hard_gas_limit_per_operation: context -> Z.t
|
||||||
val hard_gas_limit_per_block: context -> Z.t
|
val hard_gas_limit_per_block: context -> Z.t
|
||||||
val cost_per_byte: context -> Tez.t
|
val cost_per_byte: context -> Tez.t
|
||||||
@ -404,6 +443,9 @@ module Constants : sig
|
|||||||
val block_security_deposit: context -> Tez.t
|
val block_security_deposit: context -> Tez.t
|
||||||
val endorsement_security_deposit: context -> Tez.t
|
val endorsement_security_deposit: context -> Tez.t
|
||||||
val test_chain_duration: context -> int64
|
val test_chain_duration: context -> int64
|
||||||
|
val quorum_min: context -> int32
|
||||||
|
val quorum_max: context -> int32
|
||||||
|
val min_proposal_quorum: context -> int32
|
||||||
|
|
||||||
(** All constants: fixed and parametric *)
|
(** All constants: fixed and parametric *)
|
||||||
type t = {
|
type t = {
|
||||||
@ -531,6 +573,17 @@ module Seed : sig
|
|||||||
|
|
||||||
end
|
end
|
||||||
|
|
||||||
|
module Big_map: sig
|
||||||
|
type id = Z.t
|
||||||
|
val fresh : context -> (context * id) tzresult Lwt.t
|
||||||
|
val fresh_temporary : context -> context * id
|
||||||
|
val mem : context -> id -> Script_expr_hash.t -> (context * bool) tzresult Lwt.t
|
||||||
|
val get_opt : context -> id -> Script_expr_hash.t -> (context * Script.expr option) tzresult Lwt.t
|
||||||
|
val rpc_arg : id RPC_arg.t
|
||||||
|
val cleanup_temporary : context -> context Lwt.t
|
||||||
|
val exists : context -> id -> (context * (Script.expr * Script.expr) option) tzresult Lwt.t
|
||||||
|
end
|
||||||
|
|
||||||
module Contract : sig
|
module Contract : sig
|
||||||
|
|
||||||
include BASIC_DATA
|
include BASIC_DATA
|
||||||
@ -551,27 +604,22 @@ module Contract : sig
|
|||||||
|
|
||||||
val list: context -> contract list Lwt.t
|
val list: context -> contract list Lwt.t
|
||||||
|
|
||||||
val get_manager:
|
|
||||||
context -> contract -> public_key_hash tzresult Lwt.t
|
|
||||||
|
|
||||||
val get_manager_key:
|
val get_manager_key:
|
||||||
context -> contract -> public_key tzresult Lwt.t
|
context -> public_key_hash -> public_key tzresult Lwt.t
|
||||||
val is_manager_key_revealed:
|
val is_manager_key_revealed:
|
||||||
context -> contract -> bool tzresult Lwt.t
|
context -> public_key_hash -> bool tzresult Lwt.t
|
||||||
|
|
||||||
val reveal_manager_key:
|
val reveal_manager_key:
|
||||||
context -> contract -> public_key -> context tzresult Lwt.t
|
context -> public_key_hash -> public_key -> context tzresult Lwt.t
|
||||||
|
|
||||||
val is_delegatable:
|
val get_script_code:
|
||||||
context -> contract -> bool tzresult Lwt.t
|
context -> contract -> (context * Script.lazy_expr option) tzresult Lwt.t
|
||||||
val is_spendable:
|
|
||||||
context -> contract -> bool tzresult Lwt.t
|
|
||||||
val get_script:
|
val get_script:
|
||||||
context -> contract -> (context * Script.t option) tzresult Lwt.t
|
context -> contract -> (context * Script.t option) tzresult Lwt.t
|
||||||
val get_storage:
|
val get_storage:
|
||||||
context -> contract -> (context * Script.expr option) tzresult Lwt.t
|
context -> contract -> (context * Script.expr option) tzresult Lwt.t
|
||||||
|
|
||||||
val get_counter: context -> contract -> Z.t tzresult Lwt.t
|
val get_counter: context -> public_key_hash -> Z.t tzresult Lwt.t
|
||||||
val get_balance:
|
val get_balance:
|
||||||
context -> contract -> Tez.t tzresult Lwt.t
|
context -> contract -> Tez.t tzresult Lwt.t
|
||||||
|
|
||||||
@ -580,10 +628,19 @@ module Contract : sig
|
|||||||
val fresh_contract_from_current_nonce : context -> (context * t) tzresult Lwt.t
|
val fresh_contract_from_current_nonce : context -> (context * t) tzresult Lwt.t
|
||||||
val originated_from_current_nonce: since: context -> until:context -> contract list tzresult Lwt.t
|
val originated_from_current_nonce: since: context -> until:context -> contract list tzresult Lwt.t
|
||||||
|
|
||||||
type big_map_diff_item = {
|
type big_map_diff_item =
|
||||||
diff_key : Script_repr.expr;
|
| Update of {
|
||||||
|
big_map : Big_map.id ;
|
||||||
|
diff_key : Script.expr;
|
||||||
diff_key_hash : Script_expr_hash.t;
|
diff_key_hash : Script_expr_hash.t;
|
||||||
diff_value : Script_repr.expr option;
|
diff_value : Script.expr option;
|
||||||
|
}
|
||||||
|
| Clear of Big_map.id
|
||||||
|
| Copy of Big_map.id * Big_map.id
|
||||||
|
| Alloc of {
|
||||||
|
big_map : Big_map.id;
|
||||||
|
key_type : Script.expr;
|
||||||
|
value_type : Script.expr;
|
||||||
}
|
}
|
||||||
type big_map_diff = big_map_diff_item list
|
type big_map_diff = big_map_diff_item list
|
||||||
val big_map_diff_encoding : big_map_diff Data_encoding.t
|
val big_map_diff_encoding : big_map_diff Data_encoding.t
|
||||||
@ -591,18 +648,14 @@ module Contract : sig
|
|||||||
val originate:
|
val originate:
|
||||||
context -> contract ->
|
context -> contract ->
|
||||||
balance: Tez.t ->
|
balance: Tez.t ->
|
||||||
manager: public_key_hash ->
|
script: (Script.t * big_map_diff option) ->
|
||||||
?script: (Script.t * big_map_diff option) ->
|
|
||||||
delegate: public_key_hash option ->
|
delegate: public_key_hash option ->
|
||||||
spendable: bool ->
|
context tzresult Lwt.t
|
||||||
delegatable: bool -> context tzresult Lwt.t
|
|
||||||
|
|
||||||
type error += Balance_too_low of contract * Tez.t * Tez.t
|
type error += Balance_too_low of contract * Tez.t * Tez.t
|
||||||
|
|
||||||
val spend:
|
val spend:
|
||||||
context -> contract -> Tez.t -> context tzresult Lwt.t
|
context -> contract -> Tez.t -> context tzresult Lwt.t
|
||||||
val spend_from_script:
|
|
||||||
context -> contract -> Tez.t -> context tzresult Lwt.t
|
|
||||||
|
|
||||||
val credit:
|
val credit:
|
||||||
context -> contract -> Tez.t -> context tzresult Lwt.t
|
context -> contract -> Tez.t -> context tzresult Lwt.t
|
||||||
@ -615,17 +668,10 @@ module Contract : sig
|
|||||||
val used_storage_space: context -> t -> Z.t tzresult Lwt.t
|
val used_storage_space: context -> t -> Z.t tzresult Lwt.t
|
||||||
|
|
||||||
val increment_counter:
|
val increment_counter:
|
||||||
context -> contract -> context tzresult Lwt.t
|
context -> public_key_hash -> context tzresult Lwt.t
|
||||||
|
|
||||||
val check_counter_increment:
|
val check_counter_increment:
|
||||||
context -> contract -> Z.t -> unit tzresult Lwt.t
|
context -> public_key_hash -> Z.t -> unit tzresult Lwt.t
|
||||||
|
|
||||||
module Big_map : sig
|
|
||||||
val mem:
|
|
||||||
context -> contract -> Script_expr_hash.t -> (context * bool) tzresult Lwt.t
|
|
||||||
val get_opt:
|
|
||||||
context -> contract -> Script_expr_hash.t -> (context * Script_repr.expr option) tzresult Lwt.t
|
|
||||||
end
|
|
||||||
|
|
||||||
(**/**)
|
(**/**)
|
||||||
(* Only for testing *)
|
(* Only for testing *)
|
||||||
@ -658,9 +704,6 @@ module Delegate : sig
|
|||||||
val set:
|
val set:
|
||||||
context -> Contract.t -> public_key_hash option -> context tzresult Lwt.t
|
context -> Contract.t -> public_key_hash option -> context tzresult Lwt.t
|
||||||
|
|
||||||
val set_from_script:
|
|
||||||
context -> Contract.t -> public_key_hash option -> context tzresult Lwt.t
|
|
||||||
|
|
||||||
val fold:
|
val fold:
|
||||||
context ->
|
context ->
|
||||||
init:'a -> f:(public_key_hash -> 'a -> 'a Lwt.t) -> 'a Lwt.t
|
init:'a -> f:(public_key_hash -> 'a -> 'a Lwt.t) -> 'a Lwt.t
|
||||||
@ -713,7 +756,7 @@ module Delegate : sig
|
|||||||
|
|
||||||
val delegated_contracts:
|
val delegated_contracts:
|
||||||
context -> Signature.Public_key_hash.t ->
|
context -> Signature.Public_key_hash.t ->
|
||||||
Contract_hash.t list Lwt.t
|
Contract_repr.t list Lwt.t
|
||||||
|
|
||||||
val delegated_balance:
|
val delegated_balance:
|
||||||
context -> Signature.Public_key_hash.t ->
|
context -> Signature.Public_key_hash.t ->
|
||||||
@ -775,7 +818,9 @@ module Vote : sig
|
|||||||
context -> Voting_period.kind -> context tzresult Lwt.t
|
context -> Voting_period.kind -> context tzresult Lwt.t
|
||||||
|
|
||||||
val get_current_quorum: context -> int32 tzresult Lwt.t
|
val get_current_quorum: context -> int32 tzresult Lwt.t
|
||||||
val set_current_quorum: context -> int32 -> context tzresult Lwt.t
|
|
||||||
|
val get_participation_ema: context -> int32 tzresult Lwt.t
|
||||||
|
val set_participation_ema: context -> int32 -> context tzresult Lwt.t
|
||||||
|
|
||||||
val get_current_proposal:
|
val get_current_proposal:
|
||||||
context -> proposal tzresult Lwt.t
|
context -> proposal tzresult Lwt.t
|
||||||
@ -892,7 +937,7 @@ and _ contents =
|
|||||||
ballot: Vote.ballot ;
|
ballot: Vote.ballot ;
|
||||||
} -> Kind.ballot contents
|
} -> Kind.ballot contents
|
||||||
| Manager_operation : {
|
| Manager_operation : {
|
||||||
source: Contract.contract ;
|
source: Signature.Public_key_hash.t ;
|
||||||
fee: Tez.tez ;
|
fee: Tez.tez ;
|
||||||
counter: counter ;
|
counter: counter ;
|
||||||
operation: 'kind manager_operation ;
|
operation: 'kind manager_operation ;
|
||||||
@ -904,15 +949,13 @@ and _ manager_operation =
|
|||||||
| Reveal : Signature.Public_key.t -> Kind.reveal manager_operation
|
| Reveal : Signature.Public_key.t -> Kind.reveal manager_operation
|
||||||
| Transaction : {
|
| Transaction : {
|
||||||
amount: Tez.tez ;
|
amount: Tez.tez ;
|
||||||
parameters: Script.lazy_expr option ;
|
parameters: Script.lazy_expr ;
|
||||||
|
entrypoint: string ;
|
||||||
destination: Contract.contract ;
|
destination: Contract.contract ;
|
||||||
} -> Kind.transaction manager_operation
|
} -> Kind.transaction manager_operation
|
||||||
| Origination : {
|
| Origination : {
|
||||||
manager: Signature.Public_key_hash.t ;
|
|
||||||
delegate: Signature.Public_key_hash.t option ;
|
delegate: Signature.Public_key_hash.t option ;
|
||||||
script: Script.t option ;
|
script: Script.t ;
|
||||||
spendable: bool ;
|
|
||||||
delegatable: bool ;
|
|
||||||
credit: Tez.tez ;
|
credit: Tez.tez ;
|
||||||
preorigination: Contract.t option ;
|
preorigination: Contract.t option ;
|
||||||
} -> Kind.origination manager_operation
|
} -> Kind.origination manager_operation
|
||||||
@ -1111,8 +1154,8 @@ end
|
|||||||
|
|
||||||
module Global : sig
|
module Global : sig
|
||||||
|
|
||||||
val get_last_block_priority: context -> int tzresult Lwt.t
|
val get_block_priority: context -> int tzresult Lwt.t
|
||||||
val set_last_block_priority: context -> int -> context tzresult Lwt.t
|
val set_block_priority: context -> int -> context tzresult Lwt.t
|
||||||
|
|
||||||
end
|
end
|
||||||
|
|
||||||
@ -1128,6 +1171,7 @@ val prepare_first_block:
|
|||||||
val prepare:
|
val prepare:
|
||||||
Context.t ->
|
Context.t ->
|
||||||
level:Int32.t ->
|
level:Int32.t ->
|
||||||
|
predecessor_timestamp:Time.t ->
|
||||||
timestamp:Time.t ->
|
timestamp:Time.t ->
|
||||||
fitness:Fitness.t ->
|
fitness:Fitness.t ->
|
||||||
context tzresult Lwt.t
|
context tzresult Lwt.t
|
||||||
@ -1146,6 +1190,8 @@ val init_endorsements:
|
|||||||
context ->
|
context ->
|
||||||
(Signature.Public_key.t * int list * bool) Signature.Public_key_hash.Map.t ->
|
(Signature.Public_key.t * int list * bool) Signature.Public_key_hash.Map.t ->
|
||||||
context
|
context
|
||||||
|
val included_endorsements:
|
||||||
|
context -> int
|
||||||
|
|
||||||
val reset_internal_nonce: context -> context
|
val reset_internal_nonce: context -> context
|
||||||
val fresh_internal_nonce: context -> (context * int) tzresult
|
val fresh_internal_nonce: context -> (context * int) tzresult
|
||||||
|
@ -26,34 +26,46 @@
|
|||||||
open Alpha_context
|
open Alpha_context
|
||||||
|
|
||||||
(** Returns the proposal submitted by the most delegates.
|
(** Returns the proposal submitted by the most delegates.
|
||||||
Returns None in case of a tie or if there are no proposals. *)
|
Returns None in case of a tie, if proposal quorum is below required
|
||||||
let select_winning_proposal proposals =
|
minimum or if there are no proposals. *)
|
||||||
|
let select_winning_proposal ctxt =
|
||||||
|
Vote.get_proposals ctxt >>=? fun proposals ->
|
||||||
let merge proposal vote winners =
|
let merge proposal vote winners =
|
||||||
match winners with
|
match winners with
|
||||||
| None -> Some ([proposal], vote)
|
| None -> Some ([proposal], vote)
|
||||||
| Some (winners, winners_vote) as previous ->
|
| Some (winners, winners_vote) as previous ->
|
||||||
if Compare.Int32.(vote = winners_vote) then
|
if Compare.Int32.(vote = winners_vote) then
|
||||||
Some (proposal :: winners, winners_vote)
|
Some (proposal :: winners, winners_vote)
|
||||||
else if Compare.Int32.(vote >= winners_vote) then
|
else if Compare.Int32.(vote > winners_vote) then
|
||||||
Some ([proposal], vote)
|
Some ([proposal], vote)
|
||||||
else
|
else
|
||||||
previous in
|
previous in
|
||||||
match Protocol_hash.Map.fold merge proposals None with
|
match Protocol_hash.Map.fold merge proposals None with
|
||||||
| None -> None
|
| Some ([proposal], vote) ->
|
||||||
| Some ([proposal], _) -> Some proposal
|
Vote.listing_size ctxt >>=? fun max_vote ->
|
||||||
| Some _ -> None (* in case of a tie, lets do nothing. *)
|
let min_proposal_quorum = Constants.min_proposal_quorum ctxt in
|
||||||
|
let min_vote_to_pass =
|
||||||
|
Int32.div (Int32.mul min_proposal_quorum max_vote) 100_00l in
|
||||||
|
if Compare.Int32.(vote >= min_vote_to_pass) then
|
||||||
|
return_some proposal
|
||||||
|
else
|
||||||
|
return_none
|
||||||
|
| _ ->
|
||||||
|
return_none (* in case of a tie, let's do nothing. *)
|
||||||
|
|
||||||
(** A proposal is approved if it has supermajority and the participation reaches
|
(** A proposal is approved if it has supermajority and the participation reaches
|
||||||
the current quorum.
|
the current quorum.
|
||||||
Supermajority means the yays are more 8/10 of casted votes.
|
Supermajority means the yays are more 8/10 of casted votes.
|
||||||
The participation is the ratio of all received votes, including passes, with
|
The participation is the ratio of all received votes, including passes, with
|
||||||
respect to the number of possible votes. The quorum starts at 80% and at
|
respect to the number of possible votes.
|
||||||
each vote is updated using the last expected quorum and the current
|
The participation EMA (exponential moving average) uses the last
|
||||||
participation with the following weights:
|
participation EMA and the current participation./
|
||||||
newQ = oldQ * 8/10 + participation * 2/10 *)
|
The expected quorum is calculated using the last participation EMA, capped
|
||||||
let check_approval_and_update_quorum ctxt =
|
by the min/max quorum protocol constants. *)
|
||||||
|
let check_approval_and_update_participation_ema ctxt =
|
||||||
Vote.get_ballots ctxt >>=? fun ballots ->
|
Vote.get_ballots ctxt >>=? fun ballots ->
|
||||||
Vote.listing_size ctxt >>=? fun maximum_vote ->
|
Vote.listing_size ctxt >>=? fun maximum_vote ->
|
||||||
|
Vote.get_participation_ema ctxt >>=? fun participation_ema ->
|
||||||
Vote.get_current_quorum ctxt >>=? fun expected_quorum ->
|
Vote.get_current_quorum ctxt >>=? fun expected_quorum ->
|
||||||
(* Note overflows: considering a maximum of 8e8 tokens, with roll size as
|
(* Note overflows: considering a maximum of 8e8 tokens, with roll size as
|
||||||
small as 1e3, there is a maximum of 8e5 rolls and thus votes.
|
small as 1e3, there is a maximum of 8e5 rolls and thus votes.
|
||||||
@ -64,15 +76,18 @@ let check_approval_and_update_quorum ctxt =
|
|||||||
let all_votes = Int32.add casted_votes ballots.pass in
|
let all_votes = Int32.add casted_votes ballots.pass in
|
||||||
let supermajority = Int32.div (Int32.mul 8l casted_votes) 10l in
|
let supermajority = Int32.div (Int32.mul 8l casted_votes) 10l in
|
||||||
let participation = (* in centile of percentage *)
|
let participation = (* in centile of percentage *)
|
||||||
Int64.to_int32
|
Int64.(to_int32
|
||||||
(Int64.div
|
(div
|
||||||
(Int64.mul (Int64.of_int32 all_votes) 100_00L)
|
(mul (of_int32 all_votes) 100_00L)
|
||||||
(Int64.of_int32 maximum_vote)) in
|
(of_int32 maximum_vote))) in
|
||||||
let outcome = Compare.Int32.(participation >= expected_quorum &&
|
let outcome = Compare.Int32.(participation >= expected_quorum &&
|
||||||
ballots.yay >= supermajority) in
|
ballots.yay >= supermajority) in
|
||||||
let updated_quorum =
|
let new_participation_ema =
|
||||||
Int32.div (Int32.add (Int32.mul 8l expected_quorum) (Int32.mul 2l participation)) 10l in
|
Int32.(div (add
|
||||||
Vote.set_current_quorum ctxt updated_quorum >>=? fun ctxt ->
|
(mul 8l participation_ema)
|
||||||
|
(mul 2l participation))
|
||||||
|
10l) in
|
||||||
|
Vote.set_participation_ema ctxt new_participation_ema >>=? fun ctxt ->
|
||||||
return (ctxt, outcome)
|
return (ctxt, outcome)
|
||||||
|
|
||||||
(** Implements the state machine of the amendment procedure.
|
(** Implements the state machine of the amendment procedure.
|
||||||
@ -82,10 +97,10 @@ let check_approval_and_update_quorum ctxt =
|
|||||||
let start_new_voting_period ctxt =
|
let start_new_voting_period ctxt =
|
||||||
Vote.get_current_period_kind ctxt >>=? function
|
Vote.get_current_period_kind ctxt >>=? function
|
||||||
| Proposal -> begin
|
| Proposal -> begin
|
||||||
Vote.get_proposals ctxt >>=? fun proposals ->
|
select_winning_proposal ctxt >>=? fun proposal ->
|
||||||
Vote.clear_proposals ctxt >>= fun ctxt ->
|
Vote.clear_proposals ctxt >>= fun ctxt ->
|
||||||
Vote.clear_listings ctxt >>=? fun ctxt ->
|
Vote.clear_listings ctxt >>=? fun ctxt ->
|
||||||
match select_winning_proposal proposals with
|
match proposal with
|
||||||
| None ->
|
| None ->
|
||||||
Vote.freeze_listings ctxt >>=? fun ctxt ->
|
Vote.freeze_listings ctxt >>=? fun ctxt ->
|
||||||
return ctxt
|
return ctxt
|
||||||
@ -96,7 +111,7 @@ let start_new_voting_period ctxt =
|
|||||||
return ctxt
|
return ctxt
|
||||||
end
|
end
|
||||||
| Testing_vote ->
|
| Testing_vote ->
|
||||||
check_approval_and_update_quorum ctxt >>=? fun (ctxt, approved) ->
|
check_approval_and_update_participation_ema ctxt >>=? fun (ctxt, approved) ->
|
||||||
Vote.clear_ballots ctxt >>= fun ctxt ->
|
Vote.clear_ballots ctxt >>= fun ctxt ->
|
||||||
Vote.clear_listings ctxt >>=? fun ctxt ->
|
Vote.clear_listings ctxt >>=? fun ctxt ->
|
||||||
if approved then
|
if approved then
|
||||||
@ -116,7 +131,7 @@ let start_new_voting_period ctxt =
|
|||||||
Vote.set_current_period_kind ctxt Promotion_vote >>=? fun ctxt ->
|
Vote.set_current_period_kind ctxt Promotion_vote >>=? fun ctxt ->
|
||||||
return ctxt
|
return ctxt
|
||||||
| Promotion_vote ->
|
| Promotion_vote ->
|
||||||
check_approval_and_update_quorum ctxt >>=? fun (ctxt, approved) ->
|
check_approval_and_update_participation_ema ctxt >>=? fun (ctxt, approved) ->
|
||||||
begin
|
begin
|
||||||
if approved then
|
if approved then
|
||||||
Vote.get_current_proposal ctxt >>=? fun proposal ->
|
Vote.get_current_proposal ctxt >>=? fun proposal ->
|
||||||
|
240
vendors/ligo-utils/tezos-protocol-alpha/apply.ml
vendored
240
vendors/ligo-utils/tezos-protocol-alpha/apply.ml
vendored
@ -33,8 +33,6 @@ type error += Duplicate_endorsement of Signature.Public_key_hash.t (* `Branch *)
|
|||||||
type error += Invalid_endorsement_level
|
type error += Invalid_endorsement_level
|
||||||
type error += Invalid_commitment of { expected: bool }
|
type error += Invalid_commitment of { expected: bool }
|
||||||
type error += Internal_operation_replay of packed_internal_operation
|
type error += Internal_operation_replay of packed_internal_operation
|
||||||
type error += Cannot_originate_spendable_smart_contract (* `Permanent *)
|
|
||||||
type error += Cannot_originate_non_spendable_account (* `Permanent *)
|
|
||||||
|
|
||||||
type error += Invalid_double_endorsement_evidence (* `Permanent *)
|
type error += Invalid_double_endorsement_evidence (* `Permanent *)
|
||||||
type error += Inconsistent_double_endorsement_evidence
|
type error += Inconsistent_double_endorsement_evidence
|
||||||
@ -60,6 +58,12 @@ type error += Outdated_double_baking_evidence
|
|||||||
type error += Invalid_activation of { pkh : Ed25519.Public_key_hash.t }
|
type error += Invalid_activation of { pkh : Ed25519.Public_key_hash.t }
|
||||||
type error += Multiple_revelation
|
type error += Multiple_revelation
|
||||||
type error += Gas_quota_exceeded_init_deserialize (* Permanent *)
|
type error += Gas_quota_exceeded_init_deserialize (* Permanent *)
|
||||||
|
type error +=
|
||||||
|
Not_enough_endorsements_for_priority of
|
||||||
|
{ required : int ;
|
||||||
|
priority : int ;
|
||||||
|
endorsements : int ;
|
||||||
|
timestamp: Time.t }
|
||||||
|
|
||||||
let () =
|
let () =
|
||||||
register_error_kind
|
register_error_kind
|
||||||
@ -135,30 +139,6 @@ let () =
|
|||||||
Operation.internal_operation_encoding
|
Operation.internal_operation_encoding
|
||||||
(function Internal_operation_replay op -> Some op | _ -> None)
|
(function Internal_operation_replay op -> Some op | _ -> None)
|
||||||
(fun op -> Internal_operation_replay op) ;
|
(fun op -> Internal_operation_replay op) ;
|
||||||
register_error_kind
|
|
||||||
`Permanent
|
|
||||||
~id:"cannot_originate_non_spendable_account"
|
|
||||||
~title:"Cannot originate non spendable account"
|
|
||||||
~description:"An origination was attempted \
|
|
||||||
that would create a non spendable, non scripted contract"
|
|
||||||
~pp:(fun ppf () ->
|
|
||||||
Format.fprintf ppf "It is not possible anymore to originate \
|
|
||||||
a non scripted contract that is not spendable.")
|
|
||||||
Data_encoding.empty
|
|
||||||
(function Cannot_originate_non_spendable_account -> Some () | _ -> None)
|
|
||||||
(fun () -> Cannot_originate_non_spendable_account) ;
|
|
||||||
register_error_kind
|
|
||||||
`Permanent
|
|
||||||
~id:"cannot_originate_spendable_smart_contract"
|
|
||||||
~title:"Cannot originate spendable smart contract"
|
|
||||||
~description:"An origination was attempted \
|
|
||||||
that would create a spendable scripted contract"
|
|
||||||
~pp:(fun ppf () ->
|
|
||||||
Format.fprintf ppf "It is not possible anymore to originate \
|
|
||||||
a scripted contract that is spendable.")
|
|
||||||
Data_encoding.empty
|
|
||||||
(function Cannot_originate_spendable_smart_contract -> Some () | _ -> None)
|
|
||||||
(fun () -> Cannot_originate_spendable_smart_contract) ;
|
|
||||||
register_error_kind
|
register_error_kind
|
||||||
`Permanent
|
`Permanent
|
||||||
~id:"block.invalid_double_endorsement_evidence"
|
~id:"block.invalid_double_endorsement_evidence"
|
||||||
@ -372,34 +352,49 @@ let () =
|
|||||||
parse within the provided gas bounds."
|
parse within the provided gas bounds."
|
||||||
Data_encoding.empty
|
Data_encoding.empty
|
||||||
(function Gas_quota_exceeded_init_deserialize -> Some () | _ -> None)
|
(function Gas_quota_exceeded_init_deserialize -> Some () | _ -> None)
|
||||||
(fun () -> Gas_quota_exceeded_init_deserialize)
|
(fun () -> Gas_quota_exceeded_init_deserialize) ;
|
||||||
|
register_error_kind
|
||||||
|
`Permanent
|
||||||
|
~id:"operation.not_enought_endorsements_for_priority"
|
||||||
|
~title:"Not enough endorsements for priority"
|
||||||
|
~description:"The block being validated does not include the \
|
||||||
|
required minimum number of endorsements for this priority."
|
||||||
|
~pp:(fun ppf (required, endorsements, priority, timestamp) ->
|
||||||
|
Format.fprintf ppf "Wrong number of endorsements (%i) for \
|
||||||
|
priority (%i), %i are expected at %a"
|
||||||
|
endorsements priority required Time.pp_hum timestamp)
|
||||||
|
Data_encoding.(obj4
|
||||||
|
(req "required" int31)
|
||||||
|
(req "endorsements" int31)
|
||||||
|
(req "priority" int31)
|
||||||
|
(req "timestamp" Time.encoding))
|
||||||
|
(function Not_enough_endorsements_for_priority
|
||||||
|
{ required ; endorsements ; priority ; timestamp } ->
|
||||||
|
Some (required, endorsements, priority, timestamp) | _ -> None)
|
||||||
|
(fun (required, endorsements, priority, timestamp) ->
|
||||||
|
Not_enough_endorsements_for_priority
|
||||||
|
{ required ; endorsements ; priority ; timestamp })
|
||||||
|
|
||||||
open Apply_results
|
open Apply_results
|
||||||
|
|
||||||
let apply_manager_operation_content :
|
let apply_manager_operation_content :
|
||||||
type kind.
|
type kind.
|
||||||
( Alpha_context.t -> Script_ir_translator.unparsing_mode -> payer:Contract.t -> source:Contract.t ->
|
( Alpha_context.t -> Script_ir_translator.unparsing_mode -> payer:Contract.t -> source:Contract.t ->
|
||||||
internal:bool -> kind manager_operation ->
|
chain_id:Chain_id.t -> internal:bool -> kind manager_operation ->
|
||||||
(context * kind successful_manager_operation_result * packed_internal_operation list) tzresult Lwt.t ) =
|
(context * kind successful_manager_operation_result * packed_internal_operation list) tzresult Lwt.t ) =
|
||||||
fun ctxt mode ~payer ~source ~internal operation ->
|
fun ctxt mode ~payer ~source ~chain_id ~internal operation ->
|
||||||
let before_operation =
|
let before_operation =
|
||||||
(* This context is not used for backtracking. Only to compute
|
(* This context is not used for backtracking. Only to compute
|
||||||
gas consumption and originations for the operation result. *)
|
gas consumption and originations for the operation result. *)
|
||||||
ctxt in
|
ctxt in
|
||||||
Contract.must_exist ctxt source >>=? fun () ->
|
Contract.must_exist ctxt source >>=? fun () ->
|
||||||
let spend =
|
|
||||||
(* Ignore the spendable flag for smart contracts. *)
|
|
||||||
if internal then Contract.spend_from_script else Contract.spend in
|
|
||||||
let set_delegate =
|
|
||||||
(* Ignore the delegatable flag for smart contracts. *)
|
|
||||||
if internal then Delegate.set_from_script else Delegate.set in
|
|
||||||
Lwt.return (Gas.consume ctxt Michelson_v1_gas.Cost_of.manager_operation) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt Michelson_v1_gas.Cost_of.manager_operation) >>=? fun ctxt ->
|
||||||
match operation with
|
match operation with
|
||||||
| Reveal _ ->
|
| Reveal _ ->
|
||||||
return (* No-op: action already performed by `precheck_manager_contents`. *)
|
return (* No-op: action already performed by `precheck_manager_contents`. *)
|
||||||
(ctxt, (Reveal_result { consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt } : kind successful_manager_operation_result), [])
|
(ctxt, (Reveal_result { consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt } : kind successful_manager_operation_result), [])
|
||||||
| Transaction { amount ; parameters ; destination } -> begin
|
| Transaction { amount ; parameters ; destination ; entrypoint } -> begin
|
||||||
spend ctxt source amount >>=? fun ctxt ->
|
Contract.spend ctxt source amount >>=? fun ctxt ->
|
||||||
begin match Contract.is_implicit destination with
|
begin match Contract.is_implicit destination with
|
||||||
| None -> return (ctxt, [], false)
|
| None -> return (ctxt, [], false)
|
||||||
| Some _ ->
|
| Some _ ->
|
||||||
@ -413,10 +408,11 @@ let apply_manager_operation_content :
|
|||||||
Contract.get_script ctxt destination >>=? fun (ctxt, script) ->
|
Contract.get_script ctxt destination >>=? fun (ctxt, script) ->
|
||||||
match script with
|
match script with
|
||||||
| None -> begin
|
| None -> begin
|
||||||
match parameters with
|
begin match entrypoint with
|
||||||
| None -> return ctxt
|
| "default" -> return ()
|
||||||
| Some arg ->
|
| entrypoint -> fail (Script_tc_errors.No_such_entrypoint entrypoint)
|
||||||
Script.force_decode ctxt arg >>=? fun (arg, ctxt) -> (* see [note] *)
|
end >>=? fun () ->
|
||||||
|
Script.force_decode ctxt parameters >>=? fun (arg, ctxt) -> (* see [note] *)
|
||||||
(* [note]: for toplevel ops, cost is nil since the
|
(* [note]: for toplevel ops, cost is nil since the
|
||||||
lazy value has already been forced at precheck, so
|
lazy value has already been forced at precheck, so
|
||||||
we compute and consume the full cost again *)
|
we compute and consume the full cost again *)
|
||||||
@ -445,20 +441,18 @@ let apply_manager_operation_content :
|
|||||||
} in
|
} in
|
||||||
return (ctxt, result, [])
|
return (ctxt, result, [])
|
||||||
| Some script ->
|
| Some script ->
|
||||||
begin match parameters with
|
Script.force_decode ctxt parameters >>=? fun (parameter, ctxt) -> (* see [note] *)
|
||||||
| None ->
|
let cost_parameter = Script.deserialized_cost parameter in
|
||||||
(* Forge a [Unit] parameter that will be checked by [execute]. *)
|
Lwt.return (Gas.consume ctxt cost_parameter) >>=? fun ctxt ->
|
||||||
let unit = Micheline.strip_locations (Prim (0, Script.D_Unit, [], [])) in
|
let step_constants =
|
||||||
return (ctxt, unit)
|
let open Script_interpreter in
|
||||||
| Some parameters ->
|
{ source ;
|
||||||
Script.force_decode ctxt parameters >>=? fun (arg, ctxt) -> (* see [note] *)
|
payer ;
|
||||||
let cost_arg = Script.deserialized_cost arg in
|
self = destination ;
|
||||||
Lwt.return (Gas.consume ctxt cost_arg) >>=? fun ctxt ->
|
amount ;
|
||||||
return (ctxt, arg)
|
chain_id } in
|
||||||
end >>=? fun (ctxt, parameter) ->
|
|
||||||
Script_interpreter.execute
|
Script_interpreter.execute
|
||||||
ctxt mode
|
ctxt mode step_constants ~script ~parameter ~entrypoint
|
||||||
~source ~payer ~self:(destination, script) ~amount ~parameter
|
|
||||||
>>=? fun { ctxt ; storage ; big_map_diff ; operations } ->
|
>>=? fun { ctxt ; storage ; big_map_diff ; operations } ->
|
||||||
Contract.update_script_storage
|
Contract.update_script_storage
|
||||||
ctxt destination storage big_map_diff >>=? fun ctxt ->
|
ctxt destination storage big_map_diff >>=? fun ctxt ->
|
||||||
@ -483,27 +477,20 @@ let apply_manager_operation_content :
|
|||||||
allocated_destination_contract } in
|
allocated_destination_contract } in
|
||||||
return (ctxt, result, operations)
|
return (ctxt, result, operations)
|
||||||
end
|
end
|
||||||
| Origination { manager ; delegate ; script ; preorigination ;
|
| Origination { delegate ; script ; preorigination ; credit } ->
|
||||||
spendable ; delegatable ; credit } ->
|
|
||||||
begin match script with
|
|
||||||
| None ->
|
|
||||||
if spendable then
|
|
||||||
return (None, ctxt)
|
|
||||||
else
|
|
||||||
fail Cannot_originate_non_spendable_account
|
|
||||||
| Some script ->
|
|
||||||
if spendable then
|
|
||||||
fail Cannot_originate_spendable_smart_contract
|
|
||||||
else
|
|
||||||
Script.force_decode ctxt script.storage >>=? fun (unparsed_storage, ctxt) -> (* see [note] *)
|
Script.force_decode ctxt script.storage >>=? fun (unparsed_storage, ctxt) -> (* see [note] *)
|
||||||
Lwt.return (Gas.consume ctxt (Script.deserialized_cost unparsed_storage)) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt (Script.deserialized_cost unparsed_storage)) >>=? fun ctxt ->
|
||||||
Script.force_decode ctxt script.code >>=? fun (unparsed_code, ctxt) -> (* see [note] *)
|
Script.force_decode ctxt script.code >>=? fun (unparsed_code, ctxt) -> (* see [note] *)
|
||||||
Lwt.return (Gas.consume ctxt (Script.deserialized_cost unparsed_code)) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt (Script.deserialized_cost unparsed_code)) >>=? fun ctxt ->
|
||||||
Script_ir_translator.parse_script ctxt script >>=? fun (ex_script, ctxt) ->
|
Script_ir_translator.parse_script ctxt ~legacy:false script >>=? fun (Ex_script parsed_script, ctxt) ->
|
||||||
Script_ir_translator.big_map_initialization ctxt Optimized ex_script >>=? fun (big_map_diff, ctxt) ->
|
Script_ir_translator.collect_big_maps ctxt parsed_script.storage_type parsed_script.storage >>=? fun (to_duplicate, ctxt) ->
|
||||||
return (Some (script, big_map_diff), ctxt)
|
let to_update = Script_ir_translator.no_big_map_id in
|
||||||
end >>=? fun (script, ctxt) ->
|
Script_ir_translator.extract_big_map_diff ctxt Optimized parsed_script.storage_type parsed_script.storage
|
||||||
spend ctxt source credit >>=? fun ctxt ->
|
~to_duplicate ~to_update ~temporary:false >>=? fun (storage, big_map_diff, ctxt) ->
|
||||||
|
Script_ir_translator.unparse_data ctxt Optimized parsed_script.storage_type storage >>=? fun (storage, ctxt) ->
|
||||||
|
let storage = Script.lazy_expr (Micheline.strip_locations storage) in
|
||||||
|
let script = { script with storage } in
|
||||||
|
Contract.spend ctxt source credit >>=? fun ctxt ->
|
||||||
begin match preorigination with
|
begin match preorigination with
|
||||||
| Some contract ->
|
| Some contract ->
|
||||||
assert internal ;
|
assert internal ;
|
||||||
@ -515,14 +502,14 @@ let apply_manager_operation_content :
|
|||||||
Contract.fresh_contract_from_current_nonce ctxt
|
Contract.fresh_contract_from_current_nonce ctxt
|
||||||
end >>=? fun (ctxt, contract) ->
|
end >>=? fun (ctxt, contract) ->
|
||||||
Contract.originate ctxt contract
|
Contract.originate ctxt contract
|
||||||
~manager ~delegate ~balance:credit
|
~delegate ~balance:credit
|
||||||
?script
|
~script:(script, big_map_diff) >>=? fun ctxt ->
|
||||||
~spendable ~delegatable >>=? fun ctxt ->
|
|
||||||
Fees.origination_burn ctxt >>=? fun (ctxt, origination_burn) ->
|
Fees.origination_burn ctxt >>=? fun (ctxt, origination_burn) ->
|
||||||
Fees.record_paid_storage_space ctxt contract >>=? fun (ctxt, size, paid_storage_size_diff, fees) ->
|
Fees.record_paid_storage_space ctxt contract >>=? fun (ctxt, size, paid_storage_size_diff, fees) ->
|
||||||
let result =
|
let result =
|
||||||
Origination_result
|
Origination_result
|
||||||
{ balance_updates =
|
{ big_map_diff ;
|
||||||
|
balance_updates =
|
||||||
Delegate.cleanup_balance_updates
|
Delegate.cleanup_balance_updates
|
||||||
[ Contract payer, Debited fees ;
|
[ Contract payer, Debited fees ;
|
||||||
Contract payer, Debited origination_burn ;
|
Contract payer, Debited origination_burn ;
|
||||||
@ -534,10 +521,10 @@ let apply_manager_operation_content :
|
|||||||
paid_storage_size_diff } in
|
paid_storage_size_diff } in
|
||||||
return (ctxt, result, [])
|
return (ctxt, result, [])
|
||||||
| Delegation delegate ->
|
| Delegation delegate ->
|
||||||
set_delegate ctxt source delegate >>=? fun ctxt ->
|
Delegate.set ctxt source delegate >>=? fun ctxt ->
|
||||||
return (ctxt, Delegation_result { consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt }, [])
|
return (ctxt, Delegation_result { consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt }, [])
|
||||||
|
|
||||||
let apply_internal_manager_operations ctxt mode ~payer ops =
|
let apply_internal_manager_operations ctxt mode ~payer ~chain_id ops =
|
||||||
let rec apply ctxt applied worklist =
|
let rec apply ctxt applied worklist =
|
||||||
match worklist with
|
match worklist with
|
||||||
| [] -> Lwt.return (`Success ctxt, List.rev applied)
|
| [] -> Lwt.return (`Success ctxt, List.rev applied)
|
||||||
@ -549,7 +536,7 @@ let apply_internal_manager_operations ctxt mode ~payer ops =
|
|||||||
else
|
else
|
||||||
let ctxt = record_internal_nonce ctxt nonce in
|
let ctxt = record_internal_nonce ctxt nonce in
|
||||||
apply_manager_operation_content
|
apply_manager_operation_content
|
||||||
ctxt mode ~source ~payer ~internal:true operation
|
ctxt mode ~source ~payer ~chain_id ~internal:true operation
|
||||||
end >>= function
|
end >>= function
|
||||||
| Error errors ->
|
| Error errors ->
|
||||||
let result =
|
let result =
|
||||||
@ -573,20 +560,20 @@ let precheck_manager_contents
|
|||||||
Lwt.return (Gas.check_limit ctxt gas_limit) >>=? fun () ->
|
Lwt.return (Gas.check_limit ctxt gas_limit) >>=? fun () ->
|
||||||
let ctxt = Gas.set_limit ctxt gas_limit in
|
let ctxt = Gas.set_limit ctxt gas_limit in
|
||||||
Lwt.return (Fees.check_storage_limit ctxt storage_limit) >>=? fun () ->
|
Lwt.return (Fees.check_storage_limit ctxt storage_limit) >>=? fun () ->
|
||||||
Contract.must_be_allocated ctxt source >>=? fun () ->
|
Contract.must_be_allocated ctxt (Contract.implicit_contract source) >>=? fun () ->
|
||||||
Contract.check_counter_increment ctxt source counter >>=? fun () ->
|
Contract.check_counter_increment ctxt source counter >>=? fun () ->
|
||||||
begin
|
begin
|
||||||
match operation with
|
match operation with
|
||||||
| Reveal pk ->
|
| Reveal pk ->
|
||||||
Contract.reveal_manager_key ctxt source pk
|
Contract.reveal_manager_key ctxt source pk
|
||||||
| Transaction { parameters = Some arg ; _ } ->
|
| Transaction { parameters ; _ } ->
|
||||||
(* Fail quickly if not enough gas for minimal deserialization cost *)
|
(* Fail quickly if not enough gas for minimal deserialization cost *)
|
||||||
Lwt.return @@ record_trace Gas_quota_exceeded_init_deserialize @@
|
Lwt.return @@ record_trace Gas_quota_exceeded_init_deserialize @@
|
||||||
Gas.check_enough ctxt (Script.minimal_deserialize_cost arg) >>=? fun () ->
|
Gas.check_enough ctxt (Script.minimal_deserialize_cost parameters) >>=? fun () ->
|
||||||
(* Fail if not enough gas for complete deserialization cost *)
|
(* Fail if not enough gas for complete deserialization cost *)
|
||||||
trace Gas_quota_exceeded_init_deserialize @@
|
trace Gas_quota_exceeded_init_deserialize @@
|
||||||
Script.force_decode ctxt arg >>|? fun (_arg, ctxt) -> ctxt
|
Script.force_decode ctxt parameters >>|? fun (_arg, ctxt) -> ctxt
|
||||||
| Origination { script = Some script ; _ } ->
|
| Origination { script ; _ } ->
|
||||||
(* Fail quickly if not enough gas for minimal deserialization cost *)
|
(* Fail quickly if not enough gas for minimal deserialization cost *)
|
||||||
Lwt.return @@ record_trace Gas_quota_exceeded_init_deserialize @@
|
Lwt.return @@ record_trace Gas_quota_exceeded_init_deserialize @@
|
||||||
(Gas.consume ctxt (Script.minimal_deserialize_cost script.code) >>? fun ctxt ->
|
(Gas.consume ctxt (Script.minimal_deserialize_cost script.code) >>? fun ctxt ->
|
||||||
@ -606,12 +593,12 @@ let precheck_manager_contents
|
|||||||
sequence of transactions. *)
|
sequence of transactions. *)
|
||||||
Operation.check_signature public_key chain_id raw_operation >>=? fun () ->
|
Operation.check_signature public_key chain_id raw_operation >>=? fun () ->
|
||||||
Contract.increment_counter ctxt source >>=? fun ctxt ->
|
Contract.increment_counter ctxt source >>=? fun ctxt ->
|
||||||
Contract.spend ctxt source fee >>=? fun ctxt ->
|
Contract.spend ctxt (Contract.implicit_contract source) fee >>=? fun ctxt ->
|
||||||
add_fees ctxt fee >>=? fun ctxt ->
|
add_fees ctxt fee >>=? fun ctxt ->
|
||||||
return ctxt
|
return ctxt
|
||||||
|
|
||||||
let apply_manager_contents
|
let apply_manager_contents
|
||||||
(type kind) ctxt mode (op : kind Kind.manager contents)
|
(type kind) ctxt mode chain_id (op : kind Kind.manager contents)
|
||||||
: ([ `Success of context | `Failure ] *
|
: ([ `Success of context | `Failure ] *
|
||||||
kind manager_operation_result *
|
kind manager_operation_result *
|
||||||
packed_internal_operation_result list) Lwt.t =
|
packed_internal_operation_result list) Lwt.t =
|
||||||
@ -619,11 +606,12 @@ let apply_manager_contents
|
|||||||
{ source ; operation ; gas_limit ; storage_limit } = op in
|
{ source ; operation ; gas_limit ; storage_limit } = op in
|
||||||
let ctxt = Gas.set_limit ctxt gas_limit in
|
let ctxt = Gas.set_limit ctxt gas_limit in
|
||||||
let ctxt = Fees.start_counting_storage_fees ctxt in
|
let ctxt = Fees.start_counting_storage_fees ctxt in
|
||||||
|
let source = Contract.implicit_contract source in
|
||||||
apply_manager_operation_content ctxt mode
|
apply_manager_operation_content ctxt mode
|
||||||
~source ~payer:source ~internal:false operation >>= function
|
~source ~payer:source ~internal:false ~chain_id operation >>= function
|
||||||
| Ok (ctxt, operation_results, internal_operations) -> begin
|
| Ok (ctxt, operation_results, internal_operations) -> begin
|
||||||
apply_internal_manager_operations
|
apply_internal_manager_operations
|
||||||
ctxt mode ~payer:source internal_operations >>= function
|
ctxt mode ~payer:source ~chain_id internal_operations >>= function
|
||||||
| (`Success ctxt, internal_operations_results) -> begin
|
| (`Success ctxt, internal_operations_results) -> begin
|
||||||
Fees.burn_storage_fees ctxt ~storage_limit ~payer:source >>= function
|
Fees.burn_storage_fees ctxt ~storage_limit ~payer:source >>= function
|
||||||
| Ok ctxt ->
|
| Ok ctxt ->
|
||||||
@ -654,6 +642,7 @@ let rec mark_skipped
|
|||||||
baker : Signature.Public_key_hash.t -> Level.t -> kind Kind.manager contents_list ->
|
baker : Signature.Public_key_hash.t -> Level.t -> kind Kind.manager contents_list ->
|
||||||
kind Kind.manager contents_result_list = fun ~baker level -> function
|
kind Kind.manager contents_result_list = fun ~baker level -> function
|
||||||
| Single (Manager_operation { source ; fee ; operation } ) ->
|
| Single (Manager_operation { source ; fee ; operation } ) ->
|
||||||
|
let source = Contract.implicit_contract source in
|
||||||
Single_result
|
Single_result
|
||||||
(Manager_operation_result
|
(Manager_operation_result
|
||||||
{ balance_updates =
|
{ balance_updates =
|
||||||
@ -663,6 +652,7 @@ let rec mark_skipped
|
|||||||
operation_result = skipped_operation_result operation ;
|
operation_result = skipped_operation_result operation ;
|
||||||
internal_operation_results = [] })
|
internal_operation_results = [] })
|
||||||
| Cons (Manager_operation { source ; fee ; operation } , rest) ->
|
| Cons (Manager_operation { source ; fee ; operation } , rest) ->
|
||||||
|
let source = Contract.implicit_contract source in
|
||||||
Cons_result
|
Cons_result
|
||||||
(Manager_operation_result {
|
(Manager_operation_result {
|
||||||
balance_updates =
|
balance_updates =
|
||||||
@ -688,14 +678,15 @@ let rec precheck_manager_contents_list
|
|||||||
let rec apply_manager_contents_list_rec
|
let rec apply_manager_contents_list_rec
|
||||||
: type kind.
|
: type kind.
|
||||||
Alpha_context.t -> Script_ir_translator.unparsing_mode ->
|
Alpha_context.t -> Script_ir_translator.unparsing_mode ->
|
||||||
public_key_hash -> kind Kind.manager contents_list ->
|
public_key_hash -> Chain_id.t -> kind Kind.manager contents_list ->
|
||||||
([ `Success of context | `Failure ] *
|
([ `Success of context | `Failure ] *
|
||||||
kind Kind.manager contents_result_list) Lwt.t =
|
kind Kind.manager contents_result_list) Lwt.t =
|
||||||
fun ctxt mode baker contents_list ->
|
fun ctxt mode baker chain_id contents_list ->
|
||||||
let level = Level.current ctxt in
|
let level = Level.current ctxt in
|
||||||
match contents_list with
|
match contents_list with
|
||||||
| Single (Manager_operation { source ; fee ; _ } as op) -> begin
|
| Single (Manager_operation { source ; fee ; _ } as op) -> begin
|
||||||
apply_manager_contents ctxt mode op
|
let source = Contract.implicit_contract source in
|
||||||
|
apply_manager_contents ctxt mode chain_id op
|
||||||
>>= fun (ctxt_result, operation_result, internal_operation_results) ->
|
>>= fun (ctxt_result, operation_result, internal_operation_results) ->
|
||||||
let result =
|
let result =
|
||||||
Manager_operation_result {
|
Manager_operation_result {
|
||||||
@ -709,7 +700,8 @@ let rec apply_manager_contents_list_rec
|
|||||||
Lwt.return (ctxt_result, Single_result (result))
|
Lwt.return (ctxt_result, Single_result (result))
|
||||||
end
|
end
|
||||||
| Cons (Manager_operation { source ; fee ; _ } as op, rest) ->
|
| Cons (Manager_operation { source ; fee ; _ } as op, rest) ->
|
||||||
apply_manager_contents ctxt mode op >>= function
|
let source = Contract.implicit_contract source in
|
||||||
|
apply_manager_contents ctxt mode chain_id op >>= function
|
||||||
| (`Failure, operation_result, internal_operation_results) ->
|
| (`Failure, operation_result, internal_operation_results) ->
|
||||||
let result =
|
let result =
|
||||||
Manager_operation_result {
|
Manager_operation_result {
|
||||||
@ -731,7 +723,7 @@ let rec apply_manager_contents_list_rec
|
|||||||
operation_result ;
|
operation_result ;
|
||||||
internal_operation_results ;
|
internal_operation_results ;
|
||||||
} in
|
} in
|
||||||
apply_manager_contents_list_rec ctxt mode baker rest >>= fun (ctxt_result, results) ->
|
apply_manager_contents_list_rec ctxt mode baker chain_id rest >>= fun (ctxt_result, results) ->
|
||||||
Lwt.return (ctxt_result, Cons_result (result, results))
|
Lwt.return (ctxt_result, Cons_result (result, results))
|
||||||
|
|
||||||
let mark_backtracked results =
|
let mark_backtracked results =
|
||||||
@ -765,14 +757,16 @@ let mark_backtracked results =
|
|||||||
| Applied result -> Backtracked (result, None) in
|
| Applied result -> Backtracked (result, None) in
|
||||||
mark_contents_list results
|
mark_contents_list results
|
||||||
|
|
||||||
let apply_manager_contents_list ctxt mode baker contents_list =
|
let apply_manager_contents_list ctxt mode baker chain_id contents_list =
|
||||||
apply_manager_contents_list_rec ctxt mode baker contents_list >>= fun (ctxt_result, results) ->
|
apply_manager_contents_list_rec ctxt mode baker chain_id contents_list >>= fun (ctxt_result, results) ->
|
||||||
match ctxt_result with
|
match ctxt_result with
|
||||||
| `Failure -> Lwt.return (ctxt (* backtracked *), mark_backtracked results)
|
| `Failure -> Lwt.return (ctxt (* backtracked *), mark_backtracked results)
|
||||||
| `Success ctxt -> Lwt.return (ctxt, results)
|
| `Success ctxt ->
|
||||||
|
Big_map.cleanup_temporary ctxt >>= fun ctxt ->
|
||||||
|
Lwt.return (ctxt, results)
|
||||||
|
|
||||||
let apply_contents_list
|
let apply_contents_list
|
||||||
(type kind) ctxt ~partial chain_id mode pred_block baker
|
(type kind) ctxt chain_id mode pred_block baker
|
||||||
(operation : kind operation)
|
(operation : kind operation)
|
||||||
(contents_list : kind contents_list)
|
(contents_list : kind contents_list)
|
||||||
: (context * kind contents_result_list) tzresult Lwt.t =
|
: (context * kind contents_result_list) tzresult Lwt.t =
|
||||||
@ -791,18 +785,12 @@ let apply_contents_list
|
|||||||
else
|
else
|
||||||
let ctxt = record_endorsement ctxt delegate in
|
let ctxt = record_endorsement ctxt delegate in
|
||||||
let gap = List.length slots in
|
let gap = List.length slots in
|
||||||
let ctxt = Fitness.increase ~gap ctxt in
|
|
||||||
Lwt.return
|
Lwt.return
|
||||||
Tez.(Constants.endorsement_security_deposit ctxt *?
|
Tez.(Constants.endorsement_security_deposit ctxt *?
|
||||||
Int64.of_int gap) >>=? fun deposit ->
|
Int64.of_int gap) >>=? fun deposit ->
|
||||||
begin
|
Delegate.freeze_deposit ctxt delegate deposit >>=? fun ctxt ->
|
||||||
if partial then
|
Global.get_block_priority ctxt >>=? fun block_priority ->
|
||||||
Delegate.freeze_deposit ctxt delegate deposit
|
Baking.endorsing_reward ctxt ~block_priority gap >>=? fun reward ->
|
||||||
else
|
|
||||||
add_deposit ctxt delegate deposit
|
|
||||||
end >>=? fun ctxt ->
|
|
||||||
Global.get_last_block_priority ctxt >>=? fun block_priority ->
|
|
||||||
Baking.endorsement_reward ctxt ~block_priority gap >>=? fun reward ->
|
|
||||||
Delegate.freeze_rewards ctxt delegate reward >>=? fun ctxt ->
|
Delegate.freeze_rewards ctxt delegate reward >>=? fun ctxt ->
|
||||||
let level = Level.from_raw ctxt level in
|
let level = Level.from_raw ctxt level in
|
||||||
return (ctxt, Single_result
|
return (ctxt, Single_result
|
||||||
@ -944,17 +932,17 @@ let apply_contents_list
|
|||||||
return (ctxt, Single_result Ballot_result)
|
return (ctxt, Single_result Ballot_result)
|
||||||
| Single (Manager_operation _) as op ->
|
| Single (Manager_operation _) as op ->
|
||||||
precheck_manager_contents_list ctxt chain_id operation op >>=? fun ctxt ->
|
precheck_manager_contents_list ctxt chain_id operation op >>=? fun ctxt ->
|
||||||
apply_manager_contents_list ctxt mode baker op >>= fun (ctxt, result) ->
|
apply_manager_contents_list ctxt mode baker chain_id op >>= fun (ctxt, result) ->
|
||||||
return (ctxt, result)
|
return (ctxt, result)
|
||||||
| Cons (Manager_operation _, _) as op ->
|
| Cons (Manager_operation _, _) as op ->
|
||||||
precheck_manager_contents_list ctxt chain_id operation op >>=? fun ctxt ->
|
precheck_manager_contents_list ctxt chain_id operation op >>=? fun ctxt ->
|
||||||
apply_manager_contents_list ctxt mode baker op >>= fun (ctxt, result) ->
|
apply_manager_contents_list ctxt mode baker chain_id op >>= fun (ctxt, result) ->
|
||||||
return (ctxt, result)
|
return (ctxt, result)
|
||||||
|
|
||||||
let apply_operation ctxt ~partial chain_id mode pred_block baker hash operation =
|
let apply_operation ctxt chain_id mode pred_block baker hash operation =
|
||||||
let ctxt = Contract.init_origination_nonce ctxt hash in
|
let ctxt = Contract.init_origination_nonce ctxt hash in
|
||||||
apply_contents_list
|
apply_contents_list
|
||||||
ctxt ~partial chain_id mode pred_block baker operation
|
ctxt chain_id mode pred_block baker operation
|
||||||
operation.protocol_data.contents >>=? fun (ctxt, result) ->
|
operation.protocol_data.contents >>=? fun (ctxt, result) ->
|
||||||
let ctxt = Gas.set_unlimited ctxt in
|
let ctxt = Gas.set_unlimited ctxt in
|
||||||
let ctxt = Contract.unset_origination_nonce ctxt in
|
let ctxt = Contract.unset_origination_nonce ctxt in
|
||||||
@ -983,15 +971,17 @@ let may_start_new_cycle ctxt =
|
|||||||
return (ctxt, update_balances, deactivated)
|
return (ctxt, update_balances, deactivated)
|
||||||
|
|
||||||
let begin_full_construction ctxt pred_timestamp protocol_data =
|
let begin_full_construction ctxt pred_timestamp protocol_data =
|
||||||
|
Alpha_context.Global.set_block_priority ctxt
|
||||||
|
protocol_data.Block_header.priority >>=? fun ctxt ->
|
||||||
Baking.check_baking_rights
|
Baking.check_baking_rights
|
||||||
ctxt protocol_data pred_timestamp >>=? fun delegate_pk ->
|
ctxt protocol_data pred_timestamp >>=? fun (delegate_pk, block_delay) ->
|
||||||
let ctxt = Fitness.increase ctxt in
|
let ctxt = Fitness.increase ctxt in
|
||||||
match Level.pred ctxt (Level.current ctxt) with
|
match Level.pred ctxt (Level.current ctxt) with
|
||||||
| None -> assert false (* genesis *)
|
| None -> assert false (* genesis *)
|
||||||
| Some pred_level ->
|
| Some pred_level ->
|
||||||
Baking.endorsement_rights ctxt pred_level >>=? fun rights ->
|
Baking.endorsement_rights ctxt pred_level >>=? fun rights ->
|
||||||
let ctxt = init_endorsements ctxt rights in
|
let ctxt = init_endorsements ctxt rights in
|
||||||
return (ctxt, protocol_data, delegate_pk)
|
return (ctxt, protocol_data, delegate_pk, block_delay)
|
||||||
|
|
||||||
let begin_partial_construction ctxt =
|
let begin_partial_construction ctxt =
|
||||||
let ctxt = Fitness.increase ctxt in
|
let ctxt = Fitness.increase ctxt in
|
||||||
@ -1003,11 +993,14 @@ let begin_partial_construction ctxt =
|
|||||||
return ctxt
|
return ctxt
|
||||||
|
|
||||||
let begin_application ctxt chain_id block_header pred_timestamp =
|
let begin_application ctxt chain_id block_header pred_timestamp =
|
||||||
|
Alpha_context.Global.set_block_priority ctxt
|
||||||
|
block_header.Block_header.protocol_data.contents.priority >>=? fun ctxt ->
|
||||||
let current_level = Alpha_context.Level.current ctxt in
|
let current_level = Alpha_context.Level.current ctxt in
|
||||||
Baking.check_proof_of_work_stamp ctxt block_header >>=? fun () ->
|
Baking.check_proof_of_work_stamp ctxt block_header >>=? fun () ->
|
||||||
Baking.check_fitness_gap ctxt block_header >>=? fun () ->
|
Baking.check_fitness_gap ctxt block_header >>=? fun () ->
|
||||||
Baking.check_baking_rights
|
Baking.check_baking_rights
|
||||||
ctxt block_header.protocol_data.contents pred_timestamp >>=? fun delegate_pk ->
|
ctxt block_header.protocol_data.contents pred_timestamp
|
||||||
|
>>=? fun (delegate_pk, block_delay) ->
|
||||||
Baking.check_signature block_header chain_id delegate_pk >>=? fun () ->
|
Baking.check_signature block_header chain_id delegate_pk >>=? fun () ->
|
||||||
let has_commitment =
|
let has_commitment =
|
||||||
match block_header.protocol_data.contents.seed_nonce_hash with
|
match block_header.protocol_data.contents.seed_nonce_hash with
|
||||||
@ -1023,12 +1016,27 @@ let begin_application ctxt chain_id block_header pred_timestamp =
|
|||||||
| Some pred_level ->
|
| Some pred_level ->
|
||||||
Baking.endorsement_rights ctxt pred_level >>=? fun rights ->
|
Baking.endorsement_rights ctxt pred_level >>=? fun rights ->
|
||||||
let ctxt = init_endorsements ctxt rights in
|
let ctxt = init_endorsements ctxt rights in
|
||||||
return (ctxt, delegate_pk)
|
return (ctxt, delegate_pk, block_delay)
|
||||||
|
|
||||||
let finalize_application ctxt protocol_data delegate =
|
let check_minimum_endorsements ctxt protocol_data block_delay included_endorsements =
|
||||||
|
let minimum = Baking.minimum_allowed_endorsements ctxt ~block_delay in
|
||||||
|
let timestamp = Timestamp.current ctxt in
|
||||||
|
fail_unless Compare.Int.(included_endorsements >= minimum)
|
||||||
|
(Not_enough_endorsements_for_priority
|
||||||
|
{ required = minimum ;
|
||||||
|
priority = protocol_data.Block_header.priority ;
|
||||||
|
endorsements = included_endorsements ;
|
||||||
|
timestamp })
|
||||||
|
|
||||||
|
let finalize_application ctxt protocol_data delegate ~block_delay =
|
||||||
|
let included_endorsements = included_endorsements ctxt in
|
||||||
|
check_minimum_endorsements ctxt
|
||||||
|
protocol_data block_delay included_endorsements >>=? fun () ->
|
||||||
let deposit = Constants.block_security_deposit ctxt in
|
let deposit = Constants.block_security_deposit ctxt in
|
||||||
add_deposit ctxt delegate deposit >>=? fun ctxt ->
|
add_deposit ctxt delegate deposit >>=? fun ctxt ->
|
||||||
let reward = (Constants.block_reward ctxt) in
|
|
||||||
|
Baking.baking_reward ctxt
|
||||||
|
~block_priority:protocol_data.priority ~included_endorsements >>=? fun reward ->
|
||||||
add_rewards ctxt reward >>=? fun ctxt ->
|
add_rewards ctxt reward >>=? fun ctxt ->
|
||||||
Signature.Public_key_hash.Map.fold
|
Signature.Public_key_hash.Map.fold
|
||||||
(fun delegate deposit ctxt ->
|
(fun delegate deposit ctxt ->
|
||||||
@ -1048,8 +1056,6 @@ let finalize_application ctxt protocol_data delegate =
|
|||||||
Nonce.record_hash ctxt
|
Nonce.record_hash ctxt
|
||||||
{ nonce_hash ; delegate ; rewards ; fees }
|
{ nonce_hash ; delegate ; rewards ; fees }
|
||||||
end >>=? fun ctxt ->
|
end >>=? fun ctxt ->
|
||||||
Alpha_context.Global.set_last_block_priority
|
|
||||||
ctxt protocol_data.priority >>=? fun ctxt ->
|
|
||||||
(* end of cycle *)
|
(* end of cycle *)
|
||||||
may_snapshot_roll ctxt >>=? fun ctxt ->
|
may_snapshot_roll ctxt >>=? fun ctxt ->
|
||||||
may_start_new_cycle ctxt >>=? fun (ctxt, balance_updates, deactivated) ->
|
may_start_new_cycle ctxt >>=? fun (ctxt, balance_updates, deactivated) ->
|
||||||
|
@ -56,7 +56,8 @@ type _ successful_manager_operation_result =
|
|||||||
allocated_destination_contract : bool ;
|
allocated_destination_contract : bool ;
|
||||||
} -> Kind.transaction successful_manager_operation_result
|
} -> Kind.transaction successful_manager_operation_result
|
||||||
| Origination_result :
|
| Origination_result :
|
||||||
{ balance_updates : Delegate.balance_updates ;
|
{ big_map_diff : Contract.big_map_diff option ;
|
||||||
|
balance_updates : Delegate.balance_updates ;
|
||||||
originated_contracts : Contract.t list ;
|
originated_contracts : Contract.t list ;
|
||||||
consumed_gas : Z.t ;
|
consumed_gas : Z.t ;
|
||||||
storage_size : Z.t ;
|
storage_size : Z.t ;
|
||||||
@ -215,7 +216,8 @@ module Manager_result = struct
|
|||||||
make
|
make
|
||||||
~op_case: Operation.Encoding.Manager_operations.origination_case
|
~op_case: Operation.Encoding.Manager_operations.origination_case
|
||||||
~encoding:
|
~encoding:
|
||||||
(obj5
|
(obj6
|
||||||
|
(opt "big_map_diff" Contract.big_map_diff_encoding)
|
||||||
(dft "balance_updates" Delegate.balance_updates_encoding [])
|
(dft "balance_updates" Delegate.balance_updates_encoding [])
|
||||||
(dft "originated_contracts" (list Contract.encoding) [])
|
(dft "originated_contracts" (list Contract.encoding) [])
|
||||||
(dft "consumed_gas" z Z.zero)
|
(dft "consumed_gas" z Z.zero)
|
||||||
@ -234,19 +236,19 @@ module Manager_result = struct
|
|||||||
~proj:
|
~proj:
|
||||||
(function
|
(function
|
||||||
| Origination_result
|
| Origination_result
|
||||||
{ balance_updates ;
|
{ big_map_diff ; balance_updates ;
|
||||||
originated_contracts ; consumed_gas ;
|
originated_contracts ; consumed_gas ;
|
||||||
storage_size ; paid_storage_size_diff } ->
|
storage_size ; paid_storage_size_diff } ->
|
||||||
(balance_updates,
|
(big_map_diff, balance_updates,
|
||||||
originated_contracts, consumed_gas,
|
originated_contracts, consumed_gas,
|
||||||
storage_size, paid_storage_size_diff))
|
storage_size, paid_storage_size_diff))
|
||||||
~kind: Kind.Origination_manager_kind
|
~kind: Kind.Origination_manager_kind
|
||||||
~inj:
|
~inj:
|
||||||
(fun (balance_updates,
|
(fun (big_map_diff, balance_updates,
|
||||||
originated_contracts, consumed_gas,
|
originated_contracts, consumed_gas,
|
||||||
storage_size, paid_storage_size_diff) ->
|
storage_size, paid_storage_size_diff) ->
|
||||||
Origination_result
|
Origination_result
|
||||||
{ balance_updates ;
|
{ big_map_diff ; balance_updates ;
|
||||||
originated_contracts ; consumed_gas ;
|
originated_contracts ; consumed_gas ;
|
||||||
storage_size ; paid_storage_size_diff })
|
storage_size ; paid_storage_size_diff })
|
||||||
|
|
||||||
|
@ -100,7 +100,8 @@ and _ successful_manager_operation_result =
|
|||||||
allocated_destination_contract : bool ;
|
allocated_destination_contract : bool ;
|
||||||
} -> Kind.transaction successful_manager_operation_result
|
} -> Kind.transaction successful_manager_operation_result
|
||||||
| Origination_result :
|
| Origination_result :
|
||||||
{ balance_updates : Delegate.balance_updates ;
|
{ big_map_diff : Contract.big_map_diff option ;
|
||||||
|
balance_updates : Delegate.balance_updates ;
|
||||||
originated_contracts : Contract.t list ;
|
originated_contracts : Contract.t list ;
|
||||||
consumed_gas : Z.t ;
|
consumed_gas : Z.t ;
|
||||||
storage_size : Z.t ;
|
storage_size : Z.t ;
|
||||||
|
@ -142,17 +142,19 @@ let earlier_predecessor_timestamp ctxt level =
|
|||||||
let check_timestamp c priority pred_timestamp =
|
let check_timestamp c priority pred_timestamp =
|
||||||
minimal_time c priority pred_timestamp >>=? fun minimal_time ->
|
minimal_time c priority pred_timestamp >>=? fun minimal_time ->
|
||||||
let timestamp = Alpha_context.Timestamp.current c in
|
let timestamp = Alpha_context.Timestamp.current c in
|
||||||
fail_unless Timestamp.(minimal_time <= timestamp)
|
Lwt.return
|
||||||
(Timestamp_too_early (minimal_time, timestamp))
|
(record_trace (Timestamp_too_early (minimal_time, timestamp))
|
||||||
|
Timestamp.(timestamp -? minimal_time))
|
||||||
|
|
||||||
let check_baking_rights c { Block_header.priority ; _ }
|
let check_baking_rights c { Block_header.priority ; _ }
|
||||||
pred_timestamp =
|
pred_timestamp =
|
||||||
let level = Level.current c in
|
let level = Level.current c in
|
||||||
Roll.baking_rights_owner c level ~priority >>=? fun delegate ->
|
Roll.baking_rights_owner c level ~priority >>=? fun delegate ->
|
||||||
check_timestamp c priority pred_timestamp >>=? fun () ->
|
check_timestamp c priority pred_timestamp >>=? fun block_delay ->
|
||||||
return delegate
|
return (delegate, block_delay)
|
||||||
|
|
||||||
type error += Incorrect_priority (* `Permanent *)
|
type error += Incorrect_priority (* `Permanent *)
|
||||||
|
type error += Incorrect_number_of_endorsements (* `Permanent *)
|
||||||
|
|
||||||
let () =
|
let () =
|
||||||
register_error_kind
|
register_error_kind
|
||||||
@ -166,7 +168,34 @@ let () =
|
|||||||
(function Incorrect_priority -> Some () | _ -> None)
|
(function Incorrect_priority -> Some () | _ -> None)
|
||||||
(fun () -> Incorrect_priority)
|
(fun () -> Incorrect_priority)
|
||||||
|
|
||||||
let endorsement_reward ctxt ~block_priority:prio n =
|
let () =
|
||||||
|
let description = "The number of endorsements must be non-negative and \
|
||||||
|
at most the endosers_per_block constant." in
|
||||||
|
register_error_kind
|
||||||
|
`Permanent
|
||||||
|
~id:"incorrect_number_of_endorsements"
|
||||||
|
~title:"Incorrect number of endorsements"
|
||||||
|
~description
|
||||||
|
~pp:(fun ppf () -> Format.fprintf ppf "%s" description)
|
||||||
|
Data_encoding.unit
|
||||||
|
(function Incorrect_number_of_endorsements -> Some () | _ -> None)
|
||||||
|
(fun () -> Incorrect_number_of_endorsements)
|
||||||
|
|
||||||
|
let baking_reward ctxt ~block_priority:prio ~included_endorsements:num_endo =
|
||||||
|
fail_unless Compare.Int.(prio >= 0) Incorrect_priority >>=? fun () ->
|
||||||
|
let max_endorsements = Constants.endorsers_per_block ctxt in
|
||||||
|
fail_unless Compare.Int.(num_endo >= 0 && num_endo <= max_endorsements)
|
||||||
|
Incorrect_number_of_endorsements >>=? fun () ->
|
||||||
|
let prio_factor_denominator = Int64.(succ (of_int prio)) in
|
||||||
|
let endo_factor_numerator = Int64.of_int (8 + 2 * num_endo / max_endorsements) in
|
||||||
|
let endo_factor_denominator = 10L in
|
||||||
|
Lwt.return
|
||||||
|
Tez.(
|
||||||
|
Constants.block_reward ctxt *? endo_factor_numerator >>? fun val1 ->
|
||||||
|
val1 /? endo_factor_denominator >>? fun val2 ->
|
||||||
|
val2 /? prio_factor_denominator)
|
||||||
|
|
||||||
|
let endorsing_reward ctxt ~block_priority:prio n =
|
||||||
if Compare.Int.(prio >= 0)
|
if Compare.Int.(prio >= 0)
|
||||||
then
|
then
|
||||||
Lwt.return
|
Lwt.return
|
||||||
@ -271,9 +300,7 @@ let check_signature block chain_id key =
|
|||||||
fail (Invalid_block_signature (Block_header.hash block,
|
fail (Invalid_block_signature (Block_header.hash block,
|
||||||
Signature.Public_key.hash key))
|
Signature.Public_key.hash key))
|
||||||
|
|
||||||
let max_fitness_gap ctxt =
|
let max_fitness_gap _ctxt = 1L
|
||||||
let slots = Int64.of_int (Constants.endorsers_per_block ctxt + 1) in
|
|
||||||
Int64.add slots 1L
|
|
||||||
|
|
||||||
let check_fitness_gap ctxt (block : Block_header.t) =
|
let check_fitness_gap ctxt (block : Block_header.t) =
|
||||||
let current_fitness = Fitness.current ctxt in
|
let current_fitness = Fitness.current ctxt in
|
||||||
@ -294,3 +321,36 @@ let dawn_of_a_new_cycle ctxt =
|
|||||||
return_some level.cycle
|
return_some level.cycle
|
||||||
else
|
else
|
||||||
return_none
|
return_none
|
||||||
|
|
||||||
|
let minimum_allowed_endorsements ctxt ~block_delay =
|
||||||
|
let minimum = Constants.initial_endorsers ctxt in
|
||||||
|
let delay_per_missing_endorsement =
|
||||||
|
Int64.to_int
|
||||||
|
(Period.to_seconds
|
||||||
|
(Constants.delay_per_missing_endorsement ctxt))
|
||||||
|
in
|
||||||
|
let reduced_time_constraint =
|
||||||
|
let delay = Int64.to_int (Period.to_seconds block_delay) in
|
||||||
|
if Compare.Int.(delay_per_missing_endorsement = 0) then
|
||||||
|
delay
|
||||||
|
else
|
||||||
|
delay / delay_per_missing_endorsement
|
||||||
|
in
|
||||||
|
Compare.Int.max 0 (minimum - reduced_time_constraint)
|
||||||
|
|
||||||
|
let minimal_valid_time ctxt ~priority ~endorsing_power =
|
||||||
|
let predecessor_timestamp = Timestamp.current ctxt in
|
||||||
|
minimal_time ctxt
|
||||||
|
priority predecessor_timestamp >>=? fun minimal_time ->
|
||||||
|
let minimal_required_endorsements = Constants.initial_endorsers ctxt in
|
||||||
|
let delay_per_missing_endorsement =
|
||||||
|
Constants.delay_per_missing_endorsement ctxt
|
||||||
|
in
|
||||||
|
let missing_endorsements =
|
||||||
|
Compare.Int.max 0 (minimal_required_endorsements - endorsing_power) in
|
||||||
|
match Period.mult
|
||||||
|
(Int32.of_int missing_endorsements)
|
||||||
|
delay_per_missing_endorsement with
|
||||||
|
| Ok delay ->
|
||||||
|
return (Time.add minimal_time (Period.to_seconds delay))
|
||||||
|
| Error _ as err -> Lwt.return err
|
||||||
|
@ -47,7 +47,7 @@ val minimal_time: context -> int -> Time.t -> Time.t tzresult Lwt.t
|
|||||||
*)
|
*)
|
||||||
val check_baking_rights:
|
val check_baking_rights:
|
||||||
context -> Block_header.contents -> Time.t ->
|
context -> Block_header.contents -> Time.t ->
|
||||||
public_key tzresult Lwt.t
|
(public_key * Period.t) tzresult Lwt.t
|
||||||
|
|
||||||
(** For a given level computes who has the right to
|
(** For a given level computes who has the right to
|
||||||
include an endorsement in the next block.
|
include an endorsement in the next block.
|
||||||
@ -63,8 +63,15 @@ val check_endorsement_rights:
|
|||||||
context -> Chain_id.t -> Kind.endorsement Operation.t ->
|
context -> Chain_id.t -> Kind.endorsement Operation.t ->
|
||||||
(public_key_hash * int list * bool) tzresult Lwt.t
|
(public_key_hash * int list * bool) tzresult Lwt.t
|
||||||
|
|
||||||
(** Returns the endorsement reward calculated w.r.t a given priority. *)
|
(** Returns the baking reward calculated w.r.t a given priority [p] and a
|
||||||
val endorsement_reward: context -> block_priority:int -> int -> Tez.t tzresult Lwt.t
|
number [e] of included endorsements as follows:
|
||||||
|
(block_reward / (p+1)) * (0.8 + 0.2 * e / endorsers_per_block)
|
||||||
|
*)
|
||||||
|
val baking_reward: context ->
|
||||||
|
block_priority:int -> included_endorsements:int -> Tez.t tzresult Lwt.t
|
||||||
|
|
||||||
|
(** Returns the endorsing reward calculated w.r.t a given priority. *)
|
||||||
|
val endorsing_reward: context -> block_priority:int -> int -> Tez.t tzresult Lwt.t
|
||||||
|
|
||||||
(** [baking_priorities ctxt level] is the lazy list of contract's
|
(** [baking_priorities ctxt level] is the lazy list of contract's
|
||||||
public key hashes that are allowed to bake for [level]. *)
|
public key hashes that are allowed to bake for [level]. *)
|
||||||
@ -106,3 +113,39 @@ val check_fitness_gap:
|
|||||||
val dawn_of_a_new_cycle: context -> Cycle.t option tzresult Lwt.t
|
val dawn_of_a_new_cycle: context -> Cycle.t option tzresult Lwt.t
|
||||||
|
|
||||||
val earlier_predecessor_timestamp: context -> Level.t -> Timestamp.t tzresult Lwt.t
|
val earlier_predecessor_timestamp: context -> Level.t -> Timestamp.t tzresult Lwt.t
|
||||||
|
|
||||||
|
(** Since Emmy+
|
||||||
|
|
||||||
|
A block is valid only if its timestamp has a minimal delay with
|
||||||
|
respect to the previous block's timestamp, and this minimal delay
|
||||||
|
depends not only on the block's priority but also on the number of
|
||||||
|
endorsement operations included in the block.
|
||||||
|
|
||||||
|
In Emmy+, blocks' fitness increases by one unit with each level.
|
||||||
|
|
||||||
|
In this way, Emmy+ simplifies the optimal baking strategy: The
|
||||||
|
bakers used to have to choose whether to wait for more endorsements
|
||||||
|
to include in their block, or to publish the block immediately,
|
||||||
|
without waiting. The incentive for including more endorsements was
|
||||||
|
to increase the fitness and win against unknown blocks. However,
|
||||||
|
when a block was produced too late in the priority period, there
|
||||||
|
was the risk that the block did not reach endorsers before the
|
||||||
|
block of next priority. In Emmy+, the baker does not need to take
|
||||||
|
such a decision, because the baker cannot publish a block too
|
||||||
|
early. *)
|
||||||
|
|
||||||
|
(** Given a delay of a block's timestamp with respect to the minimum
|
||||||
|
time to bake at the block's priority (as returned by
|
||||||
|
`minimum_time`), it returns the minimum number of endorsements that
|
||||||
|
the block has to contain *)
|
||||||
|
val minimum_allowed_endorsements: context -> block_delay:Period.t -> int
|
||||||
|
|
||||||
|
(** This is the somehow the dual of the previous function. Given a
|
||||||
|
block priority and a number of endorsement slots (given by the
|
||||||
|
`endorsing_power` argument), it returns the minimum time at which
|
||||||
|
the next block can be baked. *)
|
||||||
|
val minimal_valid_time:
|
||||||
|
context ->
|
||||||
|
priority:int ->
|
||||||
|
endorsing_power: int ->
|
||||||
|
Time.t tzresult Lwt.t
|
||||||
|
@ -31,7 +31,7 @@ let init_account ctxt
|
|||||||
Contract_storage.credit ctxt contract amount >>=? fun ctxt ->
|
Contract_storage.credit ctxt contract amount >>=? fun ctxt ->
|
||||||
match public_key with
|
match public_key with
|
||||||
| Some public_key ->
|
| Some public_key ->
|
||||||
Contract_storage.reveal_manager_key ctxt contract public_key >>=? fun ctxt ->
|
Contract_storage.reveal_manager_key ctxt public_key_hash public_key >>=? fun ctxt ->
|
||||||
Delegate_storage.set ctxt contract (Some public_key_hash) >>=? fun ctxt ->
|
Delegate_storage.set ctxt contract (Some public_key_hash) >>=? fun ctxt ->
|
||||||
return ctxt
|
return ctxt
|
||||||
| None -> return ctxt
|
| None -> return ctxt
|
||||||
@ -43,11 +43,8 @@ let init_contract ~typecheck ctxt
|
|||||||
Contract_storage.originate ctxt contract
|
Contract_storage.originate ctxt contract
|
||||||
~balance:amount
|
~balance:amount
|
||||||
~prepaid_bootstrap_storage:true
|
~prepaid_bootstrap_storage:true
|
||||||
~manager:Signature.Public_key_hash.zero
|
|
||||||
~script
|
~script
|
||||||
~delegate:(Some delegate)
|
~delegate:(Some delegate) >>=? fun ctxt ->
|
||||||
~spendable:false
|
|
||||||
~delegatable:false >>=? fun ctxt ->
|
|
||||||
return ctxt
|
return ctxt
|
||||||
|
|
||||||
let init ctxt ~typecheck ?ramp_up_cycles ?no_reward_cycles accounts contracts =
|
let init ctxt ~typecheck ?ramp_up_cycles ?no_reward_cycles accounts contracts =
|
||||||
|
@ -23,7 +23,8 @@
|
|||||||
(* *)
|
(* *)
|
||||||
(*****************************************************************************)
|
(*****************************************************************************)
|
||||||
|
|
||||||
let version_number = "\000"
|
let version_number_004 = "\000"
|
||||||
|
let version_number = "\001"
|
||||||
let proof_of_work_nonce_size = 8
|
let proof_of_work_nonce_size = 8
|
||||||
let nonce_length = 32
|
let nonce_length = 32
|
||||||
let max_revelations_per_block = 32
|
let max_revelations_per_block = 32
|
||||||
@ -95,37 +96,11 @@ type parametric = {
|
|||||||
cost_per_byte: Tez_repr.t ;
|
cost_per_byte: Tez_repr.t ;
|
||||||
hard_storage_limit_per_operation: Z.t ;
|
hard_storage_limit_per_operation: Z.t ;
|
||||||
test_chain_duration: int64 ; (* in seconds *)
|
test_chain_duration: int64 ; (* in seconds *)
|
||||||
}
|
quorum_min: int32 ;
|
||||||
|
quorum_max: int32 ;
|
||||||
let default = {
|
min_proposal_quorum: int32 ;
|
||||||
preserved_cycles = 5 ;
|
initial_endorsers: int ;
|
||||||
blocks_per_cycle = 4096l ;
|
delay_per_missing_endorsement: Period_repr.t ;
|
||||||
blocks_per_commitment = 32l ;
|
|
||||||
blocks_per_roll_snapshot = 256l ;
|
|
||||||
blocks_per_voting_period = 32768l ;
|
|
||||||
time_between_blocks =
|
|
||||||
List.map Period_repr.of_seconds_exn [ 60L ; 75L ] ;
|
|
||||||
endorsers_per_block = 32 ;
|
|
||||||
hard_gas_limit_per_operation = Z.of_int 800_000 ;
|
|
||||||
hard_gas_limit_per_block = Z.of_int 8_000_000 ;
|
|
||||||
proof_of_work_threshold =
|
|
||||||
Int64.(sub (shift_left 1L 46) 1L) ;
|
|
||||||
tokens_per_roll =
|
|
||||||
Tez_repr.(mul_exn one 8_000) ;
|
|
||||||
michelson_maximum_type_size = 1000 ;
|
|
||||||
seed_nonce_revelation_tip = begin
|
|
||||||
match Tez_repr.(one /? 8L) with
|
|
||||||
| Ok c -> c
|
|
||||||
| Error _ -> assert false
|
|
||||||
end ;
|
|
||||||
origination_size = 257 ;
|
|
||||||
block_security_deposit = Tez_repr.(mul_exn one 512) ;
|
|
||||||
endorsement_security_deposit = Tez_repr.(mul_exn one 64) ;
|
|
||||||
block_reward = Tez_repr.(mul_exn one 16) ;
|
|
||||||
endorsement_reward = Tez_repr.(mul_exn one 2) ;
|
|
||||||
hard_storage_limit_per_operation = Z.of_int 60_000 ;
|
|
||||||
cost_per_byte = Tez_repr.of_mutez_exn 1_000L ;
|
|
||||||
test_chain_duration = Int64.mul 32768L 60L;
|
|
||||||
}
|
}
|
||||||
|
|
||||||
let parametric_encoding =
|
let parametric_encoding =
|
||||||
@ -152,7 +127,13 @@ let parametric_encoding =
|
|||||||
(c.endorsement_reward,
|
(c.endorsement_reward,
|
||||||
c.cost_per_byte,
|
c.cost_per_byte,
|
||||||
c.hard_storage_limit_per_operation,
|
c.hard_storage_limit_per_operation,
|
||||||
c.test_chain_duration))) )
|
c.test_chain_duration,
|
||||||
|
c.quorum_min,
|
||||||
|
c.quorum_max,
|
||||||
|
c.min_proposal_quorum,
|
||||||
|
c.initial_endorsers,
|
||||||
|
c.delay_per_missing_endorsement
|
||||||
|
))) )
|
||||||
(fun (( preserved_cycles,
|
(fun (( preserved_cycles,
|
||||||
blocks_per_cycle,
|
blocks_per_cycle,
|
||||||
blocks_per_commitment,
|
blocks_per_commitment,
|
||||||
@ -173,7 +154,12 @@ let parametric_encoding =
|
|||||||
(endorsement_reward,
|
(endorsement_reward,
|
||||||
cost_per_byte,
|
cost_per_byte,
|
||||||
hard_storage_limit_per_operation,
|
hard_storage_limit_per_operation,
|
||||||
test_chain_duration))) ->
|
test_chain_duration,
|
||||||
|
quorum_min,
|
||||||
|
quorum_max,
|
||||||
|
min_proposal_quorum,
|
||||||
|
initial_endorsers,
|
||||||
|
delay_per_missing_endorsement))) ->
|
||||||
{ preserved_cycles ;
|
{ preserved_cycles ;
|
||||||
blocks_per_cycle ;
|
blocks_per_cycle ;
|
||||||
blocks_per_commitment ;
|
blocks_per_commitment ;
|
||||||
@ -195,6 +181,11 @@ let parametric_encoding =
|
|||||||
cost_per_byte ;
|
cost_per_byte ;
|
||||||
hard_storage_limit_per_operation ;
|
hard_storage_limit_per_operation ;
|
||||||
test_chain_duration ;
|
test_chain_duration ;
|
||||||
|
quorum_min ;
|
||||||
|
quorum_max ;
|
||||||
|
min_proposal_quorum ;
|
||||||
|
initial_endorsers ;
|
||||||
|
delay_per_missing_endorsement ;
|
||||||
} )
|
} )
|
||||||
(merge_objs
|
(merge_objs
|
||||||
(obj9
|
(obj9
|
||||||
@ -217,11 +208,17 @@ let parametric_encoding =
|
|||||||
(req "block_security_deposit" Tez_repr.encoding)
|
(req "block_security_deposit" Tez_repr.encoding)
|
||||||
(req "endorsement_security_deposit" Tez_repr.encoding)
|
(req "endorsement_security_deposit" Tez_repr.encoding)
|
||||||
(req "block_reward" Tez_repr.encoding))
|
(req "block_reward" Tez_repr.encoding))
|
||||||
(obj4
|
(obj9
|
||||||
(req "endorsement_reward" Tez_repr.encoding)
|
(req "endorsement_reward" Tez_repr.encoding)
|
||||||
(req "cost_per_byte" Tez_repr.encoding)
|
(req "cost_per_byte" Tez_repr.encoding)
|
||||||
(req "hard_storage_limit_per_operation" z)
|
(req "hard_storage_limit_per_operation" z)
|
||||||
(req "test_chain_duration" int64))))
|
(req "test_chain_duration" int64)
|
||||||
|
(req "quorum_min" int32)
|
||||||
|
(req "quorum_max" int32)
|
||||||
|
(req "min_proposal_quorum" int32)
|
||||||
|
(req "initial_endorsers" uint16)
|
||||||
|
(req "delay_per_missing_endorsement" Period_repr.encoding)
|
||||||
|
)))
|
||||||
|
|
||||||
type t = {
|
type t = {
|
||||||
fixed : fixed ;
|
fixed : fixed ;
|
||||||
|
@ -44,6 +44,12 @@ let time_between_blocks c =
|
|||||||
let endorsers_per_block c =
|
let endorsers_per_block c =
|
||||||
let constants = Raw_context.constants c in
|
let constants = Raw_context.constants c in
|
||||||
constants.endorsers_per_block
|
constants.endorsers_per_block
|
||||||
|
let initial_endorsers c =
|
||||||
|
let constants = Raw_context.constants c in
|
||||||
|
constants.initial_endorsers
|
||||||
|
let delay_per_missing_endorsement c =
|
||||||
|
let constants = Raw_context.constants c in
|
||||||
|
constants.delay_per_missing_endorsement
|
||||||
let hard_gas_limit_per_operation c =
|
let hard_gas_limit_per_operation c =
|
||||||
let constants = Raw_context.constants c in
|
let constants = Raw_context.constants c in
|
||||||
constants.hard_gas_limit_per_operation
|
constants.hard_gas_limit_per_operation
|
||||||
@ -86,5 +92,14 @@ let endorsement_reward c =
|
|||||||
let test_chain_duration c =
|
let test_chain_duration c =
|
||||||
let constants = Raw_context.constants c in
|
let constants = Raw_context.constants c in
|
||||||
constants.test_chain_duration
|
constants.test_chain_duration
|
||||||
|
let quorum_min c =
|
||||||
|
let constants = Raw_context.constants c in
|
||||||
|
constants.quorum_min
|
||||||
|
let quorum_max c =
|
||||||
|
let constants = Raw_context.constants c in
|
||||||
|
constants.quorum_max
|
||||||
|
let min_proposal_quorum c =
|
||||||
|
let constants = Raw_context.constants c in
|
||||||
|
constants.min_proposal_quorum
|
||||||
let parametric c =
|
let parametric c =
|
||||||
Raw_context.constants c
|
Raw_context.constants c
|
||||||
|
@ -109,6 +109,8 @@ let () =
|
|||||||
|
|
||||||
let implicit_contract id = Implicit id
|
let implicit_contract id = Implicit id
|
||||||
|
|
||||||
|
let originated_contract_004 id = Originated id
|
||||||
|
|
||||||
let is_implicit = function
|
let is_implicit = function
|
||||||
| Implicit m -> Some m
|
| Implicit m -> Some m
|
||||||
| Originated _ -> None
|
| Originated _ -> None
|
||||||
|
@ -30,13 +30,16 @@ type contract = t
|
|||||||
|
|
||||||
include Compare.S with type t := contract
|
include Compare.S with type t := contract
|
||||||
|
|
||||||
(** {2 Implicit contracts} *****************************************************)
|
(** {2 Implicit contracts} *)
|
||||||
|
|
||||||
val implicit_contract : Signature.Public_key_hash.t -> contract
|
val implicit_contract : Signature.Public_key_hash.t -> contract
|
||||||
|
|
||||||
|
(** Only for migration from proto_004 *)
|
||||||
|
val originated_contract_004 : Contract_hash.t -> contract
|
||||||
|
|
||||||
val is_implicit : contract -> Signature.Public_key_hash.t option
|
val is_implicit : contract -> Signature.Public_key_hash.t option
|
||||||
|
|
||||||
(** {2 Originated contracts} **************************************************)
|
(** {2 Originated contracts} *)
|
||||||
|
|
||||||
(** Originated contracts handles are crafted from the hash of the
|
(** Originated contracts handles are crafted from the hash of the
|
||||||
operation that triggered their origination (and nothing else).
|
operation that triggered their origination (and nothing else).
|
||||||
@ -56,7 +59,7 @@ val incr_origination_nonce : origination_nonce -> origination_nonce
|
|||||||
val is_originated : contract -> Contract_hash.t option
|
val is_originated : contract -> Contract_hash.t option
|
||||||
|
|
||||||
|
|
||||||
(** {2 Human readable notation} ***********************************************)
|
(** {2 Human readable notation} *)
|
||||||
|
|
||||||
type error += Invalid_contract_notation of string (* `Permanent *)
|
type error += Invalid_contract_notation of string (* `Permanent *)
|
||||||
|
|
||||||
@ -68,7 +71,7 @@ val pp: Format.formatter -> contract -> unit
|
|||||||
|
|
||||||
val pp_short: Format.formatter -> contract -> unit
|
val pp_short: Format.formatter -> contract -> unit
|
||||||
|
|
||||||
(** {2 Serializers} ***********************************************************)
|
(** {2 Serializers} *)
|
||||||
|
|
||||||
val encoding : contract Data_encoding.t
|
val encoding : contract Data_encoding.t
|
||||||
|
|
||||||
|
@ -28,35 +28,28 @@ open Alpha_context
|
|||||||
let custom_root =
|
let custom_root =
|
||||||
(RPC_path.(open_root / "context" / "contracts") : RPC_context.t RPC_path.context)
|
(RPC_path.(open_root / "context" / "contracts") : RPC_context.t RPC_path.context)
|
||||||
|
|
||||||
|
let big_map_root =
|
||||||
|
(RPC_path.(open_root / "context" / "big_maps") : RPC_context.t RPC_path.context)
|
||||||
|
|
||||||
type info = {
|
type info = {
|
||||||
manager: public_key_hash ;
|
|
||||||
balance: Tez.t ;
|
balance: Tez.t ;
|
||||||
spendable: bool ;
|
delegate: public_key_hash option ;
|
||||||
delegate: bool * public_key_hash option ;
|
counter: counter option ;
|
||||||
counter: counter ;
|
|
||||||
script: Script.t option ;
|
script: Script.t option ;
|
||||||
}
|
}
|
||||||
|
|
||||||
let info_encoding =
|
let info_encoding =
|
||||||
let open Data_encoding in
|
let open Data_encoding in
|
||||||
conv
|
conv
|
||||||
(fun {manager ; balance ; spendable ; delegate ;
|
(fun {balance ; delegate ; script ; counter } ->
|
||||||
script ; counter } ->
|
(balance, delegate, script, counter))
|
||||||
(manager, balance, spendable, delegate,
|
(fun (balance, delegate, script, counter) ->
|
||||||
script, counter))
|
{balance ; delegate ; script ; counter}) @@
|
||||||
(fun (manager, balance, spendable, delegate,
|
obj4
|
||||||
script, counter) ->
|
|
||||||
{manager ; balance ; spendable ; delegate ;
|
|
||||||
script ; counter}) @@
|
|
||||||
obj6
|
|
||||||
(req "manager" Signature.Public_key_hash.encoding)
|
|
||||||
(req "balance" Tez.encoding)
|
(req "balance" Tez.encoding)
|
||||||
(req "spendable" bool)
|
(opt "delegate" Signature.Public_key_hash.encoding)
|
||||||
(req "delegate" @@ obj2
|
|
||||||
(req "setable" bool)
|
|
||||||
(opt "value" Signature.Public_key_hash.encoding))
|
|
||||||
(opt "script" Script.encoding)
|
(opt "script" Script.encoding)
|
||||||
(req "counter" n)
|
(opt "counter" n)
|
||||||
|
|
||||||
module S = struct
|
module S = struct
|
||||||
|
|
||||||
@ -69,20 +62,11 @@ module S = struct
|
|||||||
~output: Tez.encoding
|
~output: Tez.encoding
|
||||||
RPC_path.(custom_root /: Contract.rpc_arg / "balance")
|
RPC_path.(custom_root /: Contract.rpc_arg / "balance")
|
||||||
|
|
||||||
let manager =
|
|
||||||
RPC_service.get_service
|
|
||||||
~description: "Access the manager of a contract."
|
|
||||||
~query: RPC_query.empty
|
|
||||||
~output: Signature.Public_key_hash.encoding
|
|
||||||
RPC_path.(custom_root /: Contract.rpc_arg / "manager")
|
|
||||||
|
|
||||||
let manager_key =
|
let manager_key =
|
||||||
RPC_service.get_service
|
RPC_service.get_service
|
||||||
~description: "Access the manager of a contract."
|
~description: "Access the manager of a contract."
|
||||||
~query: RPC_query.empty
|
~query: RPC_query.empty
|
||||||
~output: (obj2
|
~output: (option Signature.Public_key.encoding)
|
||||||
(req "manager" Signature.Public_key_hash.encoding)
|
|
||||||
(opt "key" Signature.Public_key.encoding))
|
|
||||||
RPC_path.(custom_root /: Contract.rpc_arg / "manager_key")
|
RPC_path.(custom_root /: Contract.rpc_arg / "manager_key")
|
||||||
|
|
||||||
let delegate =
|
let delegate =
|
||||||
@ -99,20 +83,6 @@ module S = struct
|
|||||||
~output: z
|
~output: z
|
||||||
RPC_path.(custom_root /: Contract.rpc_arg / "counter")
|
RPC_path.(custom_root /: Contract.rpc_arg / "counter")
|
||||||
|
|
||||||
let spendable =
|
|
||||||
RPC_service.get_service
|
|
||||||
~description: "Tells if the contract tokens can be spent by the manager."
|
|
||||||
~query: RPC_query.empty
|
|
||||||
~output: bool
|
|
||||||
RPC_path.(custom_root /: Contract.rpc_arg / "spendable")
|
|
||||||
|
|
||||||
let delegatable =
|
|
||||||
RPC_service.get_service
|
|
||||||
~description: "Tells if the contract delegate can be changed."
|
|
||||||
~query: RPC_query.empty
|
|
||||||
~output: bool
|
|
||||||
RPC_path.(custom_root /: Contract.rpc_arg / "delegatable")
|
|
||||||
|
|
||||||
let script =
|
let script =
|
||||||
RPC_service.get_service
|
RPC_service.get_service
|
||||||
~description: "Access the code and data of the contract."
|
~description: "Access the code and data of the contract."
|
||||||
@ -127,9 +97,30 @@ module S = struct
|
|||||||
~output: Script.expr_encoding
|
~output: Script.expr_encoding
|
||||||
RPC_path.(custom_root /: Contract.rpc_arg / "storage")
|
RPC_path.(custom_root /: Contract.rpc_arg / "storage")
|
||||||
|
|
||||||
let big_map_get =
|
let entrypoint_type =
|
||||||
|
RPC_service.get_service
|
||||||
|
~description: "Return the type of the given entrypoint of the contract"
|
||||||
|
~query: RPC_query.empty
|
||||||
|
~output: Script.expr_encoding
|
||||||
|
RPC_path.(custom_root /: Contract.rpc_arg / "entrypoints" /: RPC_arg.string)
|
||||||
|
|
||||||
|
|
||||||
|
let list_entrypoints =
|
||||||
|
RPC_service.get_service
|
||||||
|
~description: "Return the list of entrypoints of the contract"
|
||||||
|
~query: RPC_query.empty
|
||||||
|
~output: (obj2
|
||||||
|
(dft "unreachable"
|
||||||
|
(Data_encoding.list
|
||||||
|
(obj1 (req "path" (Data_encoding.list Michelson_v1_primitives.prim_encoding))))
|
||||||
|
[])
|
||||||
|
(req "entrypoints"
|
||||||
|
(assoc Script.expr_encoding)))
|
||||||
|
RPC_path.(custom_root /: Contract.rpc_arg / "entrypoints")
|
||||||
|
|
||||||
|
let contract_big_map_get_opt =
|
||||||
RPC_service.post_service
|
RPC_service.post_service
|
||||||
~description: "Access the value associated with a key in the big map storage of the contract."
|
~description: "Access the value associated with a key in a big map of the contract (deprecated)."
|
||||||
~query: RPC_query.empty
|
~query: RPC_query.empty
|
||||||
~input: (obj2
|
~input: (obj2
|
||||||
(req "key" Script.expr_encoding)
|
(req "key" Script.expr_encoding)
|
||||||
@ -137,6 +128,13 @@ module S = struct
|
|||||||
~output: (option Script.expr_encoding)
|
~output: (option Script.expr_encoding)
|
||||||
RPC_path.(custom_root /: Contract.rpc_arg / "big_map_get")
|
RPC_path.(custom_root /: Contract.rpc_arg / "big_map_get")
|
||||||
|
|
||||||
|
let big_map_get =
|
||||||
|
RPC_service.get_service
|
||||||
|
~description: "Access the value associated with a key in a big map."
|
||||||
|
~query: RPC_query.empty
|
||||||
|
~output: Script.expr_encoding
|
||||||
|
RPC_path.(big_map_root /: Big_map.rpc_arg /: Script_expr_hash.rpc_arg)
|
||||||
|
|
||||||
let info =
|
let info =
|
||||||
RPC_service.get_service
|
RPC_service.get_service
|
||||||
~description: "Access the complete status of a contract."
|
~description: "Access the complete status of a contract."
|
||||||
@ -170,20 +168,39 @@ let register () =
|
|||||||
f ctxt a1 >>=? function
|
f ctxt a1 >>=? function
|
||||||
| None -> raise Not_found
|
| None -> raise Not_found
|
||||||
| Some v -> return v) in
|
| Some v -> return v) in
|
||||||
|
let do_big_map_get ctxt id key =
|
||||||
|
let open Script_ir_translator in
|
||||||
|
let ctxt = Gas.set_unlimited ctxt in
|
||||||
|
Big_map.exists ctxt id >>=? fun (ctxt, types) ->
|
||||||
|
match types with
|
||||||
|
| None -> raise Not_found
|
||||||
|
| Some (_, value_type) ->
|
||||||
|
Lwt.return (parse_ty ctxt
|
||||||
|
~legacy:true ~allow_big_map:false ~allow_operation:false ~allow_contract:true
|
||||||
|
(Micheline.root value_type))
|
||||||
|
>>=? fun (Ex_ty value_type, ctxt) ->
|
||||||
|
Big_map.get_opt ctxt id key >>=? fun (_ctxt, value) ->
|
||||||
|
match value with
|
||||||
|
| None -> raise Not_found
|
||||||
|
| Some value ->
|
||||||
|
parse_data ctxt ~legacy:true value_type (Micheline.root value) >>=? fun (value, ctxt) ->
|
||||||
|
unparse_data ctxt Readable value_type value >>=? fun (value, _ctxt) ->
|
||||||
|
return (Micheline.strip_locations value) in
|
||||||
register_field S.balance Contract.get_balance ;
|
register_field S.balance Contract.get_balance ;
|
||||||
register_field S.manager Contract.get_manager ;
|
register1 S.manager_key
|
||||||
register_field S.manager_key
|
(fun ctxt contract () () ->
|
||||||
(fun ctxt c ->
|
match Contract.is_implicit contract with
|
||||||
Contract.get_manager ctxt c >>=? fun mgr ->
|
| None -> raise Not_found
|
||||||
Contract.is_manager_key_revealed ctxt c >>=? fun revealed ->
|
| Some mgr ->
|
||||||
if revealed then
|
Contract.is_manager_key_revealed ctxt mgr >>=? function
|
||||||
Contract.get_manager_key ctxt c >>=? fun key ->
|
| false -> return_none
|
||||||
return (mgr, Some key)
|
| true -> Contract.get_manager_key ctxt mgr >>=? return_some) ;
|
||||||
else return (mgr, None)) ;
|
|
||||||
register_opt_field S.delegate Delegate.get ;
|
register_opt_field S.delegate Delegate.get ;
|
||||||
register_field S.counter Contract.get_counter ;
|
register1 S.counter
|
||||||
register_field S.spendable Contract.is_spendable ;
|
(fun ctxt contract () () ->
|
||||||
register_field S.delegatable Contract.is_delegatable ;
|
match Contract.is_implicit contract with
|
||||||
|
| None -> raise Not_found
|
||||||
|
| Some mgr -> Contract.get_counter ctxt mgr) ;
|
||||||
register_opt_field S.script
|
register_opt_field S.script
|
||||||
(fun c v -> Contract.get_script c v >>=? fun (_, v) -> return v) ;
|
(fun c v -> Contract.get_script c v >>=? fun (_, v) -> return v) ;
|
||||||
register_opt_field S.storage (fun ctxt contract ->
|
register_opt_field S.storage (fun ctxt contract ->
|
||||||
@ -193,39 +210,95 @@ let register () =
|
|||||||
| Some script ->
|
| Some script ->
|
||||||
let ctxt = Gas.set_unlimited ctxt in
|
let ctxt = Gas.set_unlimited ctxt in
|
||||||
let open Script_ir_translator in
|
let open Script_ir_translator in
|
||||||
parse_script ctxt script >>=? fun (Ex_script script, ctxt) ->
|
parse_script ctxt ~legacy:true script >>=? fun (Ex_script script, ctxt) ->
|
||||||
unparse_script ctxt Readable script >>=? fun (script, ctxt) ->
|
unparse_script ctxt Readable script >>=? fun (script, ctxt) ->
|
||||||
Script.force_decode ctxt script.storage >>=? fun (storage, _ctxt) ->
|
Script.force_decode ctxt script.storage >>=? fun (storage, _ctxt) ->
|
||||||
return_some storage) ;
|
return_some storage) ;
|
||||||
register1 S.big_map_get (fun ctxt contract () (key, key_type) ->
|
register2 S.entrypoint_type
|
||||||
let open Script_ir_translator in
|
(fun ctxt v entrypoint () () -> Contract.get_script_code ctxt v >>=? fun (_, expr) ->
|
||||||
|
match expr with
|
||||||
|
| None -> raise Not_found
|
||||||
|
| Some expr ->
|
||||||
let ctxt = Gas.set_unlimited ctxt in
|
let ctxt = Gas.set_unlimited ctxt in
|
||||||
Lwt.return (parse_ty ctxt ~allow_big_map:false ~allow_operation:false (Micheline.root key_type))
|
let legacy = true in
|
||||||
>>=? fun (Ex_ty key_type, ctxt) ->
|
let open Script_ir_translator in
|
||||||
parse_data ctxt key_type (Micheline.root key) >>=? fun (key, ctxt) ->
|
Script.force_decode ctxt expr >>=? fun (expr, _) ->
|
||||||
hash_data ctxt key_type key >>=? fun (key_hash, ctxt) ->
|
Lwt.return
|
||||||
Contract.Big_map.get_opt ctxt contract key_hash >>=? fun (_ctxt, value) ->
|
begin
|
||||||
return value) ;
|
parse_toplevel ~legacy expr >>? fun (arg_type, _, _, root_name) ->
|
||||||
|
parse_ty ctxt ~legacy
|
||||||
|
~allow_big_map:true ~allow_operation:false
|
||||||
|
~allow_contract:true arg_type >>? fun (Ex_ty arg_type, _) ->
|
||||||
|
Script_ir_translator.find_entrypoint ~root_name arg_type
|
||||||
|
entrypoint
|
||||||
|
end >>= function
|
||||||
|
Ok (_f , Ex_ty ty)->
|
||||||
|
unparse_ty ctxt ty >>=? fun (ty_node, _) ->
|
||||||
|
return (Micheline.strip_locations ty_node)
|
||||||
|
| Error _ -> raise Not_found) ;
|
||||||
|
register1 S.list_entrypoints
|
||||||
|
(fun ctxt v () () -> Contract.get_script_code ctxt v >>=? fun (_, expr) ->
|
||||||
|
match expr with
|
||||||
|
| None -> raise Not_found
|
||||||
|
| Some expr ->
|
||||||
|
let ctxt = Gas.set_unlimited ctxt in
|
||||||
|
let legacy = true in
|
||||||
|
let open Script_ir_translator in
|
||||||
|
Script.force_decode ctxt expr >>=? fun (expr, _) ->
|
||||||
|
Lwt.return
|
||||||
|
begin
|
||||||
|
parse_toplevel ~legacy expr >>? fun (arg_type, _, _, root_name) ->
|
||||||
|
parse_ty ctxt ~legacy
|
||||||
|
~allow_big_map:true ~allow_operation:false
|
||||||
|
~allow_contract:true arg_type >>? fun (Ex_ty arg_type, _) ->
|
||||||
|
Script_ir_translator.list_entrypoints ~root_name arg_type ctxt
|
||||||
|
end >>=? fun (unreachable_entrypoint,map) ->
|
||||||
|
return
|
||||||
|
(unreachable_entrypoint,
|
||||||
|
Entrypoints_map.fold
|
||||||
|
begin fun entry (_,ty) acc ->
|
||||||
|
(entry , Micheline.strip_locations ty) ::acc end
|
||||||
|
map [])
|
||||||
|
) ;
|
||||||
|
register1 S.contract_big_map_get_opt (fun ctxt contract () (key, key_type) ->
|
||||||
|
Contract.get_script ctxt contract >>=? fun (ctxt, script) ->
|
||||||
|
Lwt.return (Script_ir_translator.parse_packable_ty ctxt ~legacy:true (Micheline.root key_type)) >>=? fun (Ex_ty key_type, ctxt) ->
|
||||||
|
Script_ir_translator.parse_data ctxt ~legacy:true key_type (Micheline.root key) >>=? fun (key, ctxt) ->
|
||||||
|
Script_ir_translator.hash_data ctxt key_type key >>=? fun (key, ctxt) ->
|
||||||
|
match script with
|
||||||
|
| None -> raise Not_found
|
||||||
|
| Some script ->
|
||||||
|
let ctxt = Gas.set_unlimited ctxt in
|
||||||
|
let open Script_ir_translator in
|
||||||
|
parse_script ctxt ~legacy:true script >>=? fun (Ex_script script, ctxt) ->
|
||||||
|
Script_ir_translator.collect_big_maps ctxt script.storage_type script.storage >>=? fun (ids, _ctxt) ->
|
||||||
|
let ids = Script_ir_translator.list_of_big_map_ids ids in
|
||||||
|
let rec find = function
|
||||||
|
| [] -> return_none
|
||||||
|
| (id : Z.t) :: ids -> try do_big_map_get ctxt id key >>=? return_some with Not_found -> find ids in
|
||||||
|
find ids) ;
|
||||||
|
register2 S.big_map_get (fun ctxt id key () () ->
|
||||||
|
do_big_map_get ctxt id key) ;
|
||||||
register_field S.info (fun ctxt contract ->
|
register_field S.info (fun ctxt contract ->
|
||||||
Contract.get_balance ctxt contract >>=? fun balance ->
|
Contract.get_balance ctxt contract >>=? fun balance ->
|
||||||
Contract.get_manager ctxt contract >>=? fun manager ->
|
|
||||||
Delegate.get ctxt contract >>=? fun delegate ->
|
Delegate.get ctxt contract >>=? fun delegate ->
|
||||||
Contract.get_counter ctxt contract >>=? fun counter ->
|
begin match Contract.is_implicit contract with
|
||||||
Contract.is_delegatable ctxt contract >>=? fun delegatable ->
|
| Some manager ->
|
||||||
Contract.is_spendable ctxt contract >>=? fun spendable ->
|
Contract.get_counter ctxt manager >>=? fun counter ->
|
||||||
|
return_some counter
|
||||||
|
| None -> return None
|
||||||
|
end >>=? fun counter ->
|
||||||
Contract.get_script ctxt contract >>=? fun (ctxt, script) ->
|
Contract.get_script ctxt contract >>=? fun (ctxt, script) ->
|
||||||
begin match script with
|
begin match script with
|
||||||
| None -> return (None, ctxt)
|
| None -> return (None, ctxt)
|
||||||
| Some script ->
|
| Some script ->
|
||||||
let ctxt = Gas.set_unlimited ctxt in
|
let ctxt = Gas.set_unlimited ctxt in
|
||||||
let open Script_ir_translator in
|
let open Script_ir_translator in
|
||||||
parse_script ctxt script >>=? fun (Ex_script script, ctxt) ->
|
parse_script ctxt ~legacy:true script >>=? fun (Ex_script script, ctxt) ->
|
||||||
unparse_script ctxt Readable script >>=? fun (script, ctxt) ->
|
unparse_script ctxt Readable script >>=? fun (script, ctxt) ->
|
||||||
return (Some script, ctxt)
|
return (Some script, ctxt)
|
||||||
end >>=? fun (script, _ctxt) ->
|
end >>=? fun (script, _ctxt) ->
|
||||||
return { manager ; balance ;
|
return { balance ; delegate ; script ; counter })
|
||||||
spendable ; delegate = (delegatable, delegate) ;
|
|
||||||
script ; counter })
|
|
||||||
|
|
||||||
let list ctxt block =
|
let list ctxt block =
|
||||||
RPC_context.make_call0 S.list ctxt block () ()
|
RPC_context.make_call0 S.list ctxt block () ()
|
||||||
@ -236,11 +309,8 @@ let info ctxt block contract =
|
|||||||
let balance ctxt block contract =
|
let balance ctxt block contract =
|
||||||
RPC_context.make_call1 S.balance ctxt block contract () ()
|
RPC_context.make_call1 S.balance ctxt block contract () ()
|
||||||
|
|
||||||
let manager ctxt block contract =
|
let manager_key ctxt block mgr =
|
||||||
RPC_context.make_call1 S.manager ctxt block contract () ()
|
RPC_context.make_call1 S.manager_key ctxt block (Contract.implicit_contract mgr) () ()
|
||||||
|
|
||||||
let manager_key ctxt block contract =
|
|
||||||
RPC_context.make_call1 S.manager_key ctxt block contract () ()
|
|
||||||
|
|
||||||
let delegate ctxt block contract =
|
let delegate ctxt block contract =
|
||||||
RPC_context.make_call1 S.delegate ctxt block contract () ()
|
RPC_context.make_call1 S.delegate ctxt block contract () ()
|
||||||
@ -248,14 +318,8 @@ let delegate ctxt block contract =
|
|||||||
let delegate_opt ctxt block contract =
|
let delegate_opt ctxt block contract =
|
||||||
RPC_context.make_opt_call1 S.delegate ctxt block contract () ()
|
RPC_context.make_opt_call1 S.delegate ctxt block contract () ()
|
||||||
|
|
||||||
let counter ctxt block contract =
|
let counter ctxt block mgr =
|
||||||
RPC_context.make_call1 S.counter ctxt block contract () ()
|
RPC_context.make_call1 S.counter ctxt block (Contract.implicit_contract mgr) () ()
|
||||||
|
|
||||||
let is_delegatable ctxt block contract =
|
|
||||||
RPC_context.make_call1 S.delegatable ctxt block contract () ()
|
|
||||||
|
|
||||||
let is_spendable ctxt block contract =
|
|
||||||
RPC_context.make_call1 S.spendable ctxt block contract () ()
|
|
||||||
|
|
||||||
let script ctxt block contract =
|
let script ctxt block contract =
|
||||||
RPC_context.make_call1 S.script ctxt block contract () ()
|
RPC_context.make_call1 S.script ctxt block contract () ()
|
||||||
@ -266,8 +330,17 @@ let script_opt ctxt block contract =
|
|||||||
let storage ctxt block contract =
|
let storage ctxt block contract =
|
||||||
RPC_context.make_call1 S.storage ctxt block contract () ()
|
RPC_context.make_call1 S.storage ctxt block contract () ()
|
||||||
|
|
||||||
|
let entrypoint_type ctxt block contract entrypoint =
|
||||||
|
RPC_context.make_call2 S.entrypoint_type ctxt block contract entrypoint () ()
|
||||||
|
|
||||||
|
let list_entrypoints ctxt block contract =
|
||||||
|
RPC_context.make_call1 S.list_entrypoints ctxt block contract () ()
|
||||||
|
|
||||||
let storage_opt ctxt block contract =
|
let storage_opt ctxt block contract =
|
||||||
RPC_context.make_opt_call1 S.storage ctxt block contract () ()
|
RPC_context.make_opt_call1 S.storage ctxt block contract () ()
|
||||||
|
|
||||||
let big_map_get_opt ctxt block contract key =
|
let big_map_get ctxt block id key =
|
||||||
RPC_context.make_call1 S.big_map_get ctxt block contract () key
|
RPC_context.make_call2 S.big_map_get ctxt block id key () ()
|
||||||
|
|
||||||
|
let contract_big_map_get_opt ctxt block contract key =
|
||||||
|
RPC_context.make_call1 S.contract_big_map_get_opt ctxt block contract () key
|
||||||
|
@ -29,11 +29,9 @@ val list:
|
|||||||
'a #RPC_context.simple -> 'a -> Contract.t list shell_tzresult Lwt.t
|
'a #RPC_context.simple -> 'a -> Contract.t list shell_tzresult Lwt.t
|
||||||
|
|
||||||
type info = {
|
type info = {
|
||||||
manager: public_key_hash ;
|
|
||||||
balance: Tez.t ;
|
balance: Tez.t ;
|
||||||
spendable: bool ;
|
delegate: public_key_hash option ;
|
||||||
delegate: bool * public_key_hash option ;
|
counter: counter option ;
|
||||||
counter: counter ;
|
|
||||||
script: Script.t option ;
|
script: Script.t option ;
|
||||||
}
|
}
|
||||||
|
|
||||||
@ -45,11 +43,8 @@ val info:
|
|||||||
val balance:
|
val balance:
|
||||||
'a #RPC_context.simple -> 'a -> Contract.t -> Tez.t shell_tzresult Lwt.t
|
'a #RPC_context.simple -> 'a -> Contract.t -> Tez.t shell_tzresult Lwt.t
|
||||||
|
|
||||||
val manager:
|
|
||||||
'a #RPC_context.simple -> 'a -> Contract.t -> public_key_hash shell_tzresult Lwt.t
|
|
||||||
|
|
||||||
val manager_key:
|
val manager_key:
|
||||||
'a #RPC_context.simple -> 'a -> Contract.t -> (public_key_hash * public_key option) shell_tzresult Lwt.t
|
'a #RPC_context.simple -> 'a -> public_key_hash -> public_key option shell_tzresult Lwt.t
|
||||||
|
|
||||||
val delegate:
|
val delegate:
|
||||||
'a #RPC_context.simple -> 'a -> Contract.t -> public_key_hash shell_tzresult Lwt.t
|
'a #RPC_context.simple -> 'a -> Contract.t -> public_key_hash shell_tzresult Lwt.t
|
||||||
@ -57,14 +52,8 @@ val delegate:
|
|||||||
val delegate_opt:
|
val delegate_opt:
|
||||||
'a #RPC_context.simple -> 'a -> Contract.t -> public_key_hash option shell_tzresult Lwt.t
|
'a #RPC_context.simple -> 'a -> Contract.t -> public_key_hash option shell_tzresult Lwt.t
|
||||||
|
|
||||||
val is_delegatable:
|
|
||||||
'a #RPC_context.simple -> 'a -> Contract.t -> bool shell_tzresult Lwt.t
|
|
||||||
|
|
||||||
val is_spendable:
|
|
||||||
'a #RPC_context.simple -> 'a -> Contract.t -> bool shell_tzresult Lwt.t
|
|
||||||
|
|
||||||
val counter:
|
val counter:
|
||||||
'a #RPC_context.simple -> 'a -> Contract.t -> counter shell_tzresult Lwt.t
|
'a #RPC_context.simple -> 'a -> public_key_hash -> counter shell_tzresult Lwt.t
|
||||||
|
|
||||||
val script:
|
val script:
|
||||||
'a #RPC_context.simple -> 'a -> Contract.t -> Script.t shell_tzresult Lwt.t
|
'a #RPC_context.simple -> 'a -> Contract.t -> Script.t shell_tzresult Lwt.t
|
||||||
@ -75,12 +64,22 @@ val script_opt:
|
|||||||
val storage:
|
val storage:
|
||||||
'a #RPC_context.simple -> 'a -> Contract.t -> Script.expr shell_tzresult Lwt.t
|
'a #RPC_context.simple -> 'a -> Contract.t -> Script.expr shell_tzresult Lwt.t
|
||||||
|
|
||||||
|
val entrypoint_type:
|
||||||
|
'a #RPC_context.simple -> 'a -> Contract.t -> string -> Script.expr shell_tzresult Lwt.t
|
||||||
|
|
||||||
|
val list_entrypoints:
|
||||||
|
'a #RPC_context.simple -> 'a -> Contract.t ->
|
||||||
|
(Michelson_v1_primitives.prim list list *
|
||||||
|
(string * Script.expr) list) shell_tzresult Lwt.t
|
||||||
|
|
||||||
val storage_opt:
|
val storage_opt:
|
||||||
'a #RPC_context.simple -> 'a -> Contract.t -> Script.expr option shell_tzresult Lwt.t
|
'a #RPC_context.simple -> 'a -> Contract.t -> Script.expr option shell_tzresult Lwt.t
|
||||||
|
|
||||||
val big_map_get_opt:
|
val big_map_get:
|
||||||
'a #RPC_context.simple -> 'a -> Contract.t -> Script.expr * Script.expr ->
|
'a #RPC_context.simple -> 'a -> Z.t -> Script_expr_hash.t ->
|
||||||
Script.expr option shell_tzresult Lwt.t
|
Script.expr shell_tzresult Lwt.t
|
||||||
|
|
||||||
|
val contract_big_map_get_opt:
|
||||||
|
'a #RPC_context.simple -> 'a -> Contract.t -> Script.expr * Script.expr -> Script.expr option shell_tzresult Lwt.t
|
||||||
|
|
||||||
val register: unit -> unit
|
val register: unit -> unit
|
||||||
|
@ -202,66 +202,164 @@ let () =
|
|||||||
|
|
||||||
let failwith msg = fail (Failure msg)
|
let failwith msg = fail (Failure msg)
|
||||||
|
|
||||||
type big_map_diff_item = {
|
type big_map_diff_item =
|
||||||
|
| Update of {
|
||||||
|
big_map : Z.t;
|
||||||
diff_key : Script_repr.expr;
|
diff_key : Script_repr.expr;
|
||||||
diff_key_hash : Script_expr_hash.t;
|
diff_key_hash : Script_expr_hash.t;
|
||||||
diff_value : Script_repr.expr option;
|
diff_value : Script_repr.expr option;
|
||||||
}
|
}
|
||||||
|
| Clear of Z.t
|
||||||
|
| Copy of Z.t * Z.t
|
||||||
|
| Alloc of {
|
||||||
|
big_map : Z.t;
|
||||||
|
key_type : Script_repr.expr;
|
||||||
|
value_type : Script_repr.expr;
|
||||||
|
}
|
||||||
|
|
||||||
type big_map_diff = big_map_diff_item list
|
type big_map_diff = big_map_diff_item list
|
||||||
|
|
||||||
let big_map_diff_item_encoding =
|
let big_map_diff_item_encoding =
|
||||||
let open Data_encoding in
|
let open Data_encoding in
|
||||||
conv
|
union
|
||||||
(fun { diff_key_hash ; diff_key ; diff_value } -> (diff_key_hash, diff_key, diff_value))
|
[ case (Tag 0) ~title:"update"
|
||||||
(fun (diff_key_hash, diff_key, diff_value) -> { diff_key_hash ; diff_key ; diff_value })
|
(obj5
|
||||||
(obj3
|
(req "action" (constant "update"))
|
||||||
|
(req "big_map" z)
|
||||||
(req "key_hash" Script_expr_hash.encoding)
|
(req "key_hash" Script_expr_hash.encoding)
|
||||||
(req "key" Script_repr.expr_encoding)
|
(req "key" Script_repr.expr_encoding)
|
||||||
(opt "value" Script_repr.expr_encoding))
|
(opt "value" Script_repr.expr_encoding))
|
||||||
|
(function
|
||||||
|
| Update { big_map ; diff_key_hash ; diff_key ; diff_value } ->
|
||||||
|
Some ((), big_map, diff_key_hash, diff_key, diff_value)
|
||||||
|
| _ -> None )
|
||||||
|
(fun ((), big_map, diff_key_hash, diff_key, diff_value) ->
|
||||||
|
Update { big_map ; diff_key_hash ; diff_key ; diff_value }) ;
|
||||||
|
case (Tag 1) ~title:"remove"
|
||||||
|
(obj2
|
||||||
|
(req "action" (constant "remove"))
|
||||||
|
(req "big_map" z))
|
||||||
|
(function
|
||||||
|
| Clear big_map ->
|
||||||
|
Some ((), big_map)
|
||||||
|
| _ -> None )
|
||||||
|
(fun ((), big_map) ->
|
||||||
|
Clear big_map) ;
|
||||||
|
case (Tag 2) ~title:"copy"
|
||||||
|
(obj3
|
||||||
|
(req "action" (constant "copy"))
|
||||||
|
(req "source_big_map" z)
|
||||||
|
(req "destination_big_map" z))
|
||||||
|
(function
|
||||||
|
| Copy (src, dst) ->
|
||||||
|
Some ((), src, dst)
|
||||||
|
| _ -> None )
|
||||||
|
(fun ((), src, dst) ->
|
||||||
|
Copy (src, dst)) ;
|
||||||
|
case (Tag 3) ~title:"alloc"
|
||||||
|
(obj4
|
||||||
|
(req "action" (constant "alloc"))
|
||||||
|
(req "big_map" z)
|
||||||
|
(req "key_type" Script_repr.expr_encoding)
|
||||||
|
(req "value_type" Script_repr.expr_encoding))
|
||||||
|
(function
|
||||||
|
| Alloc { big_map ; key_type ; value_type } ->
|
||||||
|
Some ((), big_map, key_type, value_type)
|
||||||
|
| _ -> None )
|
||||||
|
(fun ((), big_map, key_type, value_type) ->
|
||||||
|
Alloc { big_map ; key_type ; value_type }) ]
|
||||||
|
|
||||||
let big_map_diff_encoding =
|
let big_map_diff_encoding =
|
||||||
let open Data_encoding in
|
let open Data_encoding in
|
||||||
def "contract.big_map_diff" @@
|
def "contract.big_map_diff" @@
|
||||||
list big_map_diff_item_encoding
|
list big_map_diff_item_encoding
|
||||||
|
|
||||||
let update_script_big_map c contract = function
|
let big_map_key_cost = 65
|
||||||
|
let big_map_cost = 33
|
||||||
|
|
||||||
|
let update_script_big_map c = function
|
||||||
| None -> return (c, Z.zero)
|
| None -> return (c, Z.zero)
|
||||||
| Some diff ->
|
| Some diff ->
|
||||||
fold_left_s (fun (c, total) diff_item ->
|
fold_left_s (fun (c, total) -> function
|
||||||
match diff_item.diff_value with
|
| Clear id ->
|
||||||
| None ->
|
Storage.Big_map.Total_bytes.get c id >>=? fun size ->
|
||||||
Storage.Contract.Big_map.remove (c, contract) diff_item.diff_key_hash
|
Storage.Big_map.remove_rec c id >>= fun c ->
|
||||||
>>=? fun (c, freed) ->
|
if Compare.Z.(id < Z.zero) then
|
||||||
|
return (c, total)
|
||||||
|
else
|
||||||
|
return (c, Z.sub (Z.sub total size) (Z.of_int big_map_cost))
|
||||||
|
| Copy (from, to_) ->
|
||||||
|
Storage.Big_map.copy c ~from ~to_ >>=? fun c ->
|
||||||
|
if Compare.Z.(to_ < Z.zero) then
|
||||||
|
return (c, total)
|
||||||
|
else
|
||||||
|
Storage.Big_map.Total_bytes.get c from >>=? fun size ->
|
||||||
|
return (c, Z.add (Z.add total size) (Z.of_int big_map_cost))
|
||||||
|
| Alloc { big_map ; key_type ; value_type } ->
|
||||||
|
Storage.Big_map.Total_bytes.init c big_map Z.zero >>=? fun c ->
|
||||||
|
(* Annotations are erased to allow sharing on
|
||||||
|
[Copy]. The types from the contract code are used,
|
||||||
|
these ones are only used to make sure they are
|
||||||
|
compatible during transmissions between contracts,
|
||||||
|
and only need to be compatible, annotations
|
||||||
|
nonwhistanding. *)
|
||||||
|
let key_type = Micheline.strip_locations (Script_repr.strip_annotations (Micheline.root key_type)) in
|
||||||
|
let value_type = Micheline.strip_locations (Script_repr.strip_annotations (Micheline.root value_type)) in
|
||||||
|
Storage.Big_map.Key_type.init c big_map key_type >>=? fun c ->
|
||||||
|
Storage.Big_map.Value_type.init c big_map value_type >>=? fun c ->
|
||||||
|
if Compare.Z.(big_map < Z.zero) then
|
||||||
|
return (c, total)
|
||||||
|
else
|
||||||
|
return (c, Z.add total (Z.of_int big_map_cost))
|
||||||
|
| Update { big_map ; diff_key_hash ; diff_value = None } ->
|
||||||
|
Storage.Big_map.Contents.remove (c, big_map) diff_key_hash
|
||||||
|
>>=? fun (c, freed, existed) ->
|
||||||
|
let freed = if existed then freed + big_map_key_cost else freed in
|
||||||
|
Storage.Big_map.Total_bytes.get c big_map >>=? fun size ->
|
||||||
|
Storage.Big_map.Total_bytes.set c big_map (Z.sub size (Z.of_int freed)) >>=? fun c ->
|
||||||
|
if Compare.Z.(big_map < Z.zero) then
|
||||||
|
return (c, total)
|
||||||
|
else
|
||||||
return (c, Z.sub total (Z.of_int freed))
|
return (c, Z.sub total (Z.of_int freed))
|
||||||
| Some v ->
|
| Update { big_map ; diff_key_hash ; diff_value = Some v } ->
|
||||||
Storage.Contract.Big_map.init_set (c, contract) diff_item.diff_key_hash v
|
Storage.Big_map.Contents.init_set (c, big_map) diff_key_hash v
|
||||||
>>=? fun (c, size_diff) ->
|
>>=? fun (c, size_diff, existed) ->
|
||||||
|
let size_diff = if existed then size_diff else size_diff + big_map_key_cost in
|
||||||
|
Storage.Big_map.Total_bytes.get c big_map >>=? fun size ->
|
||||||
|
Storage.Big_map.Total_bytes.set c big_map (Z.add size (Z.of_int size_diff)) >>=? fun c ->
|
||||||
|
if Compare.Z.(big_map < Z.zero) then
|
||||||
|
return (c, total)
|
||||||
|
else
|
||||||
return (c, Z.add total (Z.of_int size_diff)))
|
return (c, Z.add total (Z.of_int size_diff)))
|
||||||
(c, Z.zero) diff
|
(c, Z.zero) diff
|
||||||
|
|
||||||
let create_base c
|
let create_base c
|
||||||
?(prepaid_bootstrap_storage=false) (* Free space for bootstrap contracts *)
|
?(prepaid_bootstrap_storage=false) (* Free space for bootstrap contracts *)
|
||||||
contract
|
contract
|
||||||
~balance ~manager ~delegate ?script ~spendable ~delegatable =
|
~balance ~manager ~delegate ?script () =
|
||||||
(match Contract_repr.is_implicit contract with
|
begin match Contract_repr.is_implicit contract with
|
||||||
| None -> return Z.zero
|
| None -> return c
|
||||||
| Some _ -> Storage.Contract.Global_counter.get c) >>=? fun counter ->
|
| Some _ ->
|
||||||
|
Storage.Contract.Global_counter.get c >>=? fun counter ->
|
||||||
|
Storage.Contract.Counter.init c contract counter
|
||||||
|
end >>=? fun c ->
|
||||||
Storage.Contract.Balance.init c contract balance >>=? fun c ->
|
Storage.Contract.Balance.init c contract balance >>=? fun c ->
|
||||||
Storage.Contract.Manager.init c contract (Manager_repr.Hash manager) >>=? fun c ->
|
begin match manager with
|
||||||
|
| Some manager ->
|
||||||
|
Storage.Contract.Manager.init c contract (Manager_repr.Hash manager)
|
||||||
|
| None -> return c
|
||||||
|
end >>=? fun c ->
|
||||||
begin
|
begin
|
||||||
match delegate with
|
match delegate with
|
||||||
| None -> return c
|
| None -> return c
|
||||||
| Some delegate ->
|
| Some delegate ->
|
||||||
Delegate_storage.init c contract delegate
|
Delegate_storage.init c contract delegate
|
||||||
end >>=? fun c ->
|
end >>=? fun c ->
|
||||||
Storage.Contract.Spendable.set c contract spendable >>= fun c ->
|
match script with
|
||||||
Storage.Contract.Delegatable.set c contract delegatable >>= fun c ->
|
|
||||||
Storage.Contract.Counter.init c contract counter >>=? fun c ->
|
|
||||||
(match script with
|
|
||||||
| Some ({ Script_repr.code ; storage }, big_map_diff) ->
|
| Some ({ Script_repr.code ; storage }, big_map_diff) ->
|
||||||
Storage.Contract.Code.init c contract code >>=? fun (c, code_size) ->
|
Storage.Contract.Code.init c contract code >>=? fun (c, code_size) ->
|
||||||
Storage.Contract.Storage.init c contract storage >>=? fun (c, storage_size) ->
|
Storage.Contract.Storage.init c contract storage >>=? fun (c, storage_size) ->
|
||||||
update_script_big_map c contract big_map_diff >>=? fun (c, big_map_size) ->
|
update_script_big_map c big_map_diff >>=? fun (c, big_map_size) ->
|
||||||
let total_size = Z.add (Z.add (Z.of_int code_size) (Z.of_int storage_size)) big_map_size in
|
let total_size = Z.add (Z.add (Z.of_int code_size) (Z.of_int storage_size)) big_map_size in
|
||||||
assert Compare.Z.(total_size >= Z.zero) ;
|
assert Compare.Z.(total_size >= Z.zero) ;
|
||||||
let prepaid_bootstrap_storage =
|
let prepaid_bootstrap_storage =
|
||||||
@ -272,26 +370,17 @@ let create_base c
|
|||||||
in
|
in
|
||||||
Storage.Contract.Paid_storage_space.init c contract prepaid_bootstrap_storage >>=? fun c ->
|
Storage.Contract.Paid_storage_space.init c contract prepaid_bootstrap_storage >>=? fun c ->
|
||||||
Storage.Contract.Used_storage_space.init c contract total_size
|
Storage.Contract.Used_storage_space.init c contract total_size
|
||||||
| None -> begin
|
|
||||||
match Contract_repr.is_implicit contract with
|
|
||||||
| None ->
|
| None ->
|
||||||
Storage.Contract.Paid_storage_space.init c contract Z.zero >>=? fun c ->
|
|
||||||
Storage.Contract.Used_storage_space.init c contract Z.zero
|
|
||||||
| Some _ ->
|
|
||||||
return c
|
|
||||||
end >>=? fun c ->
|
|
||||||
return c) >>=? fun c ->
|
|
||||||
return c
|
return c
|
||||||
|
|
||||||
let originate c ?prepaid_bootstrap_storage contract
|
let originate c ?prepaid_bootstrap_storage contract
|
||||||
~balance ~manager ?script ~delegate ~spendable ~delegatable =
|
~balance ~script ~delegate =
|
||||||
create_base c ?prepaid_bootstrap_storage contract ~balance ~manager
|
create_base c ?prepaid_bootstrap_storage contract ~balance
|
||||||
~delegate ?script ~spendable ~delegatable
|
~manager:None ~delegate ~script ()
|
||||||
|
|
||||||
let create_implicit c manager ~balance =
|
let create_implicit c manager ~balance =
|
||||||
create_base c (Contract_repr.implicit_contract manager)
|
create_base c (Contract_repr.implicit_contract manager)
|
||||||
~balance ~manager ?script:None ~delegate:None
|
~balance ~manager:(Some manager) ?script:None ~delegate:None ()
|
||||||
~spendable:true ~delegatable:false
|
|
||||||
|
|
||||||
let delete c contract =
|
let delete c contract =
|
||||||
match Contract_repr.is_implicit contract with
|
match Contract_repr.is_implicit contract with
|
||||||
@ -302,17 +391,15 @@ let delete c contract =
|
|||||||
Delegate_storage.remove c contract >>=? fun c ->
|
Delegate_storage.remove c contract >>=? fun c ->
|
||||||
Storage.Contract.Balance.delete c contract >>=? fun c ->
|
Storage.Contract.Balance.delete c contract >>=? fun c ->
|
||||||
Storage.Contract.Manager.delete c contract >>=? fun c ->
|
Storage.Contract.Manager.delete c contract >>=? fun c ->
|
||||||
Storage.Contract.Spendable.del c contract >>= fun c ->
|
|
||||||
Storage.Contract.Delegatable.del c contract >>= fun c ->
|
|
||||||
Storage.Contract.Counter.delete c contract >>=? fun c ->
|
Storage.Contract.Counter.delete c contract >>=? fun c ->
|
||||||
Storage.Contract.Code.remove c contract >>=? fun (c, _) ->
|
Storage.Contract.Code.remove c contract >>=? fun (c, _, _) ->
|
||||||
Storage.Contract.Storage.remove c contract >>=? fun (c, _) ->
|
Storage.Contract.Storage.remove c contract >>=? fun (c, _, _) ->
|
||||||
Storage.Contract.Paid_storage_space.remove c contract >>= fun c ->
|
Storage.Contract.Paid_storage_space.remove c contract >>= fun c ->
|
||||||
Storage.Contract.Used_storage_space.remove c contract >>= fun c ->
|
Storage.Contract.Used_storage_space.remove c contract >>= fun c ->
|
||||||
return c
|
return c
|
||||||
|
|
||||||
let allocated c contract =
|
let allocated c contract =
|
||||||
Storage.Contract.Counter.get_option c contract >>=? function
|
Storage.Contract.Balance.get_option c contract >>=? function
|
||||||
| None -> return_false
|
| None -> return_false
|
||||||
| Some _ -> return_true
|
| Some _ -> return_true
|
||||||
|
|
||||||
@ -349,7 +436,8 @@ let originated_from_current_nonce ~since: ctxt_since ~until: ctxt_until =
|
|||||||
| false -> return_none)
|
| false -> return_none)
|
||||||
(Contract_repr.originated_contracts ~since ~until)
|
(Contract_repr.originated_contracts ~since ~until)
|
||||||
|
|
||||||
let check_counter_increment c contract counter =
|
let check_counter_increment c manager counter =
|
||||||
|
let contract = Contract_repr.implicit_contract manager in
|
||||||
Storage.Contract.Counter.get c contract >>=? fun contract_counter ->
|
Storage.Contract.Counter.get c contract >>=? fun contract_counter ->
|
||||||
let expected = Z.succ contract_counter in
|
let expected = Z.succ contract_counter in
|
||||||
if Compare.Z.(expected = counter)
|
if Compare.Z.(expected = counter)
|
||||||
@ -359,12 +447,16 @@ let check_counter_increment c contract counter =
|
|||||||
else
|
else
|
||||||
fail (Counter_in_the_future (contract, expected, counter))
|
fail (Counter_in_the_future (contract, expected, counter))
|
||||||
|
|
||||||
let increment_counter c contract =
|
let increment_counter c manager =
|
||||||
|
let contract = Contract_repr.implicit_contract manager in
|
||||||
Storage.Contract.Global_counter.get c >>=? fun global_counter ->
|
Storage.Contract.Global_counter.get c >>=? fun global_counter ->
|
||||||
Storage.Contract.Global_counter.set c (Z.succ global_counter) >>=? fun c ->
|
Storage.Contract.Global_counter.set c (Z.succ global_counter) >>=? fun c ->
|
||||||
Storage.Contract.Counter.get c contract >>=? fun contract_counter ->
|
Storage.Contract.Counter.get c contract >>=? fun contract_counter ->
|
||||||
Storage.Contract.Counter.set c contract (Z.succ contract_counter)
|
Storage.Contract.Counter.set c contract (Z.succ contract_counter)
|
||||||
|
|
||||||
|
let get_script_code c contract =
|
||||||
|
Storage.Contract.Code.get_option c contract
|
||||||
|
|
||||||
let get_script c contract =
|
let get_script c contract =
|
||||||
Storage.Contract.Code.get_option c contract >>=? fun (c, code) ->
|
Storage.Contract.Code.get_option c contract >>=? fun (c, code) ->
|
||||||
Storage.Contract.Storage.get_option c contract >>=? fun (c, storage) ->
|
Storage.Contract.Storage.get_option c contract >>=? fun (c, storage) ->
|
||||||
@ -381,7 +473,8 @@ let get_storage ctxt contract =
|
|||||||
Lwt.return (Raw_context.consume_gas ctxt cost) >>=? fun ctxt ->
|
Lwt.return (Raw_context.consume_gas ctxt cost) >>=? fun ctxt ->
|
||||||
return (ctxt, Some storage)
|
return (ctxt, Some storage)
|
||||||
|
|
||||||
let get_counter c contract =
|
let get_counter c manager =
|
||||||
|
let contract = Contract_repr.implicit_contract manager in
|
||||||
Storage.Contract.Counter.get_option c contract >>=? function
|
Storage.Contract.Counter.get_option c contract >>=? function
|
||||||
| None -> begin
|
| None -> begin
|
||||||
match Contract_repr.is_implicit contract with
|
match Contract_repr.is_implicit contract with
|
||||||
@ -390,7 +483,7 @@ let get_counter c contract =
|
|||||||
end
|
end
|
||||||
| Some v -> return v
|
| Some v -> return v
|
||||||
|
|
||||||
let get_manager c contract =
|
let get_manager_004 c contract =
|
||||||
Storage.Contract.Manager.get_option c contract >>=? function
|
Storage.Contract.Manager.get_option c contract >>=? function
|
||||||
| None -> begin
|
| None -> begin
|
||||||
match Contract_repr.is_implicit contract with
|
match Contract_repr.is_implicit contract with
|
||||||
@ -400,19 +493,22 @@ let get_manager c contract =
|
|||||||
| Some (Manager_repr.Hash v) -> return v
|
| Some (Manager_repr.Hash v) -> return v
|
||||||
| Some (Manager_repr.Public_key v) -> return (Signature.Public_key.hash v)
|
| Some (Manager_repr.Public_key v) -> return (Signature.Public_key.hash v)
|
||||||
|
|
||||||
let get_manager_key c contract =
|
let get_manager_key c manager =
|
||||||
|
let contract = Contract_repr.implicit_contract manager in
|
||||||
Storage.Contract.Manager.get_option c contract >>=? function
|
Storage.Contract.Manager.get_option c contract >>=? function
|
||||||
| None -> failwith "get_manager_key"
|
| None -> failwith "get_manager_key"
|
||||||
| Some (Manager_repr.Hash _) -> fail (Unrevealed_manager_key contract)
|
| Some (Manager_repr.Hash _) -> fail (Unrevealed_manager_key contract)
|
||||||
| Some (Manager_repr.Public_key v) -> return v
|
| Some (Manager_repr.Public_key v) -> return v
|
||||||
|
|
||||||
let is_manager_key_revealed c contract =
|
let is_manager_key_revealed c manager =
|
||||||
|
let contract = Contract_repr.implicit_contract manager in
|
||||||
Storage.Contract.Manager.get_option c contract >>=? function
|
Storage.Contract.Manager.get_option c contract >>=? function
|
||||||
| None -> return_false
|
| None -> return_false
|
||||||
| Some (Manager_repr.Hash _) -> return_false
|
| Some (Manager_repr.Hash _) -> return_false
|
||||||
| Some (Manager_repr.Public_key _) -> return_true
|
| Some (Manager_repr.Public_key _) -> return_true
|
||||||
|
|
||||||
let reveal_manager_key c contract public_key =
|
let reveal_manager_key c manager public_key =
|
||||||
|
let contract = Contract_repr.implicit_contract manager in
|
||||||
Storage.Contract.Manager.get c contract >>=? function
|
Storage.Contract.Manager.get c contract >>=? function
|
||||||
| Public_key _ -> fail (Previously_revealed_key contract)
|
| Public_key _ -> fail (Previously_revealed_key contract)
|
||||||
| Hash v ->
|
| Hash v ->
|
||||||
@ -432,22 +528,15 @@ let get_balance c contract =
|
|||||||
end
|
end
|
||||||
| Some v -> return v
|
| Some v -> return v
|
||||||
|
|
||||||
let is_delegatable = Delegate_storage.is_delegatable
|
|
||||||
let is_spendable c contract =
|
|
||||||
match Contract_repr.is_implicit contract with
|
|
||||||
| Some _ -> return_true
|
|
||||||
| None ->
|
|
||||||
Storage.Contract.Spendable.mem c contract >>= return
|
|
||||||
|
|
||||||
let update_script_storage c contract storage big_map_diff =
|
let update_script_storage c contract storage big_map_diff =
|
||||||
let storage = Script_repr.lazy_expr storage in
|
let storage = Script_repr.lazy_expr storage in
|
||||||
update_script_big_map c contract big_map_diff >>=? fun (c, big_map_size_diff) ->
|
update_script_big_map c big_map_diff >>=? fun (c, big_map_size_diff) ->
|
||||||
Storage.Contract.Storage.set c contract storage >>=? fun (c, size_diff) ->
|
Storage.Contract.Storage.set c contract storage >>=? fun (c, size_diff) ->
|
||||||
Storage.Contract.Used_storage_space.get c contract >>=? fun previous_size ->
|
Storage.Contract.Used_storage_space.get c contract >>=? fun previous_size ->
|
||||||
let new_size = Z.add previous_size (Z.add big_map_size_diff (Z.of_int size_diff)) in
|
let new_size = Z.add previous_size (Z.add big_map_size_diff (Z.of_int size_diff)) in
|
||||||
Storage.Contract.Used_storage_space.set c contract new_size
|
Storage.Contract.Used_storage_space.set c contract new_size
|
||||||
|
|
||||||
let spend_from_script c contract amount =
|
let spend c contract amount =
|
||||||
Storage.Contract.Balance.get c contract >>=? fun balance ->
|
Storage.Contract.Balance.get c contract >>=? fun balance ->
|
||||||
match Tez_repr.(balance -? amount) with
|
match Tez_repr.(balance -? amount) with
|
||||||
| Error _ ->
|
| Error _ ->
|
||||||
@ -490,12 +579,6 @@ let credit c contract amount =
|
|||||||
Storage.Contract.Balance.set c contract balance >>=? fun c ->
|
Storage.Contract.Balance.set c contract balance >>=? fun c ->
|
||||||
Roll_storage.Contract.add_amount c contract amount
|
Roll_storage.Contract.add_amount c contract amount
|
||||||
|
|
||||||
let spend c contract amount =
|
|
||||||
is_spendable c contract >>=? fun spendable ->
|
|
||||||
if not spendable
|
|
||||||
then fail (Unspendable_contract contract)
|
|
||||||
else spend_from_script c contract amount
|
|
||||||
|
|
||||||
let init c =
|
let init c =
|
||||||
Storage.Contract.Global_counter.init c Z.zero
|
Storage.Contract.Global_counter.init c Z.zero
|
||||||
|
|
||||||
@ -517,10 +600,3 @@ let set_paid_storage_space_and_return_fees_to_pay c contract new_storage_space =
|
|||||||
let to_pay = Z.sub new_storage_space already_paid_space in
|
let to_pay = Z.sub new_storage_space already_paid_space in
|
||||||
Storage.Contract.Paid_storage_space.set c contract new_storage_space >>=? fun c ->
|
Storage.Contract.Paid_storage_space.set c contract new_storage_space >>=? fun c ->
|
||||||
return (to_pay, c)
|
return (to_pay, c)
|
||||||
|
|
||||||
module Big_map = struct
|
|
||||||
let mem ctxt contract key =
|
|
||||||
Storage.Contract.Big_map.mem (ctxt, contract) key
|
|
||||||
let get_opt ctxt contract key =
|
|
||||||
Storage.Contract.Big_map.get_option (ctxt, contract) key
|
|
||||||
end
|
|
||||||
|
@ -47,42 +47,49 @@ val must_be_allocated: Raw_context.t -> Contract_repr.t -> unit tzresult Lwt.t
|
|||||||
val list: Raw_context.t -> Contract_repr.t list Lwt.t
|
val list: Raw_context.t -> Contract_repr.t list Lwt.t
|
||||||
|
|
||||||
val check_counter_increment:
|
val check_counter_increment:
|
||||||
Raw_context.t -> Contract_repr.t -> Z.t -> unit tzresult Lwt.t
|
Raw_context.t -> Signature.Public_key_hash.t -> Z.t -> unit tzresult Lwt.t
|
||||||
|
|
||||||
val increment_counter:
|
val increment_counter:
|
||||||
Raw_context.t -> Contract_repr.t -> Raw_context.t tzresult Lwt.t
|
Raw_context.t -> Signature.Public_key_hash.t -> Raw_context.t tzresult Lwt.t
|
||||||
|
|
||||||
val is_delegatable:
|
val get_manager_004:
|
||||||
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:
|
|
||||||
Raw_context.t -> Contract_repr.t -> Signature.Public_key_hash.t tzresult Lwt.t
|
Raw_context.t -> Contract_repr.t -> Signature.Public_key_hash.t tzresult Lwt.t
|
||||||
|
|
||||||
val get_manager_key:
|
val get_manager_key:
|
||||||
Raw_context.t -> Contract_repr.t -> Signature.Public_key.t tzresult Lwt.t
|
Raw_context.t -> Signature.Public_key_hash.t -> Signature.Public_key.t tzresult Lwt.t
|
||||||
val is_manager_key_revealed:
|
val is_manager_key_revealed:
|
||||||
Raw_context.t -> Contract_repr.t -> bool tzresult Lwt.t
|
Raw_context.t -> Signature.Public_key_hash.t -> bool tzresult Lwt.t
|
||||||
|
|
||||||
val reveal_manager_key:
|
val reveal_manager_key:
|
||||||
Raw_context.t -> Contract_repr.t -> Signature.Public_key.t ->
|
Raw_context.t -> Signature.Public_key_hash.t -> Signature.Public_key.t ->
|
||||||
Raw_context.t tzresult Lwt.t
|
Raw_context.t tzresult Lwt.t
|
||||||
|
|
||||||
val get_balance: Raw_context.t -> Contract_repr.t -> Tez_repr.t 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 -> Z.t tzresult Lwt.t
|
val get_counter: Raw_context.t -> Signature.Public_key_hash.t -> Z.t tzresult Lwt.t
|
||||||
|
|
||||||
|
val get_script_code:
|
||||||
|
Raw_context.t -> Contract_repr.t -> (Raw_context.t * Script_repr.lazy_expr option) tzresult Lwt.t
|
||||||
val get_script:
|
val get_script:
|
||||||
Raw_context.t -> Contract_repr.t -> (Raw_context.t * Script_repr.t option) tzresult Lwt.t
|
Raw_context.t -> Contract_repr.t -> (Raw_context.t * Script_repr.t option) tzresult Lwt.t
|
||||||
val get_storage:
|
val get_storage:
|
||||||
Raw_context.t -> Contract_repr.t -> (Raw_context.t * Script_repr.expr option) tzresult Lwt.t
|
Raw_context.t -> Contract_repr.t -> (Raw_context.t * Script_repr.expr option) tzresult Lwt.t
|
||||||
|
|
||||||
|
|
||||||
type big_map_diff_item = {
|
type big_map_diff_item =
|
||||||
|
| Update of {
|
||||||
|
big_map : Z.t ;
|
||||||
diff_key : Script_repr.expr;
|
diff_key : Script_repr.expr;
|
||||||
diff_key_hash : Script_expr_hash.t;
|
diff_key_hash : Script_expr_hash.t;
|
||||||
diff_value : Script_repr.expr option;
|
diff_value : Script_repr.expr option;
|
||||||
}
|
}
|
||||||
|
| Clear of Z.t
|
||||||
|
| Copy of Z.t * Z.t
|
||||||
|
| Alloc of {
|
||||||
|
big_map : Z.t;
|
||||||
|
key_type : Script_repr.expr;
|
||||||
|
value_type : Script_repr.expr;
|
||||||
|
}
|
||||||
|
|
||||||
type big_map_diff = big_map_diff_item list
|
type big_map_diff = big_map_diff_item list
|
||||||
|
|
||||||
val big_map_diff_encoding : big_map_diff Data_encoding.t
|
val big_map_diff_encoding : big_map_diff Data_encoding.t
|
||||||
@ -96,26 +103,17 @@ val credit:
|
|||||||
Raw_context.t -> Contract_repr.t -> Tez_repr.t ->
|
Raw_context.t -> Contract_repr.t -> Tez_repr.t ->
|
||||||
Raw_context.t tzresult Lwt.t
|
Raw_context.t tzresult Lwt.t
|
||||||
|
|
||||||
(** checks that the contract is spendable and decrease_balance *)
|
|
||||||
val spend:
|
val spend:
|
||||||
Raw_context.t -> Contract_repr.t -> Tez_repr.t ->
|
Raw_context.t -> Contract_repr.t -> Tez_repr.t ->
|
||||||
Raw_context.t tzresult Lwt.t
|
Raw_context.t tzresult Lwt.t
|
||||||
|
|
||||||
(** decrease_balance even if the contract is not spendable *)
|
|
||||||
val spend_from_script:
|
|
||||||
Raw_context.t -> Contract_repr.t -> Tez_repr.t ->
|
|
||||||
Raw_context.t tzresult Lwt.t
|
|
||||||
|
|
||||||
val originate:
|
val originate:
|
||||||
Raw_context.t ->
|
Raw_context.t ->
|
||||||
?prepaid_bootstrap_storage:bool ->
|
?prepaid_bootstrap_storage:bool ->
|
||||||
Contract_repr.t ->
|
Contract_repr.t ->
|
||||||
balance:Tez_repr.t ->
|
balance:Tez_repr.t ->
|
||||||
manager:Signature.Public_key_hash.t ->
|
script:(Script_repr.t * big_map_diff option) ->
|
||||||
?script:(Script_repr.t * big_map_diff option) ->
|
|
||||||
delegate:Signature.Public_key_hash.t option ->
|
delegate:Signature.Public_key_hash.t option ->
|
||||||
spendable:bool ->
|
|
||||||
delegatable:bool ->
|
|
||||||
Raw_context.t tzresult Lwt.t
|
Raw_context.t tzresult Lwt.t
|
||||||
|
|
||||||
val fresh_contract_from_current_nonce :
|
val fresh_contract_from_current_nonce :
|
||||||
@ -131,10 +129,3 @@ val init:
|
|||||||
val used_storage_space: Raw_context.t -> Contract_repr.t -> Z.t tzresult Lwt.t
|
val used_storage_space: Raw_context.t -> Contract_repr.t -> Z.t tzresult Lwt.t
|
||||||
val paid_storage_space: Raw_context.t -> Contract_repr.t -> Z.t tzresult Lwt.t
|
val paid_storage_space: Raw_context.t -> Contract_repr.t -> Z.t tzresult Lwt.t
|
||||||
val set_paid_storage_space_and_return_fees_to_pay: Raw_context.t -> Contract_repr.t -> Z.t -> (Z.t * Raw_context.t) tzresult Lwt.t
|
val set_paid_storage_space_and_return_fees_to_pay: Raw_context.t -> Contract_repr.t -> Z.t -> (Z.t * Raw_context.t) tzresult Lwt.t
|
||||||
|
|
||||||
module Big_map : sig
|
|
||||||
val mem :
|
|
||||||
Raw_context.t -> Contract_repr.t -> Script_expr_hash.t -> (Raw_context.t * bool) tzresult Lwt.t
|
|
||||||
val get_opt :
|
|
||||||
Raw_context.t -> Contract_repr.t -> Script_expr_hash.t -> (Raw_context.t * Script_repr.expr option) tzresult Lwt.t
|
|
||||||
end
|
|
||||||
|
@ -30,7 +30,7 @@ type info = {
|
|||||||
frozen_balance: Tez.t ;
|
frozen_balance: Tez.t ;
|
||||||
frozen_balance_by_cycle: Delegate.frozen_balance Cycle.Map.t ;
|
frozen_balance_by_cycle: Delegate.frozen_balance Cycle.Map.t ;
|
||||||
staking_balance: Tez.t ;
|
staking_balance: Tez.t ;
|
||||||
delegated_contracts: Contract_hash.t list ;
|
delegated_contracts: Contract_repr.t list ;
|
||||||
delegated_balance: Tez.t ;
|
delegated_balance: Tez.t ;
|
||||||
deactivated: bool ;
|
deactivated: bool ;
|
||||||
grace_period: Cycle.t ;
|
grace_period: Cycle.t ;
|
||||||
@ -56,7 +56,7 @@ let info_encoding =
|
|||||||
(req "frozen_balance" Tez.encoding)
|
(req "frozen_balance" Tez.encoding)
|
||||||
(req "frozen_balance_by_cycle" Delegate.frozen_balance_by_cycle_encoding)
|
(req "frozen_balance_by_cycle" Delegate.frozen_balance_by_cycle_encoding)
|
||||||
(req "staking_balance" Tez.encoding)
|
(req "staking_balance" Tez.encoding)
|
||||||
(req "delegated_contracts" (list Contract_hash.encoding))
|
(req "delegated_contracts" (list Contract_repr.encoding))
|
||||||
(req "delegated_balance" Tez.encoding)
|
(req "delegated_balance" Tez.encoding)
|
||||||
(req "deactivated" bool)
|
(req "deactivated" bool)
|
||||||
(req "grace_period" Cycle.encoding))
|
(req "grace_period" Cycle.encoding))
|
||||||
@ -140,7 +140,7 @@ module S = struct
|
|||||||
~description:
|
~description:
|
||||||
"Returns the list of contracts that delegate to a given delegate."
|
"Returns the list of contracts that delegate to a given delegate."
|
||||||
~query: RPC_query.empty
|
~query: RPC_query.empty
|
||||||
~output: (list Contract_hash.encoding)
|
~output: (list Contract_repr.encoding)
|
||||||
RPC_path.(path / "delegated_contracts")
|
RPC_path.(path / "delegated_contracts")
|
||||||
|
|
||||||
let delegated_balance =
|
let delegated_balance =
|
||||||
@ -281,7 +281,7 @@ let requested_levels ~default ctxt cycles levels =
|
|||||||
Level.compare
|
Level.compare
|
||||||
(List.concat (List.map (Level.from_raw ctxt) levels ::
|
(List.concat (List.map (Level.from_raw ctxt) levels ::
|
||||||
List.map (Level.levels_in_cycle ctxt) cycles)) in
|
List.map (Level.levels_in_cycle ctxt) cycles)) in
|
||||||
map_p
|
map_s
|
||||||
(fun level ->
|
(fun level ->
|
||||||
let current_level = Level.current ctxt in
|
let current_level = Level.current ctxt in
|
||||||
if Level.(level <= current_level) then
|
if Level.(level <= current_level) then
|
||||||
@ -410,7 +410,7 @@ module Baking_rights = struct
|
|||||||
match q.max_priority with
|
match q.max_priority with
|
||||||
| None -> 64
|
| None -> 64
|
||||||
| Some max -> max in
|
| Some max -> max in
|
||||||
map_p (baking_priorities ctxt max_priority) levels >>=? fun rights ->
|
map_s (baking_priorities ctxt max_priority) levels >>=? fun rights ->
|
||||||
let rights =
|
let rights =
|
||||||
if q.all then
|
if q.all then
|
||||||
rights
|
rights
|
||||||
@ -516,7 +516,7 @@ module Endorsing_rights = struct
|
|||||||
requested_levels
|
requested_levels
|
||||||
~default: (Level.current ctxt, Some (Timestamp.current ctxt))
|
~default: (Level.current ctxt, Some (Timestamp.current ctxt))
|
||||||
ctxt q.cycles q.levels >>=? fun levels ->
|
ctxt q.cycles q.levels >>=? fun levels ->
|
||||||
map_p (endorsement_slots ctxt) levels >>=? fun rights ->
|
map_s (endorsement_slots ctxt) levels >>=? fun rights ->
|
||||||
let rights = List.concat rights in
|
let rights = List.concat rights in
|
||||||
match q.delegates with
|
match q.delegates with
|
||||||
| [] -> return rights
|
| [] -> return rights
|
||||||
@ -534,10 +534,128 @@ module Endorsing_rights = struct
|
|||||||
|
|
||||||
end
|
end
|
||||||
|
|
||||||
|
module Endorsing_power = struct
|
||||||
|
|
||||||
|
let endorsing_power ctxt (operation, chain_id) =
|
||||||
|
let Operation_data data = operation.protocol_data in
|
||||||
|
match data.contents with
|
||||||
|
| Single Endorsement _ ->
|
||||||
|
Baking.check_endorsement_rights ctxt chain_id {
|
||||||
|
shell = operation.shell ;
|
||||||
|
protocol_data = data ;
|
||||||
|
} >>=? fun (_, slots, _) ->
|
||||||
|
return (List.length slots)
|
||||||
|
| _ ->
|
||||||
|
failwith "Operation is not an endorsement"
|
||||||
|
|
||||||
|
module S = struct
|
||||||
|
let endorsing_power =
|
||||||
|
let open Data_encoding in
|
||||||
|
RPC_service.post_service
|
||||||
|
~description:"Get the endorsing power of an endorsement, that is, \
|
||||||
|
the number of slots that the endorser has"
|
||||||
|
~query: RPC_query.empty
|
||||||
|
~input: (obj2
|
||||||
|
(req "endorsement_operation" Operation.encoding)
|
||||||
|
(req "chain_id" Chain_id.encoding))
|
||||||
|
~output: int31
|
||||||
|
RPC_path.(open_root / "endorsing_power")
|
||||||
|
end
|
||||||
|
|
||||||
|
let register () =
|
||||||
|
let open Services_registration in
|
||||||
|
register0 S.endorsing_power begin fun ctxt () (op, chain_id) ->
|
||||||
|
endorsing_power ctxt (op, chain_id)
|
||||||
|
end
|
||||||
|
|
||||||
|
let get ctxt block op chain_id =
|
||||||
|
RPC_context.make_call0 S.endorsing_power ctxt block () (op, chain_id)
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
module Required_endorsements = struct
|
||||||
|
|
||||||
|
let required_endorsements ctxt block_delay =
|
||||||
|
return (Baking.minimum_allowed_endorsements ctxt ~block_delay)
|
||||||
|
|
||||||
|
module S = struct
|
||||||
|
|
||||||
|
type t = { block_delay : Period.t }
|
||||||
|
|
||||||
|
let required_endorsements_query =
|
||||||
|
let open RPC_query in
|
||||||
|
query (fun block_delay -> { block_delay })
|
||||||
|
|+ field "block_delay" Period.rpc_arg Period.zero (fun t -> t.block_delay)
|
||||||
|
|> seal
|
||||||
|
|
||||||
|
let required_endorsements =
|
||||||
|
let open Data_encoding in
|
||||||
|
RPC_service.get_service
|
||||||
|
~description:"Minimum number of endorsements for a block to be \
|
||||||
|
valid, given a delay of the block's timestamp with \
|
||||||
|
respect to the minimum time to bake at the \
|
||||||
|
block's priority"
|
||||||
|
~query: required_endorsements_query
|
||||||
|
~output: int31
|
||||||
|
RPC_path.(open_root / "required_endorsements")
|
||||||
|
end
|
||||||
|
|
||||||
|
let register () =
|
||||||
|
let open Services_registration in
|
||||||
|
register0 S.required_endorsements begin fun ctxt ({ block_delay }) () ->
|
||||||
|
required_endorsements ctxt block_delay
|
||||||
|
end
|
||||||
|
|
||||||
|
let get ctxt block block_delay =
|
||||||
|
RPC_context.make_call0 S.required_endorsements ctxt block { block_delay } ()
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
module Minimal_valid_time = struct
|
||||||
|
|
||||||
|
let minimal_valid_time ctxt ~priority ~endorsing_power =
|
||||||
|
Baking.minimal_valid_time ctxt
|
||||||
|
~priority ~endorsing_power
|
||||||
|
|
||||||
|
module S = struct
|
||||||
|
|
||||||
|
type t = { priority : int ;
|
||||||
|
endorsing_power : int }
|
||||||
|
|
||||||
|
let minimal_valid_time_query =
|
||||||
|
let open RPC_query in
|
||||||
|
query (fun priority endorsing_power ->
|
||||||
|
{ priority ; endorsing_power })
|
||||||
|
|+ field "priority" RPC_arg.int 0 (fun t -> t.priority)
|
||||||
|
|+ field "endorsing_power" RPC_arg.int 0 (fun t -> t.endorsing_power)
|
||||||
|
|> seal
|
||||||
|
|
||||||
|
let minimal_valid_time =
|
||||||
|
RPC_service.get_service
|
||||||
|
~description: "Minimal valid time for a block given a priority \
|
||||||
|
and an endorsing power."
|
||||||
|
~query: minimal_valid_time_query
|
||||||
|
~output: Time.encoding
|
||||||
|
RPC_path.(open_root / "minimal_valid_time")
|
||||||
|
end
|
||||||
|
|
||||||
|
let register () =
|
||||||
|
let open Services_registration in
|
||||||
|
register0 S.minimal_valid_time begin fun ctxt { priority ; endorsing_power } () ->
|
||||||
|
minimal_valid_time ctxt ~priority ~endorsing_power
|
||||||
|
end
|
||||||
|
|
||||||
|
let get ctxt block priority endorsing_power =
|
||||||
|
RPC_context.make_call0 S.minimal_valid_time ctxt block { priority ; endorsing_power } ()
|
||||||
|
end
|
||||||
|
|
||||||
let register () =
|
let register () =
|
||||||
register () ;
|
register () ;
|
||||||
Baking_rights.register () ;
|
Baking_rights.register () ;
|
||||||
Endorsing_rights.register ()
|
Endorsing_rights.register () ;
|
||||||
|
Endorsing_power.register () ;
|
||||||
|
Required_endorsements.register () ;
|
||||||
|
Minimal_valid_time.register ()
|
||||||
|
|
||||||
let endorsement_rights ctxt level =
|
let endorsement_rights ctxt level =
|
||||||
Endorsing_rights.endorsement_slots ctxt (level, None) >>=? fun l ->
|
Endorsing_rights.endorsement_slots ctxt (level, None) >>=? fun l ->
|
||||||
@ -551,3 +669,12 @@ let baking_rights ctxt max_priority =
|
|||||||
List.map
|
List.map
|
||||||
(fun { Baking_rights.delegate ; timestamp ; _ } ->
|
(fun { Baking_rights.delegate ; timestamp ; _ } ->
|
||||||
(delegate, timestamp)) l)
|
(delegate, timestamp)) l)
|
||||||
|
|
||||||
|
let endorsing_power ctxt operation =
|
||||||
|
Endorsing_power.endorsing_power ctxt operation
|
||||||
|
|
||||||
|
let required_endorsements ctxt delay =
|
||||||
|
Required_endorsements.required_endorsements ctxt delay
|
||||||
|
|
||||||
|
let minimal_valid_time ctxt priority endorsing_power =
|
||||||
|
Minimal_valid_time.minimal_valid_time ctxt priority endorsing_power
|
||||||
|
@ -36,7 +36,7 @@ type info = {
|
|||||||
frozen_balance: Tez.t ;
|
frozen_balance: Tez.t ;
|
||||||
frozen_balance_by_cycle: Delegate.frozen_balance Cycle.Map.t ;
|
frozen_balance_by_cycle: Delegate.frozen_balance Cycle.Map.t ;
|
||||||
staking_balance: Tez.t ;
|
staking_balance: Tez.t ;
|
||||||
delegated_contracts: Contract_hash.t list ;
|
delegated_contracts: Contract_repr.t list ;
|
||||||
delegated_balance: Tez.t ;
|
delegated_balance: Tez.t ;
|
||||||
deactivated: bool ;
|
deactivated: bool ;
|
||||||
grace_period: Cycle.t ;
|
grace_period: Cycle.t ;
|
||||||
@ -72,7 +72,7 @@ val staking_balance:
|
|||||||
val delegated_contracts:
|
val delegated_contracts:
|
||||||
'a #RPC_context.simple -> 'a ->
|
'a #RPC_context.simple -> 'a ->
|
||||||
Signature.Public_key_hash.t ->
|
Signature.Public_key_hash.t ->
|
||||||
Contract_hash.t list shell_tzresult Lwt.t
|
Contract_repr.t list shell_tzresult Lwt.t
|
||||||
|
|
||||||
val delegated_balance:
|
val delegated_balance:
|
||||||
'a #RPC_context.simple -> 'a ->
|
'a #RPC_context.simple -> 'a ->
|
||||||
@ -162,6 +162,32 @@ module Endorsing_rights : sig
|
|||||||
|
|
||||||
end
|
end
|
||||||
|
|
||||||
|
module Endorsing_power : sig
|
||||||
|
|
||||||
|
val get:
|
||||||
|
'a #RPC_context.simple -> 'a ->
|
||||||
|
Alpha_context.packed_operation ->
|
||||||
|
Chain_id.t ->
|
||||||
|
int shell_tzresult Lwt.t
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
module Required_endorsements : sig
|
||||||
|
|
||||||
|
val get:
|
||||||
|
'a #RPC_context.simple -> 'a ->
|
||||||
|
Period.t -> int shell_tzresult Lwt.t
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
module Minimal_valid_time : sig
|
||||||
|
|
||||||
|
val get:
|
||||||
|
'a #RPC_context.simple -> 'a ->
|
||||||
|
int -> int -> Time.t shell_tzresult Lwt.t
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
(* temporary export for deprecated unit test *)
|
(* temporary export for deprecated unit test *)
|
||||||
val endorsement_rights:
|
val endorsement_rights:
|
||||||
Alpha_context.t ->
|
Alpha_context.t ->
|
||||||
@ -173,4 +199,20 @@ val baking_rights:
|
|||||||
int option ->
|
int option ->
|
||||||
(Raw_level.t * (public_key_hash * Time.t option) list) tzresult Lwt.t
|
(Raw_level.t * (public_key_hash * Time.t option) list) tzresult Lwt.t
|
||||||
|
|
||||||
|
val endorsing_power:
|
||||||
|
Alpha_context.t ->
|
||||||
|
(Alpha_context.packed_operation * Chain_id.t) ->
|
||||||
|
int tzresult Lwt.t
|
||||||
|
|
||||||
|
val required_endorsements:
|
||||||
|
Alpha_context.t ->
|
||||||
|
Alpha_context.Period.t ->
|
||||||
|
int tzresult Lwt.t
|
||||||
|
|
||||||
|
val minimal_valid_time:
|
||||||
|
Alpha_context.t ->
|
||||||
|
int ->
|
||||||
|
int ->
|
||||||
|
Time.t tzresult Lwt.t
|
||||||
|
|
||||||
val register: unit -> unit
|
val register: unit -> unit
|
||||||
|
@ -123,7 +123,6 @@ let frozen_balance_encoding =
|
|||||||
(req "rewards" Tez_repr.encoding))
|
(req "rewards" Tez_repr.encoding))
|
||||||
|
|
||||||
type error +=
|
type error +=
|
||||||
| Non_delegatable_contract of Contract_repr.contract (* `Permanent *)
|
|
||||||
| No_deletion of Signature.Public_key_hash.t (* `Permanent *)
|
| No_deletion of Signature.Public_key_hash.t (* `Permanent *)
|
||||||
| Active_delegate (* `Temporary *)
|
| Active_delegate (* `Temporary *)
|
||||||
| Current_delegate (* `Temporary *)
|
| Current_delegate (* `Temporary *)
|
||||||
@ -134,18 +133,6 @@ type error +=
|
|||||||
balance : Tez_repr.t } (* `Temporary *)
|
balance : Tez_repr.t } (* `Temporary *)
|
||||||
|
|
||||||
let () =
|
let () =
|
||||||
register_error_kind
|
|
||||||
`Permanent
|
|
||||||
~id:"contract.undelegatable_contract"
|
|
||||||
~title:"Non delegatable contract"
|
|
||||||
~description:"Tried to delegate an implicit contract \
|
|
||||||
or a non delegatable originated contract"
|
|
||||||
~pp:(fun ppf contract ->
|
|
||||||
Format.fprintf ppf "Contract %a is not delegatable"
|
|
||||||
Contract_repr.pp contract)
|
|
||||||
Data_encoding.(obj1 (req "contract" Contract_repr.encoding))
|
|
||||||
(function Non_delegatable_contract c -> Some c | _ -> None)
|
|
||||||
(fun c -> Non_delegatable_contract c) ;
|
|
||||||
register_error_kind
|
register_error_kind
|
||||||
`Permanent
|
`Permanent
|
||||||
~id:"delegate.no_deletion"
|
~id:"delegate.no_deletion"
|
||||||
@ -212,32 +199,20 @@ let () =
|
|||||||
Some (delegate, balance, deposit) | _ -> None)
|
Some (delegate, balance, deposit) | _ -> None)
|
||||||
(fun (delegate, balance, deposit) -> Balance_too_low_for_deposit { delegate ; balance ; deposit } )
|
(fun (delegate, balance, deposit) -> Balance_too_low_for_deposit { delegate ; balance ; deposit } )
|
||||||
|
|
||||||
let is_delegatable c contract =
|
let link c contract delegate =
|
||||||
match Contract_repr.is_implicit contract with
|
Storage.Contract.Balance.get c contract >>=? fun balance ->
|
||||||
| Some _ ->
|
|
||||||
return_false
|
|
||||||
| None ->
|
|
||||||
Storage.Contract.Delegatable.mem c contract >>= return
|
|
||||||
|
|
||||||
let link c contract delegate balance =
|
|
||||||
Roll_storage.Delegate.add_amount c delegate balance >>=? fun c ->
|
Roll_storage.Delegate.add_amount c delegate balance >>=? fun c ->
|
||||||
match Contract_repr.is_originated contract with
|
Storage.Contract.Delegated.add (c, Contract_repr.implicit_contract delegate) contract >>= fun c ->
|
||||||
| None -> return c
|
|
||||||
| Some h ->
|
|
||||||
Storage.Contract.Delegated.add
|
|
||||||
(c, Contract_repr.implicit_contract delegate) h >>= fun c ->
|
|
||||||
return c
|
return c
|
||||||
|
|
||||||
let unlink c contract balance =
|
let unlink c contract =
|
||||||
|
Storage.Contract.Balance.get c contract >>=? fun balance ->
|
||||||
Storage.Contract.Delegate.get_option c contract >>=? function
|
Storage.Contract.Delegate.get_option c contract >>=? function
|
||||||
| None -> return c
|
| None -> return c
|
||||||
| Some delegate ->
|
| Some delegate ->
|
||||||
|
(* Removes the balance of the contract from the delegate *)
|
||||||
Roll_storage.Delegate.remove_amount c delegate balance >>=? fun c ->
|
Roll_storage.Delegate.remove_amount c delegate balance >>=? fun c ->
|
||||||
match Contract_repr.is_originated contract with
|
Storage.Contract.Delegated.del (c, Contract_repr.implicit_contract delegate) contract >>= fun c ->
|
||||||
| None -> return c
|
|
||||||
| Some h ->
|
|
||||||
Storage.Contract.Delegated.del
|
|
||||||
(c, Contract_repr.implicit_contract delegate) h >>= fun c ->
|
|
||||||
return c
|
return c
|
||||||
|
|
||||||
let known c delegate =
|
let known c delegate =
|
||||||
@ -246,55 +221,55 @@ let known c delegate =
|
|||||||
| None | Some (Manager_repr.Hash _) -> return_false
|
| None | Some (Manager_repr.Hash _) -> return_false
|
||||||
| Some (Manager_repr.Public_key _) -> return_true
|
| Some (Manager_repr.Public_key _) -> return_true
|
||||||
|
|
||||||
(* A delegate is registered if its "implicit account"
|
(* A delegate is registered if its "implicit account" delegates to itself. *)
|
||||||
delegates to itself. *)
|
|
||||||
let registered c delegate =
|
let registered c delegate =
|
||||||
Storage.Contract.Delegate.mem
|
Storage.Contract.Delegate.get_option
|
||||||
c (Contract_repr.implicit_contract delegate)
|
c (Contract_repr.implicit_contract delegate) >>=? function
|
||||||
|
| Some current_delegate ->
|
||||||
|
return @@ Signature.Public_key_hash.equal delegate current_delegate
|
||||||
|
| None ->
|
||||||
|
return_false
|
||||||
|
|
||||||
let init ctxt contract delegate =
|
let init ctxt contract delegate =
|
||||||
known ctxt delegate >>=? fun known_delegate ->
|
known ctxt delegate >>=? fun known_delegate ->
|
||||||
fail_unless
|
fail_unless
|
||||||
known_delegate
|
known_delegate
|
||||||
(Roll_storage.Unregistered_delegate delegate) >>=? fun () ->
|
(Roll_storage.Unregistered_delegate delegate) >>=? fun () ->
|
||||||
registered ctxt delegate >>= fun is_registered ->
|
registered ctxt delegate >>=? fun is_registered ->
|
||||||
fail_unless
|
fail_unless
|
||||||
is_registered
|
is_registered
|
||||||
(Roll_storage.Unregistered_delegate delegate) >>=? fun () ->
|
(Roll_storage.Unregistered_delegate delegate) >>=? fun () ->
|
||||||
Storage.Contract.Delegate.init ctxt contract delegate >>=? fun ctxt ->
|
Storage.Contract.Delegate.init ctxt contract delegate >>=? fun ctxt ->
|
||||||
Storage.Contract.Balance.get ctxt contract >>=? fun balance ->
|
link ctxt contract delegate
|
||||||
link ctxt contract delegate balance
|
|
||||||
|
|
||||||
let get = Roll_storage.get_contract_delegate
|
let get = Roll_storage.get_contract_delegate
|
||||||
|
|
||||||
let set_base c is_delegatable contract delegate =
|
let set c contract delegate =
|
||||||
match delegate with
|
match delegate with
|
||||||
| None -> begin
|
| None -> begin
|
||||||
|
let delete () =
|
||||||
|
unlink c contract >>=? fun c ->
|
||||||
|
Storage.Contract.Delegate.remove c contract >>= fun c ->
|
||||||
|
return c in
|
||||||
match Contract_repr.is_implicit contract with
|
match Contract_repr.is_implicit contract with
|
||||||
| Some pkh ->
|
| Some pkh ->
|
||||||
|
(* check if contract is a registered delegate *)
|
||||||
|
registered c pkh >>=? fun is_registered ->
|
||||||
|
if is_registered then
|
||||||
fail (No_deletion pkh)
|
fail (No_deletion pkh)
|
||||||
| None ->
|
|
||||||
is_delegatable c contract >>=? fun delegatable ->
|
|
||||||
if delegatable then
|
|
||||||
Storage.Contract.Balance.get c contract >>=? fun balance ->
|
|
||||||
unlink c contract balance >>=? fun c ->
|
|
||||||
Storage.Contract.Delegate.remove c contract >>= fun c ->
|
|
||||||
return c
|
|
||||||
else
|
else
|
||||||
fail (Non_delegatable_contract contract)
|
delete ()
|
||||||
|
| None -> delete ()
|
||||||
end
|
end
|
||||||
| Some delegate ->
|
| Some delegate ->
|
||||||
known c delegate >>=? fun known_delegate ->
|
known c delegate >>=? fun known_delegate ->
|
||||||
registered c delegate >>= fun registered_delegate ->
|
registered c delegate >>=? fun registered_delegate ->
|
||||||
is_delegatable c contract >>=? fun delegatable ->
|
|
||||||
let self_delegation =
|
let self_delegation =
|
||||||
match Contract_repr.is_implicit contract with
|
match Contract_repr.is_implicit contract with
|
||||||
| Some pkh -> Signature.Public_key_hash.equal pkh delegate
|
| Some pkh -> Signature.Public_key_hash.equal pkh delegate
|
||||||
| None -> false in
|
| None -> false in
|
||||||
if not known_delegate || not (registered_delegate || self_delegation) then
|
if not known_delegate || not (registered_delegate || self_delegation) then
|
||||||
fail (Roll_storage.Unregistered_delegate delegate)
|
fail (Roll_storage.Unregistered_delegate delegate)
|
||||||
else if not (delegatable || self_delegation) then
|
|
||||||
fail (Non_delegatable_contract contract)
|
|
||||||
else
|
else
|
||||||
begin
|
begin
|
||||||
Storage.Contract.Delegate.get_option c contract >>=? function
|
Storage.Contract.Delegate.get_option c contract >>=? function
|
||||||
@ -308,14 +283,26 @@ let set_base c is_delegatable contract delegate =
|
|||||||
fail Current_delegate
|
fail Current_delegate
|
||||||
| None | Some _ -> return_unit
|
| None | Some _ -> return_unit
|
||||||
end >>=? fun () ->
|
end >>=? fun () ->
|
||||||
|
(* check if contract is a registered delegate *)
|
||||||
|
begin
|
||||||
|
match Contract_repr.is_implicit contract with
|
||||||
|
| Some pkh ->
|
||||||
|
registered c pkh >>=? fun is_registered ->
|
||||||
|
(* allow self-delegation to re-activate *)
|
||||||
|
if not self_delegation && is_registered then
|
||||||
|
fail (No_deletion pkh)
|
||||||
|
else
|
||||||
|
return_unit
|
||||||
|
| None ->
|
||||||
|
return_unit
|
||||||
|
end >>=? fun () ->
|
||||||
Storage.Contract.Balance.mem c contract >>= fun exists ->
|
Storage.Contract.Balance.mem c contract >>= fun exists ->
|
||||||
fail_when
|
fail_when
|
||||||
(self_delegation && not exists)
|
(self_delegation && not exists)
|
||||||
(Empty_delegate_account delegate) >>=? fun () ->
|
(Empty_delegate_account delegate) >>=? fun () ->
|
||||||
Storage.Contract.Balance.get c contract >>=? fun balance ->
|
unlink c contract >>=? fun c ->
|
||||||
unlink c contract balance >>=? fun c ->
|
|
||||||
Storage.Contract.Delegate.init_set c contract delegate >>= fun c ->
|
Storage.Contract.Delegate.init_set c contract delegate >>= fun c ->
|
||||||
link c contract delegate balance >>=? fun c ->
|
link c contract delegate >>=? fun c ->
|
||||||
begin
|
begin
|
||||||
if self_delegation then
|
if self_delegation then
|
||||||
Storage.Delegates.add c delegate >>= fun c ->
|
Storage.Delegates.add c delegate >>= fun c ->
|
||||||
@ -326,15 +313,8 @@ let set_base c is_delegatable contract delegate =
|
|||||||
end >>=? fun c ->
|
end >>=? fun c ->
|
||||||
return c
|
return c
|
||||||
|
|
||||||
let set c contract delegate =
|
|
||||||
set_base c is_delegatable contract delegate
|
|
||||||
|
|
||||||
let set_from_script c contract delegate =
|
|
||||||
set_base c (fun _ _ -> return_true) contract delegate
|
|
||||||
|
|
||||||
let remove ctxt contract =
|
let remove ctxt contract =
|
||||||
Storage.Contract.Balance.get ctxt contract >>=? fun balance ->
|
unlink ctxt contract
|
||||||
unlink ctxt contract balance
|
|
||||||
|
|
||||||
let delegated_contracts ctxt delegate =
|
let delegated_contracts ctxt delegate =
|
||||||
let contract = Contract_repr.implicit_contract delegate in
|
let contract = Contract_repr.implicit_contract delegate in
|
||||||
|
@ -49,10 +49,6 @@ type frozen_balance = {
|
|||||||
rewards : Tez_repr.t ;
|
rewards : Tez_repr.t ;
|
||||||
}
|
}
|
||||||
|
|
||||||
(** Is the contract eligible to delegation ? *)
|
|
||||||
val is_delegatable:
|
|
||||||
Raw_context.t -> Contract_repr.t -> bool tzresult Lwt.t
|
|
||||||
|
|
||||||
(** Allow to register a delegate when creating an account. *)
|
(** Allow to register a delegate when creating an account. *)
|
||||||
val init:
|
val init:
|
||||||
Raw_context.t -> Contract_repr.t -> Signature.Public_key_hash.t ->
|
Raw_context.t -> Contract_repr.t -> Signature.Public_key_hash.t ->
|
||||||
@ -67,26 +63,19 @@ val get:
|
|||||||
Raw_context.t -> Contract_repr.t ->
|
Raw_context.t -> Contract_repr.t ->
|
||||||
Signature.Public_key_hash.t option tzresult Lwt.t
|
Signature.Public_key_hash.t option tzresult Lwt.t
|
||||||
|
|
||||||
val registered: Raw_context.t -> Signature.Public_key_hash.t -> bool Lwt.t
|
val registered: Raw_context.t -> Signature.Public_key_hash.t -> bool tzresult Lwt.t
|
||||||
|
|
||||||
(** Updating the delegate of a contract.
|
(** Updating the delegate of a contract.
|
||||||
|
|
||||||
When calling this function on an "implicit contract" this function
|
When calling this function on an "implicit contract" and setting
|
||||||
fails, unless when the registered delegate is the contract manager.
|
the delegate to the contract manager registers it as a delegate. One
|
||||||
In the that case, the manager is now registered as a delegate. One
|
cannot unregister a delegate for now. The associate contract is now
|
||||||
cannot unregister a delegate for now. The associate contract is
|
'undeletable'. *)
|
||||||
now 'undeletable'. *)
|
|
||||||
val set:
|
val set:
|
||||||
Raw_context.t -> Contract_repr.t -> Signature.Public_key_hash.t option ->
|
Raw_context.t -> Contract_repr.t -> Signature.Public_key_hash.t option ->
|
||||||
Raw_context.t tzresult Lwt.t
|
Raw_context.t tzresult Lwt.t
|
||||||
|
|
||||||
(** Same as {!set} ignoring the [delegatable] flag. *)
|
|
||||||
val set_from_script:
|
|
||||||
Raw_context.t -> Contract_repr.t -> Signature.Public_key_hash.t option ->
|
|
||||||
Raw_context.t tzresult Lwt.t
|
|
||||||
|
|
||||||
type error +=
|
type error +=
|
||||||
| Non_delegatable_contract of Contract_repr.contract (* `Permanent *)
|
|
||||||
| No_deletion of Signature.Public_key_hash.t (* `Permanent *)
|
| No_deletion of Signature.Public_key_hash.t (* `Permanent *)
|
||||||
| Active_delegate (* `Temporary *)
|
| Active_delegate (* `Temporary *)
|
||||||
| Current_delegate (* `Temporary *)
|
| Current_delegate (* `Temporary *)
|
||||||
@ -169,10 +158,10 @@ val staking_balance:
|
|||||||
Raw_context.t -> Signature.Public_key_hash.t ->
|
Raw_context.t -> Signature.Public_key_hash.t ->
|
||||||
Tez_repr.t tzresult Lwt.t
|
Tez_repr.t tzresult Lwt.t
|
||||||
|
|
||||||
(** Returns the list of contract that delegated towards a given delegate *)
|
(** Returns the list of contracts (implicit or originated) that delegated towards a given delegate *)
|
||||||
val delegated_contracts:
|
val delegated_contracts:
|
||||||
Raw_context.t -> Signature.Public_key_hash.t ->
|
Raw_context.t -> Signature.Public_key_hash.t ->
|
||||||
Contract_hash.t list Lwt.t
|
Contract_repr.t list Lwt.t
|
||||||
|
|
||||||
val delegated_balance:
|
val delegated_balance:
|
||||||
Raw_context.t -> Signature.Public_key_hash.t ->
|
Raw_context.t -> Signature.Public_key_hash.t ->
|
||||||
|
54
vendors/ligo-utils/tezos-protocol-alpha/dune.inc
vendored
54
vendors/ligo-utils/tezos-protocol-alpha/dune.inc
vendored
@ -11,22 +11,22 @@
|
|||||||
(targets environment.ml)
|
(targets environment.ml)
|
||||||
(action
|
(action
|
||||||
(write-file %{targets}
|
(write-file %{targets}
|
||||||
"module Name = struct let name = \"alpha\" end
|
"module Name = struct let name = \"005-PsBabyM1\" end
|
||||||
include Tezos_protocol_environment.MakeV1(Name)()
|
include Tezos_protocol_environment.MakeV1(Name)()
|
||||||
module CamlinternalFormatBasics = struct include CamlinternalFormatBasics end
|
module CamlinternalFormatBasics = struct include CamlinternalFormatBasics end
|
||||||
")))
|
")))
|
||||||
|
|
||||||
(rule
|
(rule
|
||||||
(targets registerer.ml)
|
(targets registerer.ml)
|
||||||
(deps misc.mli misc.ml storage_description.mli storage_description.ml state_hash.ml nonce_hash.ml script_expr_hash.ml contract_hash.ml blinded_public_key_hash.mli blinded_public_key_hash.ml qty_repr.ml tez_repr.mli tez_repr.ml period_repr.mli period_repr.ml time_repr.mli time_repr.ml constants_repr.ml fitness_repr.ml raw_level_repr.mli raw_level_repr.ml voting_period_repr.mli voting_period_repr.ml cycle_repr.mli cycle_repr.ml level_repr.mli level_repr.ml seed_repr.mli seed_repr.ml gas_limit_repr.mli gas_limit_repr.ml script_int_repr.mli script_int_repr.ml script_timestamp_repr.mli script_timestamp_repr.ml michelson_v1_primitives.mli michelson_v1_primitives.ml script_repr.mli script_repr.ml contract_repr.mli contract_repr.ml roll_repr.mli roll_repr.ml vote_repr.mli vote_repr.ml block_header_repr.mli block_header_repr.ml operation_repr.mli operation_repr.ml manager_repr.mli manager_repr.ml commitment_repr.mli commitment_repr.ml parameters_repr.mli parameters_repr.ml raw_context.mli raw_context.ml storage_sigs.ml storage_functors.mli storage_functors.ml storage.mli storage.ml constants_storage.ml level_storage.mli level_storage.ml nonce_storage.mli nonce_storage.ml seed_storage.mli seed_storage.ml roll_storage.mli roll_storage.ml delegate_storage.mli delegate_storage.ml contract_storage.mli contract_storage.ml bootstrap_storage.mli bootstrap_storage.ml fitness_storage.ml vote_storage.mli vote_storage.ml commitment_storage.mli commitment_storage.ml init_storage.ml fees_storage.mli fees_storage.ml alpha_context.mli alpha_context.ml script_typed_ir.ml script_tc_errors.ml michelson_v1_gas.mli michelson_v1_gas.ml script_ir_annot.mli script_ir_annot.ml script_ir_translator.mli script_ir_translator.ml script_tc_errors_registration.ml script_interpreter.mli script_interpreter.ml baking.mli baking.ml amendment.mli amendment.ml apply_results.mli apply_results.ml apply.ml services_registration.ml constants_services.mli constants_services.ml contract_services.mli contract_services.ml delegate_services.mli delegate_services.ml helpers_services.mli helpers_services.ml voting_services.mli voting_services.ml alpha_services.mli alpha_services.ml main.mli main.ml
|
(deps misc.mli misc.ml storage_description.mli storage_description.ml state_hash.ml nonce_hash.ml script_expr_hash.ml contract_hash.ml blinded_public_key_hash.mli blinded_public_key_hash.ml qty_repr.ml tez_repr.mli tez_repr.ml period_repr.mli period_repr.ml time_repr.mli time_repr.ml constants_repr.ml fitness_repr.ml raw_level_repr.mli raw_level_repr.ml voting_period_repr.mli voting_period_repr.ml cycle_repr.mli cycle_repr.ml level_repr.mli level_repr.ml seed_repr.mli seed_repr.ml gas_limit_repr.mli gas_limit_repr.ml script_int_repr.mli script_int_repr.ml script_timestamp_repr.mli script_timestamp_repr.ml michelson_v1_primitives.mli michelson_v1_primitives.ml script_repr.mli script_repr.ml legacy_script_support_repr.mli legacy_script_support_repr.ml contract_repr.mli contract_repr.ml roll_repr.mli roll_repr.ml vote_repr.mli vote_repr.ml block_header_repr.mli block_header_repr.ml operation_repr.mli operation_repr.ml manager_repr.mli manager_repr.ml commitment_repr.mli commitment_repr.ml parameters_repr.mli parameters_repr.ml raw_context.mli raw_context.ml storage_sigs.ml storage_functors.mli storage_functors.ml storage.mli storage.ml constants_storage.ml level_storage.mli level_storage.ml nonce_storage.mli nonce_storage.ml seed_storage.mli seed_storage.ml roll_storage.mli roll_storage.ml delegate_storage.mli delegate_storage.ml contract_storage.mli contract_storage.ml bootstrap_storage.mli bootstrap_storage.ml fitness_storage.ml vote_storage.mli vote_storage.ml commitment_storage.mli commitment_storage.ml init_storage.ml fees_storage.mli fees_storage.ml alpha_context.mli alpha_context.ml script_typed_ir.ml script_tc_errors.ml michelson_v1_gas.mli michelson_v1_gas.ml script_ir_annot.mli script_ir_annot.ml script_ir_translator.mli script_ir_translator.ml script_tc_errors_registration.ml script_interpreter.mli script_interpreter.ml baking.mli baking.ml amendment.mli amendment.ml apply_results.mli apply_results.ml apply.ml services_registration.ml constants_services.mli constants_services.ml contract_services.mli contract_services.ml delegate_services.mli delegate_services.ml helpers_services.mli helpers_services.ml voting_services.mli voting_services.ml alpha_services.mli alpha_services.ml main.mli main.ml
|
||||||
(:src_dir TEZOS_PROTOCOL))
|
(:src_dir TEZOS_PROTOCOL))
|
||||||
(action
|
(action
|
||||||
(with-stdout-to %{targets}
|
(with-stdout-to %{targets}
|
||||||
(chdir %{workspace_root} (run %{bin:tezos-embedded-protocol-packer} "%{src_dir}" "alpha")))))
|
(chdir %{workspace_root} (run %{bin:tezos-embedded-protocol-packer} "%{src_dir}" "005_PsBabyM1")))))
|
||||||
|
|
||||||
(rule
|
(rule
|
||||||
(targets functor.ml)
|
(targets functor.ml)
|
||||||
(deps misc.mli misc.ml storage_description.mli storage_description.ml state_hash.ml nonce_hash.ml script_expr_hash.ml contract_hash.ml blinded_public_key_hash.mli blinded_public_key_hash.ml qty_repr.ml tez_repr.mli tez_repr.ml period_repr.mli period_repr.ml time_repr.mli time_repr.ml constants_repr.ml fitness_repr.ml raw_level_repr.mli raw_level_repr.ml voting_period_repr.mli voting_period_repr.ml cycle_repr.mli cycle_repr.ml level_repr.mli level_repr.ml seed_repr.mli seed_repr.ml gas_limit_repr.mli gas_limit_repr.ml script_int_repr.mli script_int_repr.ml script_timestamp_repr.mli script_timestamp_repr.ml michelson_v1_primitives.mli michelson_v1_primitives.ml script_repr.mli script_repr.ml contract_repr.mli contract_repr.ml roll_repr.mli roll_repr.ml vote_repr.mli vote_repr.ml block_header_repr.mli block_header_repr.ml operation_repr.mli operation_repr.ml manager_repr.mli manager_repr.ml commitment_repr.mli commitment_repr.ml parameters_repr.mli parameters_repr.ml raw_context.mli raw_context.ml storage_sigs.ml storage_functors.mli storage_functors.ml storage.mli storage.ml constants_storage.ml level_storage.mli level_storage.ml nonce_storage.mli nonce_storage.ml seed_storage.mli seed_storage.ml roll_storage.mli roll_storage.ml delegate_storage.mli delegate_storage.ml contract_storage.mli contract_storage.ml bootstrap_storage.mli bootstrap_storage.ml fitness_storage.ml vote_storage.mli vote_storage.ml commitment_storage.mli commitment_storage.ml init_storage.ml fees_storage.mli fees_storage.ml alpha_context.mli alpha_context.ml script_typed_ir.ml script_tc_errors.ml michelson_v1_gas.mli michelson_v1_gas.ml script_ir_annot.mli script_ir_annot.ml script_ir_translator.mli script_ir_translator.ml script_tc_errors_registration.ml script_interpreter.mli script_interpreter.ml baking.mli baking.ml amendment.mli amendment.ml apply_results.mli apply_results.ml apply.ml services_registration.ml constants_services.mli constants_services.ml contract_services.mli contract_services.ml delegate_services.mli delegate_services.ml helpers_services.mli helpers_services.ml voting_services.mli voting_services.ml alpha_services.mli alpha_services.ml main.mli main.ml
|
(deps misc.mli misc.ml storage_description.mli storage_description.ml state_hash.ml nonce_hash.ml script_expr_hash.ml contract_hash.ml blinded_public_key_hash.mli blinded_public_key_hash.ml qty_repr.ml tez_repr.mli tez_repr.ml period_repr.mli period_repr.ml time_repr.mli time_repr.ml constants_repr.ml fitness_repr.ml raw_level_repr.mli raw_level_repr.ml voting_period_repr.mli voting_period_repr.ml cycle_repr.mli cycle_repr.ml level_repr.mli level_repr.ml seed_repr.mli seed_repr.ml gas_limit_repr.mli gas_limit_repr.ml script_int_repr.mli script_int_repr.ml script_timestamp_repr.mli script_timestamp_repr.ml michelson_v1_primitives.mli michelson_v1_primitives.ml script_repr.mli script_repr.ml legacy_script_support_repr.mli legacy_script_support_repr.ml contract_repr.mli contract_repr.ml roll_repr.mli roll_repr.ml vote_repr.mli vote_repr.ml block_header_repr.mli block_header_repr.ml operation_repr.mli operation_repr.ml manager_repr.mli manager_repr.ml commitment_repr.mli commitment_repr.ml parameters_repr.mli parameters_repr.ml raw_context.mli raw_context.ml storage_sigs.ml storage_functors.mli storage_functors.ml storage.mli storage.ml constants_storage.ml level_storage.mli level_storage.ml nonce_storage.mli nonce_storage.ml seed_storage.mli seed_storage.ml roll_storage.mli roll_storage.ml delegate_storage.mli delegate_storage.ml contract_storage.mli contract_storage.ml bootstrap_storage.mli bootstrap_storage.ml fitness_storage.ml vote_storage.mli vote_storage.ml commitment_storage.mli commitment_storage.ml init_storage.ml fees_storage.mli fees_storage.ml alpha_context.mli alpha_context.ml script_typed_ir.ml script_tc_errors.ml michelson_v1_gas.mli michelson_v1_gas.ml script_ir_annot.mli script_ir_annot.ml script_ir_translator.mli script_ir_translator.ml script_tc_errors_registration.ml script_interpreter.mli script_interpreter.ml baking.mli baking.ml amendment.mli amendment.ml apply_results.mli apply_results.ml apply.ml services_registration.ml constants_services.mli constants_services.ml contract_services.mli contract_services.ml delegate_services.mli delegate_services.ml helpers_services.mli helpers_services.ml voting_services.mli voting_services.ml alpha_services.mli alpha_services.ml main.mli main.ml
|
||||||
(:src_dir TEZOS_PROTOCOL))
|
(:src_dir TEZOS_PROTOCOL))
|
||||||
(action (with-stdout-to %{targets}
|
(action (with-stdout-to %{targets}
|
||||||
(chdir %{workspace_root}
|
(chdir %{workspace_root}
|
||||||
@ -34,70 +34,70 @@ module CamlinternalFormatBasics = struct include CamlinternalFormatBasics end
|
|||||||
|
|
||||||
(rule
|
(rule
|
||||||
(targets protocol.ml)
|
(targets protocol.ml)
|
||||||
(deps misc.mli misc.ml storage_description.mli storage_description.ml state_hash.ml nonce_hash.ml script_expr_hash.ml contract_hash.ml blinded_public_key_hash.mli blinded_public_key_hash.ml qty_repr.ml tez_repr.mli tez_repr.ml period_repr.mli period_repr.ml time_repr.mli time_repr.ml constants_repr.ml fitness_repr.ml raw_level_repr.mli raw_level_repr.ml voting_period_repr.mli voting_period_repr.ml cycle_repr.mli cycle_repr.ml level_repr.mli level_repr.ml seed_repr.mli seed_repr.ml gas_limit_repr.mli gas_limit_repr.ml script_int_repr.mli script_int_repr.ml script_timestamp_repr.mli script_timestamp_repr.ml michelson_v1_primitives.mli michelson_v1_primitives.ml script_repr.mli script_repr.ml contract_repr.mli contract_repr.ml roll_repr.mli roll_repr.ml vote_repr.mli vote_repr.ml block_header_repr.mli block_header_repr.ml operation_repr.mli operation_repr.ml manager_repr.mli manager_repr.ml commitment_repr.mli commitment_repr.ml parameters_repr.mli parameters_repr.ml raw_context.mli raw_context.ml storage_sigs.ml storage_functors.mli storage_functors.ml storage.mli storage.ml constants_storage.ml level_storage.mli level_storage.ml nonce_storage.mli nonce_storage.ml seed_storage.mli seed_storage.ml roll_storage.mli roll_storage.ml delegate_storage.mli delegate_storage.ml contract_storage.mli contract_storage.ml bootstrap_storage.mli bootstrap_storage.ml fitness_storage.ml vote_storage.mli vote_storage.ml commitment_storage.mli commitment_storage.ml init_storage.ml fees_storage.mli fees_storage.ml alpha_context.mli alpha_context.ml script_typed_ir.ml script_tc_errors.ml michelson_v1_gas.mli michelson_v1_gas.ml script_ir_annot.mli script_ir_annot.ml script_ir_translator.mli script_ir_translator.ml script_tc_errors_registration.ml script_interpreter.mli script_interpreter.ml baking.mli baking.ml amendment.mli amendment.ml apply_results.mli apply_results.ml apply.ml services_registration.ml constants_services.mli constants_services.ml contract_services.mli contract_services.ml delegate_services.mli delegate_services.ml helpers_services.mli helpers_services.ml voting_services.mli voting_services.ml alpha_services.mli alpha_services.ml main.mli main.ml)
|
(deps misc.mli misc.ml storage_description.mli storage_description.ml state_hash.ml nonce_hash.ml script_expr_hash.ml contract_hash.ml blinded_public_key_hash.mli blinded_public_key_hash.ml qty_repr.ml tez_repr.mli tez_repr.ml period_repr.mli period_repr.ml time_repr.mli time_repr.ml constants_repr.ml fitness_repr.ml raw_level_repr.mli raw_level_repr.ml voting_period_repr.mli voting_period_repr.ml cycle_repr.mli cycle_repr.ml level_repr.mli level_repr.ml seed_repr.mli seed_repr.ml gas_limit_repr.mli gas_limit_repr.ml script_int_repr.mli script_int_repr.ml script_timestamp_repr.mli script_timestamp_repr.ml michelson_v1_primitives.mli michelson_v1_primitives.ml script_repr.mli script_repr.ml legacy_script_support_repr.mli legacy_script_support_repr.ml contract_repr.mli contract_repr.ml roll_repr.mli roll_repr.ml vote_repr.mli vote_repr.ml block_header_repr.mli block_header_repr.ml operation_repr.mli operation_repr.ml manager_repr.mli manager_repr.ml commitment_repr.mli commitment_repr.ml parameters_repr.mli parameters_repr.ml raw_context.mli raw_context.ml storage_sigs.ml storage_functors.mli storage_functors.ml storage.mli storage.ml constants_storage.ml level_storage.mli level_storage.ml nonce_storage.mli nonce_storage.ml seed_storage.mli seed_storage.ml roll_storage.mli roll_storage.ml delegate_storage.mli delegate_storage.ml contract_storage.mli contract_storage.ml bootstrap_storage.mli bootstrap_storage.ml fitness_storage.ml vote_storage.mli vote_storage.ml commitment_storage.mli commitment_storage.ml init_storage.ml fees_storage.mli fees_storage.ml alpha_context.mli alpha_context.ml script_typed_ir.ml script_tc_errors.ml michelson_v1_gas.mli michelson_v1_gas.ml script_ir_annot.mli script_ir_annot.ml script_ir_translator.mli script_ir_translator.ml script_tc_errors_registration.ml script_interpreter.mli script_interpreter.ml baking.mli baking.ml amendment.mli amendment.ml apply_results.mli apply_results.ml apply.ml services_registration.ml constants_services.mli constants_services.ml contract_services.mli contract_services.ml delegate_services.mli delegate_services.ml helpers_services.mli helpers_services.ml voting_services.mli voting_services.ml alpha_services.mli alpha_services.ml main.mli main.ml)
|
||||||
(action
|
(action
|
||||||
(write-file %{targets}
|
(write-file %{targets}
|
||||||
"module Environment = Tezos_protocol_environment_alpha.Environment
|
"module Environment = Tezos_protocol_environment_005_PsBabyM1.Environment
|
||||||
let hash = Tezos_crypto.Protocol_hash.of_b58check_exn \"ProtoALphaALphaALphaALphaALphaALphaALphaALphaDdp3zK\"
|
let hash = Tezos_crypto.Protocol_hash.of_b58check_exn \"PsBabyM1eUXZseaJdmXFApDSBqj8YBfwELoxZHHW77EMcAbbwAS\"
|
||||||
let name = Environment.Name.name
|
let name = Environment.Name.name
|
||||||
include Tezos_raw_protocol_alpha
|
include Tezos_raw_protocol_005_PsBabyM1
|
||||||
include Tezos_raw_protocol_alpha.Main
|
include Tezos_raw_protocol_005_PsBabyM1.Main
|
||||||
")))
|
")))
|
||||||
|
|
||||||
(library
|
(library
|
||||||
(name tezos_protocol_environment_alpha)
|
(name tezos_protocol_environment_005_PsBabyM1)
|
||||||
(public_name tezos-protocol-alpha.environment)
|
(public_name tezos-protocol-005-PsBabyM1.environment)
|
||||||
(library_flags (:standard -linkall))
|
(library_flags (:standard -linkall))
|
||||||
(libraries tezos-protocol-environment)
|
(libraries tezos-protocol-environment)
|
||||||
(modules Environment))
|
(modules Environment))
|
||||||
|
|
||||||
(library
|
(library
|
||||||
(name tezos_raw_protocol_alpha)
|
(name tezos_raw_protocol_005_PsBabyM1)
|
||||||
(public_name tezos-protocol-alpha.raw)
|
(public_name tezos-protocol-005-PsBabyM1.raw)
|
||||||
(libraries tezos_protocol_environment_alpha)
|
(libraries tezos_protocol_environment_005_PsBabyM1)
|
||||||
(library_flags (:standard -linkall))
|
(library_flags (:standard -linkall))
|
||||||
(flags (:standard -nopervasives -nostdlib
|
(flags (:standard -nopervasives -nostdlib
|
||||||
-w +a-4-6-7-9-29-32-40..42-44-45-48
|
-w +a-4-6-7-9-29-32-40..42-44-45-48
|
||||||
-warn-error -a+8
|
-warn-error -a+8
|
||||||
-open Tezos_protocol_environment_alpha__Environment
|
-open Tezos_protocol_environment_005_PsBabyM1__Environment
|
||||||
-open Pervasives
|
-open Pervasives
|
||||||
-open Error_monad))
|
-open Error_monad))
|
||||||
(modules Misc Storage_description State_hash Nonce_hash Script_expr_hash Contract_hash Blinded_public_key_hash Qty_repr Tez_repr Period_repr Time_repr Constants_repr Fitness_repr Raw_level_repr Voting_period_repr Cycle_repr Level_repr Seed_repr Gas_limit_repr Script_int_repr Script_timestamp_repr Michelson_v1_primitives Script_repr Contract_repr Roll_repr Vote_repr Block_header_repr Operation_repr Manager_repr Commitment_repr Parameters_repr Raw_context Storage_sigs Storage_functors Storage Constants_storage Level_storage Nonce_storage Seed_storage Roll_storage Delegate_storage Contract_storage Bootstrap_storage Fitness_storage Vote_storage Commitment_storage Init_storage Fees_storage Alpha_context Script_typed_ir Script_tc_errors Michelson_v1_gas Script_ir_annot Script_ir_translator Script_tc_errors_registration Script_interpreter Baking Amendment Apply_results Apply Services_registration Constants_services Contract_services Delegate_services Helpers_services Voting_services Alpha_services Main))
|
(modules Misc Storage_description State_hash Nonce_hash Script_expr_hash Contract_hash Blinded_public_key_hash Qty_repr Tez_repr Period_repr Time_repr Constants_repr Fitness_repr Raw_level_repr Voting_period_repr Cycle_repr Level_repr Seed_repr Gas_limit_repr Script_int_repr Script_timestamp_repr Michelson_v1_primitives Script_repr Legacy_script_support_repr Contract_repr Roll_repr Vote_repr Block_header_repr Operation_repr Manager_repr Commitment_repr Parameters_repr Raw_context Storage_sigs Storage_functors Storage Constants_storage Level_storage Nonce_storage Seed_storage Roll_storage Delegate_storage Contract_storage Bootstrap_storage Fitness_storage Vote_storage Commitment_storage Init_storage Fees_storage Alpha_context Script_typed_ir Script_tc_errors Michelson_v1_gas Script_ir_annot Script_ir_translator Script_tc_errors_registration Script_interpreter Baking Amendment Apply_results Apply Services_registration Constants_services Contract_services Delegate_services Helpers_services Voting_services Alpha_services Main))
|
||||||
|
|
||||||
(install
|
(install
|
||||||
(section lib)
|
(section lib)
|
||||||
(package tezos-protocol-alpha)
|
(package tezos-protocol-005-PsBabyM1)
|
||||||
(files (TEZOS_PROTOCOL as raw/TEZOS_PROTOCOL)))
|
(files (TEZOS_PROTOCOL as raw/TEZOS_PROTOCOL)))
|
||||||
|
|
||||||
(library
|
(library
|
||||||
(name tezos_protocol_alpha)
|
(name tezos_protocol_005_PsBabyM1)
|
||||||
(public_name tezos-protocol-alpha)
|
(public_name tezos-protocol-005-PsBabyM1)
|
||||||
(libraries
|
(libraries
|
||||||
tezos-protocol-environment
|
tezos-protocol-environment
|
||||||
tezos-protocol-environment-sigs
|
tezos-protocol-environment-sigs
|
||||||
tezos_raw_protocol_alpha)
|
tezos_raw_protocol_005_PsBabyM1)
|
||||||
(flags -w "+a-4-6-7-9-29-40..42-44-45-48"
|
(flags -w "+a-4-6-7-9-29-40..42-44-45-48"
|
||||||
-warn-error "-a+8"
|
-warn-error "-a+8"
|
||||||
-nopervasives)
|
-nopervasives)
|
||||||
(modules Protocol))
|
(modules Protocol))
|
||||||
|
|
||||||
(library
|
(library
|
||||||
(name tezos_protocol_alpha_functor)
|
(name tezos_protocol_005_PsBabyM1_functor)
|
||||||
(public_name tezos-protocol-alpha.functor)
|
(public_name tezos-protocol-005-PsBabyM1.functor)
|
||||||
(libraries
|
(libraries
|
||||||
tezos-protocol-environment
|
tezos-protocol-environment
|
||||||
tezos-protocol-environment-sigs
|
tezos-protocol-environment-sigs
|
||||||
tezos_raw_protocol_alpha)
|
tezos_raw_protocol_005_PsBabyM1)
|
||||||
(flags -w "+a-4-6-7-9-29-40..42-44-45-48"
|
(flags -w "+a-4-6-7-9-29-40..42-44-45-48"
|
||||||
-warn-error "-a+8"
|
-warn-error "-a+8"
|
||||||
-nopervasives)
|
-nopervasives)
|
||||||
(modules Functor))
|
(modules Functor))
|
||||||
|
|
||||||
(library
|
(library
|
||||||
(name tezos_embedded_protocol_alpha)
|
(name tezos_embedded_protocol_005_PsBabyM1)
|
||||||
(public_name tezos-embedded-protocol-alpha)
|
(public_name tezos-embedded-protocol-005-PsBabyM1)
|
||||||
(library_flags (:standard -linkall))
|
(library_flags (:standard -linkall))
|
||||||
(libraries tezos-protocol-alpha
|
(libraries tezos-protocol-005-PsBabyM1
|
||||||
tezos-protocol-updater
|
tezos-protocol-updater
|
||||||
tezos-protocol-environment)
|
tezos-protocol-environment)
|
||||||
(flags (:standard -w +a-4-6-7-9-29-32-40..42-44-45-48
|
(flags (:standard -w +a-4-6-7-9-29-32-40..42-44-45-48
|
||||||
@ -106,4 +106,4 @@ include Tezos_raw_protocol_alpha.Main
|
|||||||
|
|
||||||
(alias
|
(alias
|
||||||
(name runtest_sandbox)
|
(name runtest_sandbox)
|
||||||
(deps .tezos_protocol_alpha.objs/native/tezos_protocol_alpha.cmx))
|
(deps .tezos_protocol_005_PsBabyM1.objs/native/tezos_protocol_005_PsBabyM1.cmx))
|
||||||
|
@ -97,7 +97,7 @@ let burn_storage_fees c ~storage_limit ~payer =
|
|||||||
else
|
else
|
||||||
trace Cannot_pay_storage_fee
|
trace Cannot_pay_storage_fee
|
||||||
(Contract_storage.must_exist c payer >>=? fun () ->
|
(Contract_storage.must_exist c payer >>=? fun () ->
|
||||||
Contract_storage.spend_from_script c payer to_burn) >>=? fun c ->
|
Contract_storage.spend c payer to_burn) >>=? fun c ->
|
||||||
return c
|
return c
|
||||||
|
|
||||||
let check_storage_limit c ~storage_limit =
|
let check_storage_limit c ~storage_limit =
|
||||||
|
@ -57,5 +57,10 @@ let to_int64 = function
|
|||||||
when Compare.String.
|
when Compare.String.
|
||||||
(MBytes.to_string version = Constants_repr.version_number) ->
|
(MBytes.to_string version = Constants_repr.version_number) ->
|
||||||
int64_of_bytes fitness
|
int64_of_bytes fitness
|
||||||
|
| [ version ;
|
||||||
|
_fitness (* ignored since higher version takes priority *) ]
|
||||||
|
when Compare.String.
|
||||||
|
(MBytes.to_string version = Constants_repr.version_number_004) ->
|
||||||
|
ok 0L
|
||||||
| [] -> ok 0L
|
| [] -> ok 0L
|
||||||
| _ -> error Invalid_fitness
|
| _ -> error Invalid_fitness
|
||||||
|
@ -27,6 +27,8 @@ type t =
|
|||||||
| Unaccounted
|
| Unaccounted
|
||||||
| Limited of { remaining : Z.t }
|
| Limited of { remaining : Z.t }
|
||||||
|
|
||||||
|
type internal_gas = Z.t
|
||||||
|
|
||||||
type cost =
|
type cost =
|
||||||
{ allocations : Z.t ;
|
{ allocations : Z.t ;
|
||||||
steps : Z.t ;
|
steps : Z.t ;
|
||||||
@ -90,37 +92,60 @@ let write_base_weight = Z.of_int 160
|
|||||||
let byte_read_weight = Z.of_int 10
|
let byte_read_weight = Z.of_int 10
|
||||||
let byte_written_weight = Z.of_int 15
|
let byte_written_weight = Z.of_int 15
|
||||||
|
|
||||||
let consume block_gas operation_gas cost = match operation_gas with
|
let rescaling_bits = 7
|
||||||
| Unaccounted -> ok (block_gas, Unaccounted)
|
let rescaling_mask =
|
||||||
| Limited { remaining } ->
|
Z.sub (Z.shift_left Z.one rescaling_bits) Z.one
|
||||||
let weighted_cost =
|
|
||||||
|
let scale (z : Z.t) = Z.shift_left z rescaling_bits
|
||||||
|
let rescale (z : Z.t) = Z.shift_right z rescaling_bits
|
||||||
|
|
||||||
|
let cost_to_internal_gas (cost : cost) : internal_gas =
|
||||||
Z.add
|
Z.add
|
||||||
(Z.add
|
(Z.add
|
||||||
(Z.mul allocation_weight cost.allocations)
|
(Z.mul cost.allocations allocation_weight)
|
||||||
(Z.mul step_weight cost.steps))
|
(Z.mul cost.steps step_weight))
|
||||||
(Z.add
|
(Z.add
|
||||||
(Z.add
|
(Z.add
|
||||||
(Z.mul read_base_weight cost.reads)
|
(Z.mul cost.reads read_base_weight)
|
||||||
(Z.mul write_base_weight cost.writes))
|
(Z.mul cost.writes write_base_weight))
|
||||||
(Z.add
|
(Z.add
|
||||||
(Z.mul byte_read_weight cost.bytes_read)
|
(Z.mul cost.bytes_read byte_read_weight)
|
||||||
(Z.mul byte_written_weight cost.bytes_written))) in
|
(Z.mul cost.bytes_written byte_written_weight)))
|
||||||
|
|
||||||
|
let internal_gas_to_gas internal_gas : Z.t * internal_gas =
|
||||||
|
let gas = rescale internal_gas in
|
||||||
|
let rest = Z.logand internal_gas rescaling_mask in
|
||||||
|
(gas, rest)
|
||||||
|
|
||||||
|
let consume block_gas operation_gas internal_gas cost =
|
||||||
|
match operation_gas with
|
||||||
|
| Unaccounted -> ok (block_gas, Unaccounted, internal_gas)
|
||||||
|
| Limited { remaining } ->
|
||||||
|
let cost_internal_gas = cost_to_internal_gas cost in
|
||||||
|
let total_internal_gas =
|
||||||
|
Z.add cost_internal_gas internal_gas in
|
||||||
|
let gas, rest = internal_gas_to_gas total_internal_gas in
|
||||||
|
if Compare.Z.(gas > Z.zero) then
|
||||||
let remaining =
|
let remaining =
|
||||||
Z.sub remaining weighted_cost in
|
Z.sub remaining gas in
|
||||||
let block_remaining =
|
let block_remaining =
|
||||||
Z.sub block_gas weighted_cost in
|
Z.sub block_gas gas in
|
||||||
if Compare.Z.(remaining < Z.zero)
|
if Compare.Z.(remaining < Z.zero)
|
||||||
then error Operation_quota_exceeded
|
then error Operation_quota_exceeded
|
||||||
else if Compare.Z.(block_remaining < Z.zero)
|
else if Compare.Z.(block_remaining < Z.zero)
|
||||||
then error Block_quota_exceeded
|
then error Block_quota_exceeded
|
||||||
else ok (block_remaining, Limited { remaining })
|
else ok (block_remaining, Limited { remaining }, rest)
|
||||||
|
else
|
||||||
|
ok (block_gas, operation_gas, total_internal_gas)
|
||||||
|
|
||||||
let check_enough block_gas operation_gas cost =
|
let check_enough block_gas operation_gas internal_gas cost =
|
||||||
consume block_gas operation_gas cost
|
consume block_gas operation_gas internal_gas cost
|
||||||
>|? fun (_block_remainig, _remaining) -> ()
|
>|? fun (_block_remainig, _remaining, _internal_gas) -> ()
|
||||||
|
|
||||||
|
let internal_gas_zero : internal_gas = Z.zero
|
||||||
|
|
||||||
let alloc_cost n =
|
let alloc_cost n =
|
||||||
{ allocations = Z.of_int (n + 1) ;
|
{ allocations = scale (Z.of_int (n + 1)) ;
|
||||||
steps = Z.zero ;
|
steps = Z.zero ;
|
||||||
reads = Z.zero ;
|
reads = Z.zero ;
|
||||||
writes = Z.zero ;
|
writes = Z.zero ;
|
||||||
@ -133,9 +158,17 @@ let alloc_bytes_cost n =
|
|||||||
let alloc_bits_cost n =
|
let alloc_bits_cost n =
|
||||||
alloc_cost ((n + 63) / 64)
|
alloc_cost ((n + 63) / 64)
|
||||||
|
|
||||||
|
let atomic_step_cost n =
|
||||||
|
{ allocations = Z.zero ;
|
||||||
|
steps = Z.of_int (2 * n) ;
|
||||||
|
reads = Z.zero ;
|
||||||
|
writes = Z.zero ;
|
||||||
|
bytes_read = Z.zero ;
|
||||||
|
bytes_written = Z.zero }
|
||||||
|
|
||||||
let step_cost n =
|
let step_cost n =
|
||||||
{ allocations = Z.zero ;
|
{ allocations = Z.zero ;
|
||||||
steps = Z.of_int n ;
|
steps = scale (Z.of_int n) ;
|
||||||
reads = Z.zero ;
|
reads = Z.zero ;
|
||||||
writes = Z.zero ;
|
writes = Z.zero ;
|
||||||
bytes_read = Z.zero ;
|
bytes_read = Z.zero ;
|
||||||
@ -152,9 +185,9 @@ let free =
|
|||||||
let read_bytes_cost n =
|
let read_bytes_cost n =
|
||||||
{ allocations = Z.zero ;
|
{ allocations = Z.zero ;
|
||||||
steps = Z.zero ;
|
steps = Z.zero ;
|
||||||
reads = Z.one ;
|
reads = scale Z.one ;
|
||||||
writes = Z.zero ;
|
writes = Z.zero ;
|
||||||
bytes_read = n ;
|
bytes_read = scale n ;
|
||||||
bytes_written = Z.zero }
|
bytes_written = Z.zero }
|
||||||
|
|
||||||
let write_bytes_cost n =
|
let write_bytes_cost n =
|
||||||
@ -163,7 +196,7 @@ let write_bytes_cost n =
|
|||||||
reads = Z.zero ;
|
reads = Z.zero ;
|
||||||
writes = Z.one ;
|
writes = Z.one ;
|
||||||
bytes_read = Z.zero ;
|
bytes_read = Z.zero ;
|
||||||
bytes_written = n }
|
bytes_written = scale n }
|
||||||
|
|
||||||
let ( +@ ) x y =
|
let ( +@ ) x y =
|
||||||
{ allocations = Z.add x.allocations y.allocations ;
|
{ allocations = Z.add x.allocations y.allocations ;
|
||||||
|
@ -27,6 +27,8 @@ type t =
|
|||||||
| Unaccounted
|
| Unaccounted
|
||||||
| Limited of { remaining : Z.t }
|
| Limited of { remaining : Z.t }
|
||||||
|
|
||||||
|
type internal_gas
|
||||||
|
|
||||||
val encoding : t Data_encoding.encoding
|
val encoding : t Data_encoding.encoding
|
||||||
val pp : Format.formatter -> t -> unit
|
val pp : Format.formatter -> t -> unit
|
||||||
|
|
||||||
@ -38,10 +40,13 @@ val pp_cost : Format.formatter -> cost -> unit
|
|||||||
type error += Block_quota_exceeded (* `Temporary *)
|
type error += Block_quota_exceeded (* `Temporary *)
|
||||||
type error += Operation_quota_exceeded (* `Temporary *)
|
type error += Operation_quota_exceeded (* `Temporary *)
|
||||||
|
|
||||||
val consume : Z.t -> t -> cost -> (Z.t * t) tzresult
|
val consume : Z.t -> t -> internal_gas -> cost -> (Z.t * t * internal_gas) tzresult
|
||||||
val check_enough : Z.t -> t -> cost -> unit tzresult
|
val check_enough : Z.t -> t -> internal_gas -> cost -> unit tzresult
|
||||||
|
|
||||||
|
val internal_gas_zero : internal_gas
|
||||||
|
|
||||||
val free : cost
|
val free : cost
|
||||||
|
val atomic_step_cost : int -> cost
|
||||||
val step_cost : int -> cost
|
val step_cost : int -> cost
|
||||||
val alloc_cost : int -> cost
|
val alloc_cost : int -> cost
|
||||||
val alloc_bytes_cost : int -> cost
|
val alloc_bytes_cost : int -> cost
|
||||||
|
@ -59,14 +59,16 @@ module Scripts = struct
|
|||||||
let path = RPC_path.(path / "scripts")
|
let path = RPC_path.(path / "scripts")
|
||||||
|
|
||||||
let run_code_input_encoding =
|
let run_code_input_encoding =
|
||||||
(obj7
|
(obj9
|
||||||
(req "script" Script.expr_encoding)
|
(req "script" Script.expr_encoding)
|
||||||
(req "storage" Script.expr_encoding)
|
(req "storage" Script.expr_encoding)
|
||||||
(req "input" Script.expr_encoding)
|
(req "input" Script.expr_encoding)
|
||||||
(req "amount" Tez.encoding)
|
(req "amount" Tez.encoding)
|
||||||
|
(req "chain_id" Chain_id.encoding)
|
||||||
(opt "source" Contract.encoding)
|
(opt "source" Contract.encoding)
|
||||||
(opt "payer" Contract.encoding)
|
(opt "payer" Contract.encoding)
|
||||||
(opt "gas" z))
|
(opt "gas" z)
|
||||||
|
(dft "entrypoint" string "default"))
|
||||||
|
|
||||||
let trace_encoding =
|
let trace_encoding =
|
||||||
def "scripted.trace" @@
|
def "scripted.trace" @@
|
||||||
@ -147,10 +149,39 @@ module Scripts = struct
|
|||||||
~description:
|
~description:
|
||||||
"Run an operation without signature checks"
|
"Run an operation without signature checks"
|
||||||
~query: RPC_query.empty
|
~query: RPC_query.empty
|
||||||
~input: Operation.encoding
|
~input: (obj2
|
||||||
|
(req "operation" Operation.encoding)
|
||||||
|
(req "chain_id" Chain_id.encoding))
|
||||||
~output: Apply_results.operation_data_and_metadata_encoding
|
~output: Apply_results.operation_data_and_metadata_encoding
|
||||||
RPC_path.(path / "run_operation")
|
RPC_path.(path / "run_operation")
|
||||||
|
|
||||||
|
let entrypoint_type =
|
||||||
|
RPC_service.post_service
|
||||||
|
~description: "Return the type of the given entrypoint"
|
||||||
|
~query: RPC_query.empty
|
||||||
|
~input: (obj2
|
||||||
|
(req "script" Script.expr_encoding)
|
||||||
|
(dft "entrypoint" string "default"))
|
||||||
|
~output: (obj1
|
||||||
|
(req "entrypoint_type" Script.expr_encoding))
|
||||||
|
RPC_path.(path / "entrypoint")
|
||||||
|
|
||||||
|
|
||||||
|
let list_entrypoints =
|
||||||
|
RPC_service.post_service
|
||||||
|
~description: "Return the list of entrypoints of the given script"
|
||||||
|
~query: RPC_query.empty
|
||||||
|
~input: (obj1
|
||||||
|
(req "script" Script.expr_encoding))
|
||||||
|
~output: (obj2
|
||||||
|
(dft "unreachable"
|
||||||
|
(Data_encoding.list
|
||||||
|
(obj1 (req "path" (Data_encoding.list Michelson_v1_primitives.prim_encoding))))
|
||||||
|
[])
|
||||||
|
(req "entrypoints"
|
||||||
|
(assoc Script.expr_encoding)))
|
||||||
|
RPC_path.(path / "entrypoints")
|
||||||
|
|
||||||
end
|
end
|
||||||
|
|
||||||
let register () =
|
let register () =
|
||||||
@ -163,14 +194,11 @@ module Scripts = struct
|
|||||||
| None -> assert false in
|
| None -> assert false in
|
||||||
Contract.originate ctxt dummy_contract
|
Contract.originate ctxt dummy_contract
|
||||||
~balance
|
~balance
|
||||||
~manager: Signature.Public_key_hash.zero
|
|
||||||
~delegate: None
|
~delegate: None
|
||||||
~spendable: false
|
|
||||||
~delegatable: false
|
|
||||||
~script: (script, None) >>=? fun ctxt ->
|
~script: (script, None) >>=? fun ctxt ->
|
||||||
return (ctxt, dummy_contract) in
|
return (ctxt, dummy_contract) in
|
||||||
register0 S.run_code begin fun ctxt ()
|
register0 S.run_code begin fun ctxt ()
|
||||||
(code, storage, parameter, amount, source, payer, gas) ->
|
(code, storage, parameter, amount, chain_id, source, payer, gas, entrypoint) ->
|
||||||
let storage = Script.lazy_expr storage in
|
let storage = Script.lazy_expr storage in
|
||||||
let code = Script.lazy_expr code in
|
let code = Script.lazy_expr code in
|
||||||
originate_dummy_contract ctxt { storage ; code } >>=? fun (ctxt, dummy_contract) ->
|
originate_dummy_contract ctxt { storage ; code } >>=? fun (ctxt, dummy_contract) ->
|
||||||
@ -183,17 +211,24 @@ module Scripts = struct
|
|||||||
| Some gas -> gas
|
| Some gas -> gas
|
||||||
| None -> Constants.hard_gas_limit_per_operation ctxt in
|
| None -> Constants.hard_gas_limit_per_operation ctxt in
|
||||||
let ctxt = Gas.set_limit ctxt gas in
|
let ctxt = Gas.set_limit ctxt gas in
|
||||||
|
let step_constants =
|
||||||
|
let open Script_interpreter in
|
||||||
|
{ source ;
|
||||||
|
payer ;
|
||||||
|
self = dummy_contract ;
|
||||||
|
amount ;
|
||||||
|
chain_id } in
|
||||||
Script_interpreter.execute
|
Script_interpreter.execute
|
||||||
ctxt Readable
|
ctxt Readable
|
||||||
~source
|
step_constants
|
||||||
~payer
|
~script:{ storage ; code }
|
||||||
~self:(dummy_contract, { storage ; code })
|
~entrypoint
|
||||||
~amount ~parameter
|
~parameter
|
||||||
>>=? fun { Script_interpreter.storage ; operations ; big_map_diff ; _ } ->
|
>>=? fun { Script_interpreter.storage ; operations ; big_map_diff ; _ } ->
|
||||||
return (storage, operations, big_map_diff)
|
return (storage, operations, big_map_diff)
|
||||||
end ;
|
end ;
|
||||||
register0 S.trace_code begin fun ctxt ()
|
register0 S.trace_code begin fun ctxt ()
|
||||||
(code, storage, parameter, amount, source, payer, gas) ->
|
(code, storage, parameter, amount, chain_id, source, payer, gas, entrypoint) ->
|
||||||
let storage = Script.lazy_expr storage in
|
let storage = Script.lazy_expr storage in
|
||||||
let code = Script.lazy_expr code in
|
let code = Script.lazy_expr code in
|
||||||
originate_dummy_contract ctxt { storage ; code } >>=? fun (ctxt, dummy_contract) ->
|
originate_dummy_contract ctxt { storage ; code } >>=? fun (ctxt, dummy_contract) ->
|
||||||
@ -206,12 +241,19 @@ module Scripts = struct
|
|||||||
| Some gas -> gas
|
| Some gas -> gas
|
||||||
| None -> Constants.hard_gas_limit_per_operation ctxt in
|
| None -> Constants.hard_gas_limit_per_operation ctxt in
|
||||||
let ctxt = Gas.set_limit ctxt gas in
|
let ctxt = Gas.set_limit ctxt gas in
|
||||||
|
let step_constants =
|
||||||
|
let open Script_interpreter in
|
||||||
|
{ source ;
|
||||||
|
payer ;
|
||||||
|
self = dummy_contract ;
|
||||||
|
amount ;
|
||||||
|
chain_id } in
|
||||||
Script_interpreter.trace
|
Script_interpreter.trace
|
||||||
ctxt Readable
|
ctxt Readable
|
||||||
~source
|
step_constants
|
||||||
~payer
|
~script:{ storage ; code }
|
||||||
~self:(dummy_contract, { storage ; code })
|
~entrypoint
|
||||||
~amount ~parameter
|
~parameter
|
||||||
>>=? fun ({ Script_interpreter.storage ; operations ; big_map_diff ; _ }, trace) ->
|
>>=? fun ({ Script_interpreter.storage ; operations ; big_map_diff ; _ }, trace) ->
|
||||||
return (storage, operations, trace, big_map_diff)
|
return (storage, operations, trace, big_map_diff)
|
||||||
end ;
|
end ;
|
||||||
@ -234,13 +276,13 @@ module Scripts = struct
|
|||||||
let ctxt = match maybe_gas with
|
let ctxt = match maybe_gas with
|
||||||
| None -> Gas.set_unlimited ctxt
|
| None -> Gas.set_unlimited ctxt
|
||||||
| Some gas -> Gas.set_limit ctxt gas in
|
| Some gas -> Gas.set_limit ctxt gas in
|
||||||
Lwt.return (parse_ty ctxt ~allow_big_map:false ~allow_operation:false (Micheline.root typ)) >>=? fun (Ex_ty typ, ctxt) ->
|
Lwt.return (parse_packable_ty ctxt ~legacy:true (Micheline.root typ)) >>=? fun (Ex_ty typ, ctxt) ->
|
||||||
parse_data ctxt typ (Micheline.root expr) >>=? fun (data, ctxt) ->
|
parse_data ctxt ~legacy:true typ (Micheline.root expr) >>=? fun (data, ctxt) ->
|
||||||
Script_ir_translator.pack_data ctxt typ data >>=? fun (bytes, ctxt) ->
|
Script_ir_translator.pack_data ctxt typ data >>=? fun (bytes, ctxt) ->
|
||||||
return (bytes, Gas.level ctxt)
|
return (bytes, Gas.level ctxt)
|
||||||
end ;
|
end ;
|
||||||
register0 S.run_operation begin fun ctxt ()
|
register0 S.run_operation begin fun ctxt ()
|
||||||
{ shell ; protocol_data = Operation_data protocol_data } ->
|
({ shell ; protocol_data = Operation_data protocol_data }, chain_id) ->
|
||||||
(* this code is a duplicate of Apply without signature check *)
|
(* this code is a duplicate of Apply without signature check *)
|
||||||
let partial_precheck_manager_contents
|
let partial_precheck_manager_contents
|
||||||
(type kind) ctxt (op : kind Kind.manager contents)
|
(type kind) ctxt (op : kind Kind.manager contents)
|
||||||
@ -249,15 +291,15 @@ module Scripts = struct
|
|||||||
Lwt.return (Gas.check_limit ctxt gas_limit) >>=? fun () ->
|
Lwt.return (Gas.check_limit ctxt gas_limit) >>=? fun () ->
|
||||||
let ctxt = Gas.set_limit ctxt gas_limit in
|
let ctxt = Gas.set_limit ctxt gas_limit in
|
||||||
Lwt.return (Fees.check_storage_limit ctxt storage_limit) >>=? fun () ->
|
Lwt.return (Fees.check_storage_limit ctxt storage_limit) >>=? fun () ->
|
||||||
Contract.must_be_allocated ctxt source >>=? fun () ->
|
Contract.must_be_allocated ctxt (Contract.implicit_contract source) >>=? fun () ->
|
||||||
Contract.check_counter_increment ctxt source counter >>=? fun () ->
|
Contract.check_counter_increment ctxt source counter >>=? fun () ->
|
||||||
begin
|
begin
|
||||||
match operation with
|
match operation with
|
||||||
| Reveal pk ->
|
| Reveal pk ->
|
||||||
Contract.reveal_manager_key ctxt source pk
|
Contract.reveal_manager_key ctxt source pk
|
||||||
| Transaction { parameters = Some arg ; _ } ->
|
| Transaction { parameters ; _ } ->
|
||||||
(* Here the data comes already deserialized, so we need to fake the deserialization to mimic apply *)
|
(* Here the data comes already deserialized, so we need to fake the deserialization to mimic apply *)
|
||||||
let arg_bytes = Data_encoding.Binary.to_bytes_exn Script.lazy_expr_encoding arg in
|
let arg_bytes = Data_encoding.Binary.to_bytes_exn Script.lazy_expr_encoding parameters in
|
||||||
let arg = match Data_encoding.Binary.of_bytes Script.lazy_expr_encoding arg_bytes with
|
let arg = match Data_encoding.Binary.of_bytes Script.lazy_expr_encoding arg_bytes with
|
||||||
| Some arg -> arg
|
| Some arg -> arg
|
||||||
| None -> assert false in
|
| None -> assert false in
|
||||||
@ -267,7 +309,7 @@ module Scripts = struct
|
|||||||
(* Fail if not enough gas for complete deserialization cost *)
|
(* Fail if not enough gas for complete deserialization cost *)
|
||||||
trace Apply.Gas_quota_exceeded_init_deserialize @@
|
trace Apply.Gas_quota_exceeded_init_deserialize @@
|
||||||
Script.force_decode ctxt arg >>|? fun (_arg, ctxt) -> ctxt
|
Script.force_decode ctxt arg >>|? fun (_arg, ctxt) -> ctxt
|
||||||
| Origination { script = Some script ; _ } ->
|
| Origination { script = script ; _ } ->
|
||||||
(* Here the data comes already deserialized, so we need to fake the deserialization to mimic apply *)
|
(* Here the data comes already deserialized, so we need to fake the deserialization to mimic apply *)
|
||||||
let script_bytes = Data_encoding.Binary.to_bytes_exn Script.encoding script in
|
let script_bytes = Data_encoding.Binary.to_bytes_exn Script.encoding script in
|
||||||
let script = match Data_encoding.Binary.of_bytes Script.encoding script_bytes with
|
let script = match Data_encoding.Binary.of_bytes Script.encoding script_bytes with
|
||||||
@ -287,7 +329,7 @@ module Scripts = struct
|
|||||||
Contract.get_manager_key ctxt source >>=? fun _public_key ->
|
Contract.get_manager_key ctxt source >>=? fun _public_key ->
|
||||||
(* signature check unplugged from here *)
|
(* signature check unplugged from here *)
|
||||||
Contract.increment_counter ctxt source >>=? fun ctxt ->
|
Contract.increment_counter ctxt source >>=? fun ctxt ->
|
||||||
Contract.spend ctxt source fee >>=? fun ctxt ->
|
Contract.spend ctxt (Contract.implicit_contract source) fee >>=? fun ctxt ->
|
||||||
return ctxt in
|
return ctxt in
|
||||||
let rec partial_precheck_manager_contents_list
|
let rec partial_precheck_manager_contents_list
|
||||||
: type kind.
|
: type kind.
|
||||||
@ -310,27 +352,61 @@ module Scripts = struct
|
|||||||
match protocol_data.contents with
|
match protocol_data.contents with
|
||||||
| Single (Manager_operation _) as op ->
|
| Single (Manager_operation _) as op ->
|
||||||
partial_precheck_manager_contents_list ctxt op >>=? fun ctxt ->
|
partial_precheck_manager_contents_list ctxt op >>=? fun ctxt ->
|
||||||
Apply.apply_manager_contents_list ctxt Optimized baker op >>= fun (_ctxt, result) ->
|
Apply.apply_manager_contents_list ctxt Optimized baker chain_id op >>= fun (_ctxt, result) ->
|
||||||
return result
|
return result
|
||||||
| Cons (Manager_operation _, _) as op ->
|
| Cons (Manager_operation _, _) as op ->
|
||||||
partial_precheck_manager_contents_list ctxt op >>=? fun ctxt ->
|
partial_precheck_manager_contents_list ctxt op >>=? fun ctxt ->
|
||||||
Apply.apply_manager_contents_list ctxt Optimized baker op >>= fun (_ctxt, result) ->
|
Apply.apply_manager_contents_list ctxt Optimized baker chain_id op >>= fun (_ctxt, result) ->
|
||||||
return result
|
return result
|
||||||
| _ ->
|
| _ ->
|
||||||
Apply.apply_contents_list
|
Apply.apply_contents_list
|
||||||
ctxt ~partial:true Chain_id.zero Optimized shell.branch baker operation
|
ctxt chain_id Optimized shell.branch baker operation
|
||||||
operation.protocol_data.contents >>=? fun (_ctxt, result) ->
|
operation.protocol_data.contents >>=? fun (_ctxt, result) ->
|
||||||
return result
|
return result
|
||||||
|
end;
|
||||||
|
register0 S.entrypoint_type begin fun ctxt () (expr, entrypoint) ->
|
||||||
|
let ctxt = Gas.set_unlimited ctxt in
|
||||||
|
let legacy = false in
|
||||||
|
let open Script_ir_translator in
|
||||||
|
Lwt.return
|
||||||
|
begin
|
||||||
|
parse_toplevel ~legacy expr >>? fun (arg_type, _, _, root_name) ->
|
||||||
|
parse_ty ctxt ~legacy
|
||||||
|
~allow_big_map:true ~allow_operation:false
|
||||||
|
~allow_contract:true arg_type >>? fun (Ex_ty arg_type, _) ->
|
||||||
|
Script_ir_translator.find_entrypoint ~root_name arg_type
|
||||||
|
entrypoint
|
||||||
|
end >>=? fun (_f , Ex_ty ty)->
|
||||||
|
unparse_ty ctxt ty >>=? fun (ty_node, _) ->
|
||||||
|
return (Micheline.strip_locations ty_node)
|
||||||
|
end ;
|
||||||
|
register0 S.list_entrypoints begin fun ctxt () expr ->
|
||||||
|
let ctxt = Gas.set_unlimited ctxt in
|
||||||
|
let legacy = false in
|
||||||
|
let open Script_ir_translator in
|
||||||
|
Lwt.return
|
||||||
|
begin
|
||||||
|
parse_toplevel ~legacy expr >>? fun (arg_type, _, _, root_name) ->
|
||||||
|
parse_ty ctxt ~legacy
|
||||||
|
~allow_big_map:true ~allow_operation:false
|
||||||
|
~allow_contract:true arg_type >>? fun (Ex_ty arg_type, _) ->
|
||||||
|
Script_ir_translator.list_entrypoints ~root_name arg_type ctxt
|
||||||
|
end >>=? fun (unreachable_entrypoint,map) ->
|
||||||
|
return
|
||||||
|
(unreachable_entrypoint,
|
||||||
|
Entrypoints_map.fold
|
||||||
|
begin fun entry (_,ty) acc ->
|
||||||
|
(entry , Micheline.strip_locations ty) ::acc end
|
||||||
|
map [])
|
||||||
end
|
end
|
||||||
|
|
||||||
let run_code ctxt block code (storage, input, amount, source, payer, gas) =
|
let run_code ctxt block code (storage, input, amount, chain_id, source, payer, gas, entrypoint) =
|
||||||
RPC_context.make_call0 S.run_code ctxt
|
RPC_context.make_call0 S.run_code ctxt
|
||||||
block () (code, storage, input, amount, source, payer, gas)
|
block () (code, storage, input, amount, chain_id, source, payer, gas, entrypoint)
|
||||||
|
|
||||||
let trace_code ctxt block code (storage, input, amount, source, payer, gas) =
|
let trace_code ctxt block code (storage, input, amount, chain_id, source, payer, gas, entrypoint) =
|
||||||
RPC_context.make_call0 S.trace_code ctxt
|
RPC_context.make_call0 S.trace_code ctxt
|
||||||
block () (code, storage, input, amount, source, payer, gas)
|
block () (code, storage, input, amount, chain_id, source, payer, gas, entrypoint)
|
||||||
|
|
||||||
let typecheck_code ctxt block =
|
let typecheck_code ctxt block =
|
||||||
RPC_context.make_call0 S.typecheck_code ctxt block ()
|
RPC_context.make_call0 S.typecheck_code ctxt block ()
|
||||||
@ -344,6 +420,13 @@ module Scripts = struct
|
|||||||
let run_operation ctxt block =
|
let run_operation ctxt block =
|
||||||
RPC_context.make_call0 S.run_operation ctxt block ()
|
RPC_context.make_call0 S.run_operation ctxt block ()
|
||||||
|
|
||||||
|
let entrypoint_type ctxt block =
|
||||||
|
RPC_context.make_call0 S.entrypoint_type ctxt block ()
|
||||||
|
|
||||||
|
let list_entrypoints ctxt block =
|
||||||
|
RPC_context.make_call0 S.list_entrypoints ctxt block ()
|
||||||
|
|
||||||
|
|
||||||
end
|
end
|
||||||
|
|
||||||
module Forge = struct
|
module Forge = struct
|
||||||
@ -403,7 +486,7 @@ module Forge = struct
|
|||||||
~gas_limit ~storage_limit operations =
|
~gas_limit ~storage_limit operations =
|
||||||
Contract_services.manager_key ctxt block source >>= function
|
Contract_services.manager_key ctxt block source >>= function
|
||||||
| Error _ as e -> Lwt.return e
|
| Error _ as e -> Lwt.return e
|
||||||
| Ok (_, revealed) ->
|
| Ok revealed ->
|
||||||
let ops =
|
let ops =
|
||||||
List.map
|
List.map
|
||||||
(fun (Manager operation) ->
|
(fun (Manager operation) ->
|
||||||
@ -431,28 +514,23 @@ module Forge = struct
|
|||||||
|
|
||||||
let transaction ctxt
|
let transaction ctxt
|
||||||
block ~branch ~source ?sourcePubKey ~counter
|
block ~branch ~source ?sourcePubKey ~counter
|
||||||
~amount ~destination ?parameters
|
~amount ~destination ?(entrypoint = "default") ?parameters
|
||||||
~gas_limit ~storage_limit ~fee ()=
|
~gas_limit ~storage_limit ~fee ()=
|
||||||
let parameters = Option.map ~f:Script.lazy_expr parameters in
|
let parameters = Option.unopt_map ~f:Script.lazy_expr ~default:Script.unit_parameter parameters in
|
||||||
operations ctxt block ~branch ~source ?sourcePubKey ~counter
|
operations ctxt block ~branch ~source ?sourcePubKey ~counter
|
||||||
~fee ~gas_limit ~storage_limit
|
~fee ~gas_limit ~storage_limit
|
||||||
[Manager (Transaction { amount ; parameters ; destination })]
|
[Manager (Transaction { amount ; parameters ; destination ; entrypoint })]
|
||||||
|
|
||||||
let origination ctxt
|
let origination ctxt
|
||||||
block ~branch
|
block ~branch
|
||||||
~source ?sourcePubKey ~counter
|
~source ?sourcePubKey ~counter
|
||||||
~managerPubKey ~balance
|
~balance
|
||||||
?(spendable = true)
|
?delegatePubKey ~script
|
||||||
?(delegatable = true)
|
|
||||||
?delegatePubKey ?script
|
|
||||||
~gas_limit ~storage_limit ~fee () =
|
~gas_limit ~storage_limit ~fee () =
|
||||||
operations ctxt block ~branch ~source ?sourcePubKey ~counter
|
operations ctxt block ~branch ~source ?sourcePubKey ~counter
|
||||||
~fee ~gas_limit ~storage_limit
|
~fee ~gas_limit ~storage_limit
|
||||||
[Manager (Origination { manager = managerPubKey ;
|
[Manager (Origination { delegate = delegatePubKey ;
|
||||||
delegate = delegatePubKey ;
|
|
||||||
script ;
|
script ;
|
||||||
spendable ;
|
|
||||||
delegatable ;
|
|
||||||
credit = balance ;
|
credit = balance ;
|
||||||
preorigination = None })]
|
preorigination = None })]
|
||||||
|
|
||||||
|
@ -40,7 +40,7 @@ module Scripts : sig
|
|||||||
val run_code:
|
val run_code:
|
||||||
'a #RPC_context.simple ->
|
'a #RPC_context.simple ->
|
||||||
'a -> Script.expr ->
|
'a -> Script.expr ->
|
||||||
(Script.expr * Script.expr * Tez.t * Contract.t option * Contract.t option * Z.t option) ->
|
(Script.expr * Script.expr * Tez.t * Chain_id.t * Contract.t option * Contract.t option * Z.t option * string) ->
|
||||||
(Script.expr *
|
(Script.expr *
|
||||||
packed_internal_operation list *
|
packed_internal_operation list *
|
||||||
Contract.big_map_diff option) shell_tzresult Lwt.t
|
Contract.big_map_diff option) shell_tzresult Lwt.t
|
||||||
@ -48,7 +48,7 @@ module Scripts : sig
|
|||||||
val trace_code:
|
val trace_code:
|
||||||
'a #RPC_context.simple ->
|
'a #RPC_context.simple ->
|
||||||
'a -> Script.expr ->
|
'a -> Script.expr ->
|
||||||
(Script.expr * Script.expr * Tez.t * Contract.t option * Contract.t option* Z.t option) ->
|
(Script.expr * Script.expr * Tez.t * Chain_id.t * Contract.t option * Contract.t option * Z.t option * string) ->
|
||||||
(Script.expr *
|
(Script.expr *
|
||||||
packed_internal_operation list *
|
packed_internal_operation list *
|
||||||
Script_interpreter.execution_trace *
|
Script_interpreter.execution_trace *
|
||||||
@ -69,9 +69,19 @@ module Scripts : sig
|
|||||||
|
|
||||||
val run_operation:
|
val run_operation:
|
||||||
'a #RPC_context.simple ->
|
'a #RPC_context.simple ->
|
||||||
'a -> packed_operation ->
|
'a -> packed_operation * Chain_id.t ->
|
||||||
(packed_protocol_data * Apply_results.packed_operation_metadata) shell_tzresult Lwt.t
|
(packed_protocol_data * Apply_results.packed_operation_metadata) shell_tzresult Lwt.t
|
||||||
|
|
||||||
|
val entrypoint_type:
|
||||||
|
'a #RPC_context.simple ->
|
||||||
|
'a -> Script.expr * string -> Script.expr shell_tzresult Lwt.t
|
||||||
|
|
||||||
|
val list_entrypoints:
|
||||||
|
'a #RPC_context.simple ->
|
||||||
|
'a -> Script.expr ->
|
||||||
|
(Michelson_v1_primitives.prim list list *
|
||||||
|
(string * Script.expr) list) shell_tzresult Lwt.t
|
||||||
|
|
||||||
end
|
end
|
||||||
|
|
||||||
module Forge : sig
|
module Forge : sig
|
||||||
@ -81,7 +91,7 @@ module Forge : sig
|
|||||||
val operations:
|
val operations:
|
||||||
'a #RPC_context.simple -> 'a ->
|
'a #RPC_context.simple -> 'a ->
|
||||||
branch:Block_hash.t ->
|
branch:Block_hash.t ->
|
||||||
source:Contract.t ->
|
source:public_key_hash ->
|
||||||
?sourcePubKey:public_key ->
|
?sourcePubKey:public_key ->
|
||||||
counter:counter ->
|
counter:counter ->
|
||||||
fee:Tez.t ->
|
fee:Tez.t ->
|
||||||
@ -92,7 +102,7 @@ module Forge : sig
|
|||||||
val reveal:
|
val reveal:
|
||||||
'a #RPC_context.simple -> 'a ->
|
'a #RPC_context.simple -> 'a ->
|
||||||
branch:Block_hash.t ->
|
branch:Block_hash.t ->
|
||||||
source:Contract.t ->
|
source:public_key_hash ->
|
||||||
sourcePubKey:public_key ->
|
sourcePubKey:public_key ->
|
||||||
counter:counter ->
|
counter:counter ->
|
||||||
fee:Tez.t ->
|
fee:Tez.t ->
|
||||||
@ -101,11 +111,12 @@ module Forge : sig
|
|||||||
val transaction:
|
val transaction:
|
||||||
'a #RPC_context.simple -> 'a ->
|
'a #RPC_context.simple -> 'a ->
|
||||||
branch:Block_hash.t ->
|
branch:Block_hash.t ->
|
||||||
source:Contract.t ->
|
source:public_key_hash ->
|
||||||
?sourcePubKey:public_key ->
|
?sourcePubKey:public_key ->
|
||||||
counter:counter ->
|
counter:counter ->
|
||||||
amount:Tez.t ->
|
amount:Tez.t ->
|
||||||
destination:Contract.t ->
|
destination:Contract.t ->
|
||||||
|
?entrypoint:string ->
|
||||||
?parameters:Script.expr ->
|
?parameters:Script.expr ->
|
||||||
gas_limit:Z.t ->
|
gas_limit:Z.t ->
|
||||||
storage_limit:Z.t ->
|
storage_limit:Z.t ->
|
||||||
@ -115,15 +126,12 @@ module Forge : sig
|
|||||||
val origination:
|
val origination:
|
||||||
'a #RPC_context.simple -> 'a ->
|
'a #RPC_context.simple -> 'a ->
|
||||||
branch:Block_hash.t ->
|
branch:Block_hash.t ->
|
||||||
source:Contract.t ->
|
source:public_key_hash ->
|
||||||
?sourcePubKey:public_key ->
|
?sourcePubKey:public_key ->
|
||||||
counter:counter ->
|
counter:counter ->
|
||||||
managerPubKey:public_key_hash ->
|
|
||||||
balance:Tez.t ->
|
balance:Tez.t ->
|
||||||
?spendable:bool ->
|
|
||||||
?delegatable:bool ->
|
|
||||||
?delegatePubKey: public_key_hash ->
|
?delegatePubKey: public_key_hash ->
|
||||||
?script:Script.t ->
|
script:Script.t ->
|
||||||
gas_limit:Z.t ->
|
gas_limit:Z.t ->
|
||||||
storage_limit:Z.t ->
|
storage_limit:Z.t ->
|
||||||
fee:Tez.t->
|
fee:Tez.t->
|
||||||
@ -132,7 +140,7 @@ module Forge : sig
|
|||||||
val delegation:
|
val delegation:
|
||||||
'a #RPC_context.simple -> 'a ->
|
'a #RPC_context.simple -> 'a ->
|
||||||
branch:Block_hash.t ->
|
branch:Block_hash.t ->
|
||||||
source:Contract.t ->
|
source:public_key_hash ->
|
||||||
?sourcePubKey:public_key ->
|
?sourcePubKey:public_key ->
|
||||||
counter:counter ->
|
counter:counter ->
|
||||||
fee:Tez.t ->
|
fee:Tez.t ->
|
||||||
|
@ -2,6 +2,7 @@
|
|||||||
(* *)
|
(* *)
|
||||||
(* Open Source License *)
|
(* Open Source License *)
|
||||||
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
|
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
|
||||||
|
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com> *)
|
||||||
(* *)
|
(* *)
|
||||||
(* Permission is hereby granted, free of charge, to any person obtaining a *)
|
(* Permission is hereby granted, free of charge, to any person obtaining a *)
|
||||||
(* copy of this software and associated documentation files (the "Software"),*)
|
(* copy of this software and associated documentation files (the "Software"),*)
|
||||||
@ -23,10 +24,324 @@
|
|||||||
(* *)
|
(* *)
|
||||||
(*****************************************************************************)
|
(*****************************************************************************)
|
||||||
|
|
||||||
(* This is the genesis protocol: initialise the state *)
|
(* Delegated storage changed type of value from Contract_hash to
|
||||||
|
Contract_repr. Move all 'delegated' data into a storage with
|
||||||
|
the original type, then copy over into the new storage. *)
|
||||||
|
let migrate_delegated ctxt contract =
|
||||||
|
let path = "contracts" :: (* module Contract *)
|
||||||
|
"index" :: (* module Indexed_context *)
|
||||||
|
Contract_repr.Index.to_path contract [
|
||||||
|
"delegated" ; (* module Delegated *)
|
||||||
|
] in
|
||||||
|
let path_tmp = "contracts" :: (* module Contract *)
|
||||||
|
"index" :: (* module Indexed_context *)
|
||||||
|
Contract_repr.Index.to_path contract [
|
||||||
|
"delegated_004" ; (* module Delegated *)
|
||||||
|
] in
|
||||||
|
Raw_context.dir_mem ctxt path >>= fun exists ->
|
||||||
|
if exists then
|
||||||
|
Raw_context.copy ctxt path path_tmp >>=? fun ctxt ->
|
||||||
|
Raw_context.remove_rec ctxt path >>= fun ctxt ->
|
||||||
|
Storage.Contract.Delegated_004.fold (ctxt, contract) ~init:(Ok ctxt) ~f:(fun delegated ctxt ->
|
||||||
|
Lwt.return ctxt >>=? fun ctxt ->
|
||||||
|
let originated = Contract_repr.originated_contract_004 delegated in
|
||||||
|
Storage.Contract.Delegated.add (ctxt, contract) originated >>= fun ctxt ->
|
||||||
|
return ctxt
|
||||||
|
) >>=? fun ctxt ->
|
||||||
|
Raw_context.remove_rec ctxt path_tmp >>= fun ctxt ->
|
||||||
|
return ctxt
|
||||||
|
else
|
||||||
|
return ctxt
|
||||||
|
|
||||||
|
let transform_script:
|
||||||
|
(manager_pkh: Signature.Public_key_hash.t ->
|
||||||
|
script_code: Script_repr.lazy_expr ->
|
||||||
|
script_storage: Script_repr.lazy_expr ->
|
||||||
|
(Script_repr.lazy_expr * Script_repr.lazy_expr) tzresult Lwt.t) ->
|
||||||
|
manager_pkh: Signature.Public_key_hash.t ->
|
||||||
|
Raw_context.t ->
|
||||||
|
Contract_repr.t ->
|
||||||
|
Script_repr.lazy_expr ->
|
||||||
|
Raw_context.t tzresult Lwt.t =
|
||||||
|
fun transformation ~manager_pkh ctxt contract code ->
|
||||||
|
Storage.Contract.Storage.get ctxt contract >>=? fun (_ctxt, storage) ->
|
||||||
|
transformation manager_pkh code storage >>=? fun (migrated_code, migrated_storage) ->
|
||||||
|
(* Set the migrated script code for free *)
|
||||||
|
Storage.Contract.Code.set_free ctxt contract migrated_code >>=? fun (ctxt, code_size_diff) ->
|
||||||
|
(* Set the migrated script storage for free *)
|
||||||
|
Storage.Contract.Storage.set_free ctxt contract migrated_storage >>=? fun (ctxt, storage_size_diff) ->
|
||||||
|
Storage.Contract.Used_storage_space.get ctxt contract >>=? fun used_space ->
|
||||||
|
let total_size = Z.(add (of_int code_size_diff) (add (of_int storage_size_diff) used_space)) in
|
||||||
|
(* Free storage space for migrated contracts *)
|
||||||
|
Storage.Contract.Used_storage_space.set ctxt contract total_size >>=? fun ctxt ->
|
||||||
|
Storage.Contract.Paid_storage_space.get ctxt contract >>=? fun paid_space ->
|
||||||
|
if Compare.Z.(paid_space < total_size) then
|
||||||
|
Storage.Contract.Paid_storage_space.set ctxt contract total_size >>=? fun ctxt ->
|
||||||
|
return ctxt
|
||||||
|
else
|
||||||
|
return ctxt
|
||||||
|
|
||||||
|
let manager_script_storage: Signature.Public_key_hash.t -> Script_repr.lazy_expr =
|
||||||
|
fun manager_pkh ->
|
||||||
|
let open Micheline in
|
||||||
|
Script_repr.lazy_expr @@ strip_locations @@
|
||||||
|
(* store in optimized binary representation - as unparsed with [Optimized]. *)
|
||||||
|
let bytes = Data_encoding.Binary.to_bytes_exn Signature.Public_key_hash.encoding manager_pkh in
|
||||||
|
Bytes (0, bytes)
|
||||||
|
|
||||||
|
(* If the given contract is not allocated, we'll allocate it with 1 mutez,
|
||||||
|
so that the migrated contracts' managers don't have to pay origination burn *)
|
||||||
|
let allocate_contract ctxt contract =
|
||||||
|
Contract_storage.allocated ctxt contract >>=? function
|
||||||
|
| true ->
|
||||||
|
return ctxt
|
||||||
|
| false ->
|
||||||
|
Contract_storage.credit ctxt contract Tez_repr.one_mutez
|
||||||
|
|
||||||
|
(* Process an individual contract *)
|
||||||
|
let process_contract_add_manager contract ctxt =
|
||||||
|
let open Legacy_script_support_repr in
|
||||||
|
match Contract_repr.is_originated contract with
|
||||||
|
| None -> return ctxt (* Only process originated contracts *)
|
||||||
|
| Some _ -> begin
|
||||||
|
Storage.Contract.Counter.remove ctxt contract >>= fun ctxt ->
|
||||||
|
Storage.Contract.Spendable_004.mem ctxt contract >>= fun is_spendable ->
|
||||||
|
Storage.Contract.Delegatable_004.mem ctxt contract >>= fun is_delegatable ->
|
||||||
|
Storage.Contract.Spendable_004.del ctxt contract >>= fun ctxt ->
|
||||||
|
Storage.Contract.Delegatable_004.del ctxt contract >>= fun ctxt ->
|
||||||
|
(* Try to get script code (ignore ctxt update to discard the initialization) *)
|
||||||
|
Storage.Contract.Code.get_option ctxt contract >>=? fun (_ctxt, code) ->
|
||||||
|
(* Get the manager of the originated contract *)
|
||||||
|
Contract_storage.get_manager_004 ctxt contract >>=? fun manager_pkh ->
|
||||||
|
let manager = Contract_repr.implicit_contract manager_pkh in
|
||||||
|
Storage.Contract.Manager.remove ctxt contract >>= fun ctxt ->
|
||||||
|
match code with
|
||||||
|
| Some code ->
|
||||||
|
(*
|
||||||
|
| spendable | delegatable | template |
|
||||||
|
|-----------+-------------+------------------|
|
||||||
|
| true | true | add_do |
|
||||||
|
| true | false | add_do |
|
||||||
|
| false | true | add_set_delegate |
|
||||||
|
| false | false | nothing |
|
||||||
|
*)
|
||||||
|
if is_spendable then
|
||||||
|
transform_script add_do ~manager_pkh ctxt contract code >>=? fun ctxt ->
|
||||||
|
allocate_contract ctxt manager
|
||||||
|
else if is_delegatable then
|
||||||
|
transform_script add_set_delegate ~manager_pkh ctxt contract code >>=? fun ctxt ->
|
||||||
|
allocate_contract ctxt manager
|
||||||
|
else if has_default_entrypoint code then
|
||||||
|
transform_script
|
||||||
|
(fun ~manager_pkh:_ ~script_code ~script_storage ->
|
||||||
|
add_root_entrypoint script_code >>=? fun script_code ->
|
||||||
|
return (script_code, script_storage))
|
||||||
|
~manager_pkh ctxt contract code
|
||||||
|
else
|
||||||
|
return ctxt
|
||||||
|
| None -> begin
|
||||||
|
(* Initialize the script code for free *)
|
||||||
|
Storage.Contract.Code.init_free ctxt contract manager_script_code >>=? fun (ctxt, code_size) ->
|
||||||
|
let storage = manager_script_storage manager_pkh in
|
||||||
|
(* Initialize the script storage for free *)
|
||||||
|
Storage.Contract.Storage.init_free ctxt contract storage >>=? fun (ctxt, storage_size) ->
|
||||||
|
let total_size = Z.(add (of_int code_size) (of_int storage_size)) in
|
||||||
|
(* Free storage space for migrated contracts *)
|
||||||
|
Storage.Contract.Paid_storage_space.init_set ctxt contract total_size >>= fun ctxt ->
|
||||||
|
Storage.Contract.Used_storage_space.init_set ctxt contract total_size >>= fun ctxt ->
|
||||||
|
allocate_contract ctxt manager
|
||||||
|
end
|
||||||
|
end
|
||||||
|
|
||||||
|
(* The [[update_contract_script]] function returns a copy of its
|
||||||
|
argument (the Micheline AST of a contract script) with "ADDRESS"
|
||||||
|
replaced by "ADDRESS; CHAIN_ID; PAIR".
|
||||||
|
|
||||||
|
[[Micheline.strip_locations]] should be called on the resulting
|
||||||
|
Micheline AST to get meaningful locations. *)
|
||||||
|
|
||||||
|
let rec update_contract_script : ('l, 'p) Micheline.node -> ('l, 'p) Micheline.node
|
||||||
|
= function
|
||||||
|
| Micheline.Seq (_,
|
||||||
|
Micheline.Prim (_, Michelson_v1_primitives.I_ADDRESS, [], []) ::
|
||||||
|
l) ->
|
||||||
|
Micheline.Seq (0,
|
||||||
|
Micheline.Prim (0, Michelson_v1_primitives.I_ADDRESS, [], []) ::
|
||||||
|
Micheline.Prim (0, Michelson_v1_primitives.I_CHAIN_ID, [], []) ::
|
||||||
|
Micheline.Prim (0, Michelson_v1_primitives.I_PAIR, [], []) :: l)
|
||||||
|
| Micheline.Seq (_, a :: l) ->
|
||||||
|
let a' = update_contract_script a in
|
||||||
|
let b = Micheline.Seq (0, l) in
|
||||||
|
let b' = update_contract_script b in
|
||||||
|
begin match b' with
|
||||||
|
| Micheline.Seq (_, l') ->
|
||||||
|
Micheline.Seq (0, a' :: l')
|
||||||
|
| _ -> assert false
|
||||||
|
end
|
||||||
|
| Micheline.Prim (_, p, l, annot) ->
|
||||||
|
Micheline.Prim (0, p, List.map update_contract_script l, annot)
|
||||||
|
| script -> script
|
||||||
|
|
||||||
|
let migrate_multisig_script (ctxt : Raw_context.t) (contract : Contract_repr.t)
|
||||||
|
(code : Script_repr.expr) : Raw_context.t tzresult Lwt.t =
|
||||||
|
let migrated_code =
|
||||||
|
Script_repr.lazy_expr @@ Micheline.strip_locations @@
|
||||||
|
update_contract_script @@ Micheline.root code
|
||||||
|
in
|
||||||
|
Storage.Contract.Code.set_free ctxt contract migrated_code >>=? fun (ctxt, _code_size_diff) ->
|
||||||
|
(* Set the spendable and delegatable flags to false so that no entrypoint gets added by
|
||||||
|
the [[process_contract_add_manager]] function. *)
|
||||||
|
Storage.Contract.Spendable_004.set ctxt contract false >>= fun ctxt ->
|
||||||
|
Storage.Contract.Delegatable_004.set ctxt contract false >>= fun ctxt ->
|
||||||
|
return ctxt
|
||||||
|
|
||||||
|
(* The hash of the multisig contract; only contracts with this exact
|
||||||
|
hash are going to be updated by the [[update_contract_script]]
|
||||||
|
function. *)
|
||||||
|
let multisig_hash : Script_expr_hash.t =
|
||||||
|
Script_expr_hash.of_bytes_exn @@
|
||||||
|
MBytes.of_hex @@
|
||||||
|
`Hex "475e37a6386d0b85890eb446db1faad67f85fc814724ad07473cac8c0a124b31"
|
||||||
|
|
||||||
|
let process_contract_multisig (contract : Contract_repr.t) (ctxt : Raw_context.t) =
|
||||||
|
Contract_storage.get_script ctxt contract >>=? fun (ctxt, script_opt) ->
|
||||||
|
match script_opt with
|
||||||
|
| None ->
|
||||||
|
(* Do nothing on scriptless contracts *)
|
||||||
|
return ctxt
|
||||||
|
| Some { Script_repr.code = code ; Script_repr.storage = _storage } ->
|
||||||
|
(* The contract has some script, only try to modify it if it has
|
||||||
|
the hash of the multisig contract *)
|
||||||
|
Lwt.return (Script_repr.force_decode code) >>=? fun (code, _gas_cost) ->
|
||||||
|
let bytes =
|
||||||
|
Data_encoding.Binary.to_bytes_exn Script_repr.expr_encoding code
|
||||||
|
in
|
||||||
|
let hash = Script_expr_hash.hash_bytes [ bytes ] in
|
||||||
|
if Script_expr_hash.(hash = multisig_hash) then
|
||||||
|
migrate_multisig_script ctxt contract code
|
||||||
|
else
|
||||||
|
return ctxt
|
||||||
|
|
||||||
|
(* Process an individual contract *)
|
||||||
|
let process_contract contract ctxt =
|
||||||
|
process_contract_multisig contract ctxt >>=? fun ctxt ->
|
||||||
|
process_contract_add_manager contract ctxt >>=? fun ctxt ->
|
||||||
|
return ctxt
|
||||||
|
|
||||||
|
let invoice_contract ctxt kt1_addr amount =
|
||||||
|
let amount = Tez_repr.of_mutez_exn (Int64.(mul 1_000_000L (of_int amount))) in
|
||||||
|
match Contract_repr.of_b58check kt1_addr with
|
||||||
|
| Ok recipient -> begin
|
||||||
|
Contract_storage.credit ctxt recipient amount >>= function
|
||||||
|
| Ok ctxt -> return ctxt
|
||||||
|
| Error _ -> return ctxt end
|
||||||
|
| Error _ -> return ctxt
|
||||||
|
|
||||||
|
(* Extract Big_maps from their parent contract directory,
|
||||||
|
recompute their used space, and assign them an ID. *)
|
||||||
|
let migrate_contract_big_map ctxt contract =
|
||||||
|
Storage.Contract.Code.get_option ctxt contract >>=? function
|
||||||
|
| ctxt, None -> return ctxt
|
||||||
|
| ctxt, Some code ->
|
||||||
|
Storage.Contract.Storage.get ctxt contract >>=? fun (ctxt, storage) ->
|
||||||
|
let extract_big_map_types expr =
|
||||||
|
let open Michelson_v1_primitives in
|
||||||
|
let open Micheline in
|
||||||
|
match Micheline.root expr with
|
||||||
|
| Seq (_, [ Prim (_, K_storage, [ expr ], _) ; _ ; _ ])
|
||||||
|
| Seq (_, [ _ ; Prim (_, K_storage, [ expr ], _) ; _ ])
|
||||||
|
| Seq (_, [ _ ; _ ; Prim (_, K_storage, [ expr ], _) ]) ->
|
||||||
|
begin match expr with
|
||||||
|
| Prim (_, T_pair, [ Prim (_, T_big_map, [ kt ; vt ], _ ) ; _ ], _) -> Some (kt, vt)
|
||||||
|
| _ -> None
|
||||||
|
end
|
||||||
|
| _ -> None in
|
||||||
|
let rewrite_big_map expr id =
|
||||||
|
let open Michelson_v1_primitives in
|
||||||
|
let open Micheline in
|
||||||
|
match Micheline.root expr with
|
||||||
|
| Prim (_, D_Pair, [ Seq (_, _ (* ignore_unused_origination_literal *)) ; pannot ], sannot) ->
|
||||||
|
Micheline.strip_locations (Prim (0, D_Pair, [ Int (0, id) ; pannot ], sannot))
|
||||||
|
| _ -> assert false in
|
||||||
|
Lwt.return (Script_repr.force_decode code) >>=? fun (code, _) ->
|
||||||
|
match extract_big_map_types code with
|
||||||
|
| None -> return ctxt
|
||||||
|
| Some (kt, vt) ->
|
||||||
|
Lwt.return (Script_repr.force_decode storage) >>=? fun (storage, _) ->
|
||||||
|
Storage.Big_map.Next.incr ctxt >>=? fun (ctxt, id) ->
|
||||||
|
let contract_path suffix =
|
||||||
|
"contracts" :: (* module Contract *)
|
||||||
|
"index" :: (* module Indexed_context *)
|
||||||
|
Contract_repr.Index.to_path contract suffix in
|
||||||
|
let old_path = contract_path [ "big_map" ] in
|
||||||
|
let storage = rewrite_big_map storage id in
|
||||||
|
Storage.Contract.Storage.set ctxt contract (Script_repr.lazy_expr storage) >>=? fun (ctxt, _) ->
|
||||||
|
let kt = Micheline.strip_locations (Script_repr.strip_annotations kt) in
|
||||||
|
let vt = Micheline.strip_locations (Script_repr.strip_annotations vt) in
|
||||||
|
Storage.Big_map.Key_type.init ctxt id kt >>=? fun ctxt ->
|
||||||
|
Storage.Big_map.Value_type.init ctxt id vt >>=? fun ctxt ->
|
||||||
|
Raw_context.dir_mem ctxt old_path >>= fun exists ->
|
||||||
|
if exists then
|
||||||
|
let read_size ctxt key =
|
||||||
|
Raw_context.get ctxt key >>=? fun len ->
|
||||||
|
match Data_encoding.(Binary.of_bytes int31) len with
|
||||||
|
| None -> assert false
|
||||||
|
| Some len -> return len in
|
||||||
|
let iter_sizes f (ctxt, acc) =
|
||||||
|
let rec dig i path (ctxt, acc) =
|
||||||
|
if Compare.Int.(i <= 0) then
|
||||||
|
Raw_context.fold ctxt path ~init:(ok (ctxt, acc)) ~f:begin fun k acc ->
|
||||||
|
Lwt.return acc >>=? fun (ctxt, acc) ->
|
||||||
|
match k with
|
||||||
|
| `Dir _ -> return (ctxt, acc)
|
||||||
|
| `Key file ->
|
||||||
|
match List.rev file with
|
||||||
|
| last :: _ when Compare.String.(last = "data") ->
|
||||||
|
return (ctxt, acc)
|
||||||
|
| last :: _ when Compare.String.(last = "len") ->
|
||||||
|
read_size ctxt file >>=? fun len ->
|
||||||
|
return (ctxt, f len acc)
|
||||||
|
| _ -> assert false
|
||||||
|
end
|
||||||
|
else
|
||||||
|
Raw_context.fold ctxt path ~init:(ok (ctxt, acc)) ~f:begin fun k acc ->
|
||||||
|
Lwt.return acc >>=? fun (ctxt, acc) ->
|
||||||
|
match k with
|
||||||
|
| `Dir k -> dig (i-1) k (ctxt, acc)
|
||||||
|
| `Key _ -> return (ctxt, acc)
|
||||||
|
end in
|
||||||
|
dig Script_expr_hash.path_length old_path (ctxt, acc) in
|
||||||
|
iter_sizes
|
||||||
|
(fun s acc -> (acc |> Z.add (Z.of_int s) |> Z.add (Z.of_int 65)))
|
||||||
|
(ctxt, (Z.of_int 0)) >>=? fun (ctxt, total_bytes) ->
|
||||||
|
Storage.Big_map.Total_bytes.init ctxt id total_bytes >>=? fun ctxt ->
|
||||||
|
let new_path = "big_maps" :: (* module Big_map *)
|
||||||
|
"index" :: (* module Indexed_context *)
|
||||||
|
Storage.Big_map.Index.to_path id [
|
||||||
|
"contents" ; (* module Delegated *)
|
||||||
|
] in
|
||||||
|
Raw_context.copy ctxt old_path new_path >>=? fun ctxt ->
|
||||||
|
Raw_context.remove_rec ctxt old_path >>= fun ctxt ->
|
||||||
|
read_size ctxt (contract_path [ "len" ; "code" ]) >>=? fun code_size ->
|
||||||
|
read_size ctxt (contract_path [ "len" ; "storage" ]) >>=? fun storage_size ->
|
||||||
|
let total_bytes =
|
||||||
|
total_bytes |>
|
||||||
|
Z.add (Z.of_int 33) |>
|
||||||
|
Z.add (Z.of_int code_size) |>
|
||||||
|
Z.add (Z.of_int storage_size) in
|
||||||
|
Storage.Contract.Used_storage_space.get ctxt contract >>=? fun previous_size ->
|
||||||
|
Storage.Contract.Paid_storage_space.get ctxt contract >>=? fun paid_bytes ->
|
||||||
|
let change = Z.sub paid_bytes previous_size in
|
||||||
|
Storage.Contract.Used_storage_space.set ctxt contract total_bytes >>=? fun ctxt ->
|
||||||
|
Storage.Contract.Paid_storage_space.set ctxt contract (Z.add total_bytes change)
|
||||||
|
else
|
||||||
|
Storage.Big_map.Total_bytes.init ctxt id Z.zero >>=? fun ctxt ->
|
||||||
|
return ctxt
|
||||||
|
|
||||||
let prepare_first_block ctxt ~typecheck ~level ~timestamp ~fitness =
|
let prepare_first_block ctxt ~typecheck ~level ~timestamp ~fitness =
|
||||||
Raw_context.prepare_first_block
|
Raw_context.prepare_first_block
|
||||||
~level ~timestamp ~fitness ctxt >>=? fun (previous_protocol, ctxt) ->
|
~level ~timestamp ~fitness ctxt >>=? fun (previous_protocol, ctxt) ->
|
||||||
|
Storage.Big_map.Next.init ctxt >>=? fun ctxt ->
|
||||||
match previous_protocol with
|
match previous_protocol with
|
||||||
| Genesis param ->
|
| Genesis param ->
|
||||||
Commitment_storage.init ctxt param.commitments >>=? fun ctxt ->
|
Commitment_storage.init ctxt param.commitments >>=? fun ctxt ->
|
||||||
@ -41,11 +356,24 @@ let prepare_first_block ctxt ~typecheck ~level ~timestamp ~fitness =
|
|||||||
param.bootstrap_contracts >>=? fun ctxt ->
|
param.bootstrap_contracts >>=? fun ctxt ->
|
||||||
Roll_storage.init_first_cycles ctxt >>=? fun ctxt ->
|
Roll_storage.init_first_cycles ctxt >>=? fun ctxt ->
|
||||||
Vote_storage.init ctxt >>=? fun ctxt ->
|
Vote_storage.init ctxt >>=? fun ctxt ->
|
||||||
Storage.Last_block_priority.init ctxt 0 >>=? fun ctxt ->
|
Storage.Block_priority.init ctxt 0 >>=? fun ctxt ->
|
||||||
Vote_storage.freeze_listings ctxt >>=? fun ctxt ->
|
Vote_storage.freeze_listings ctxt >>=? fun ctxt ->
|
||||||
return ctxt
|
return ctxt
|
||||||
| Alpha_previous ->
|
| Athens_004 ->
|
||||||
|
Storage.Vote.Current_quorum_004.get ctxt >>=? fun quorum ->
|
||||||
|
Storage.Vote.Participation_ema.init ctxt quorum >>=? fun ctxt ->
|
||||||
|
Storage.Vote.Current_quorum_004.delete ctxt >>=? fun ctxt ->
|
||||||
|
Storage.Block_priority.init ctxt 0 >>=? fun ctxt ->
|
||||||
|
Storage.Last_block_priority.delete ctxt >>=? fun ctxt ->
|
||||||
|
Storage.Contract.fold ctxt ~init:(Ok ctxt)
|
||||||
|
~f:(fun contract ctxt ->
|
||||||
|
Lwt.return ctxt >>=? fun ctxt ->
|
||||||
|
migrate_delegated ctxt contract >>=? fun ctxt ->
|
||||||
|
migrate_contract_big_map ctxt contract >>=? fun ctxt ->
|
||||||
|
process_contract contract ctxt)
|
||||||
|
>>=? fun ctxt ->
|
||||||
|
invoice_contract ctxt "KT1DUfaMfTRZZkvZAYQT5b3byXnvqoAykc43" 500 >>=? fun ctxt ->
|
||||||
return ctxt
|
return ctxt
|
||||||
|
|
||||||
let prepare ctxt ~level ~timestamp ~fitness =
|
let prepare ctxt ~level ~predecessor_timestamp ~timestamp ~fitness =
|
||||||
Raw_context.prepare ~level ~timestamp ~fitness ctxt
|
Raw_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt
|
||||||
|
532
vendors/ligo-utils/tezos-protocol-alpha/legacy_script_support_repr.ml
vendored
Normal file
532
vendors/ligo-utils/tezos-protocol-alpha/legacy_script_support_repr.ml
vendored
Normal file
@ -0,0 +1,532 @@
|
|||||||
|
(*****************************************************************************)
|
||||||
|
(* *)
|
||||||
|
(* Open Source License *)
|
||||||
|
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
|
||||||
|
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com> *)
|
||||||
|
(* Copyright (c) 2019 Cryptium Labs <contact@cryptium-labs.com> *)
|
||||||
|
(* *)
|
||||||
|
(* Permission is hereby granted, free of charge, to any person obtaining a *)
|
||||||
|
(* copy of this software and associated documentation files (the "Software"),*)
|
||||||
|
(* to deal in the Software without restriction, including without limitation *)
|
||||||
|
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
|
||||||
|
(* and/or sell copies of the Software, and to permit persons to whom the *)
|
||||||
|
(* Software is furnished to do so, subject to the following conditions: *)
|
||||||
|
(* *)
|
||||||
|
(* The above copyright notice and this permission notice shall be included *)
|
||||||
|
(* in all copies or substantial portions of the Software. *)
|
||||||
|
(* *)
|
||||||
|
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
|
||||||
|
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
|
||||||
|
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
|
||||||
|
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
|
||||||
|
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
|
||||||
|
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
|
||||||
|
(* DEALINGS IN THE SOFTWARE. *)
|
||||||
|
(* *)
|
||||||
|
(*****************************************************************************)
|
||||||
|
|
||||||
|
let manager_script_code: Script_repr.lazy_expr =
|
||||||
|
let open Micheline in
|
||||||
|
let open Michelson_v1_primitives in
|
||||||
|
Script_repr.lazy_expr @@ strip_locations @@
|
||||||
|
Seq (0, [
|
||||||
|
Prim (0, K_parameter, [
|
||||||
|
Prim (0, T_or, [
|
||||||
|
Prim (0, T_lambda, [
|
||||||
|
Prim (0, T_unit, [], []);
|
||||||
|
Prim (0, T_list, [
|
||||||
|
Prim (0, T_operation, [], [])
|
||||||
|
], [])
|
||||||
|
], ["%do"]);
|
||||||
|
Prim (0, T_unit, [], ["%default"])
|
||||||
|
], [])
|
||||||
|
], []);
|
||||||
|
Prim (0, K_storage, [
|
||||||
|
Prim (0, T_key_hash, [], [])
|
||||||
|
], []);
|
||||||
|
Prim (0, K_code, [
|
||||||
|
Seq (0, [
|
||||||
|
Seq (0, [
|
||||||
|
Seq (0, [
|
||||||
|
Prim (0, I_DUP, [], []);
|
||||||
|
Prim (0, I_CAR, [], []);
|
||||||
|
Prim (0, I_DIP, [
|
||||||
|
Seq (0, [
|
||||||
|
Prim (0, I_CDR, [], [])
|
||||||
|
])
|
||||||
|
], [])
|
||||||
|
])
|
||||||
|
]);
|
||||||
|
Prim (0, I_IF_LEFT, [
|
||||||
|
Seq (0, [
|
||||||
|
Prim (0, I_PUSH, [
|
||||||
|
Prim (0, T_mutez, [], []);
|
||||||
|
Int (0, Z.zero)
|
||||||
|
], []);
|
||||||
|
Prim (0, I_AMOUNT, [], []);
|
||||||
|
Seq (0, [
|
||||||
|
Seq (0, [
|
||||||
|
Prim (0, I_COMPARE, [], []);
|
||||||
|
Prim (0, I_EQ, [], [])
|
||||||
|
]);
|
||||||
|
Prim (0, I_IF, [
|
||||||
|
Seq (0, []);
|
||||||
|
Seq (0, [
|
||||||
|
Seq (0, [
|
||||||
|
Prim (0, I_UNIT, [], []);
|
||||||
|
Prim (0, I_FAILWITH, [], [])
|
||||||
|
])
|
||||||
|
])
|
||||||
|
], [])
|
||||||
|
]);
|
||||||
|
Seq (0, [
|
||||||
|
Prim (0, I_DIP, [
|
||||||
|
Seq (0, [
|
||||||
|
Prim (0, I_DUP, [], [])
|
||||||
|
])
|
||||||
|
], []);
|
||||||
|
Prim (0, I_SWAP, [], [])
|
||||||
|
]);
|
||||||
|
Prim (0, I_IMPLICIT_ACCOUNT, [], []);
|
||||||
|
Prim (0, I_ADDRESS, [], []);
|
||||||
|
Prim (0, I_SENDER, [], []);
|
||||||
|
Seq (0, [
|
||||||
|
Seq (0, [
|
||||||
|
Prim (0, I_COMPARE, [], []);
|
||||||
|
Prim (0, I_EQ, [], [])
|
||||||
|
]);
|
||||||
|
Prim (0, I_IF, [
|
||||||
|
Seq (0, []);
|
||||||
|
Seq (0, [
|
||||||
|
Seq (0, [
|
||||||
|
Prim (0, I_UNIT, [], []);
|
||||||
|
Prim (0, I_FAILWITH, [], [])
|
||||||
|
])
|
||||||
|
])
|
||||||
|
], [])
|
||||||
|
]);
|
||||||
|
Prim (0, I_UNIT, [], []);
|
||||||
|
Prim (0, I_EXEC, [], []);
|
||||||
|
Prim (0, I_PAIR, [], [])
|
||||||
|
]);
|
||||||
|
Seq (0, [
|
||||||
|
Prim (0, I_DROP, [], []);
|
||||||
|
Prim (0, I_NIL, [
|
||||||
|
Prim (0, T_operation, [], [])
|
||||||
|
], []);
|
||||||
|
Prim (0, I_PAIR, [], [])
|
||||||
|
])
|
||||||
|
], [])
|
||||||
|
])
|
||||||
|
], [])
|
||||||
|
])
|
||||||
|
|
||||||
|
(* Find the toplevel expression with a given prim type from list,
|
||||||
|
because they can be in arbitrary order. *)
|
||||||
|
let find_toplevel toplevel exprs =
|
||||||
|
let open Micheline in
|
||||||
|
let rec iter toplevel = function
|
||||||
|
| (Prim (_, prim, _, _) as found) :: _
|
||||||
|
when String.equal toplevel (Michelson_v1_primitives.string_of_prim prim) ->
|
||||||
|
Some found
|
||||||
|
| _ :: rest ->
|
||||||
|
iter toplevel rest
|
||||||
|
| [] ->
|
||||||
|
None in
|
||||||
|
iter (Michelson_v1_primitives.string_of_prim toplevel) exprs
|
||||||
|
|
||||||
|
let add_do:
|
||||||
|
manager_pkh: Signature.Public_key_hash.t ->
|
||||||
|
script_code: Script_repr.lazy_expr ->
|
||||||
|
script_storage: Script_repr.lazy_expr ->
|
||||||
|
(Script_repr.lazy_expr * Script_repr.lazy_expr) tzresult Lwt.t =
|
||||||
|
fun ~manager_pkh ~script_code ~script_storage ->
|
||||||
|
let open Micheline in
|
||||||
|
let open Michelson_v1_primitives in
|
||||||
|
Lwt.return (Script_repr.force_decode script_code) >>=? fun (script_code_expr, _gas_cost) ->
|
||||||
|
Lwt.return (Script_repr.force_decode script_storage) >>|? fun (script_storage_expr, _gas_cost) ->
|
||||||
|
let storage_expr = root script_storage_expr in
|
||||||
|
match root script_code_expr with
|
||||||
|
| Seq (_, toplevel)
|
||||||
|
-> begin
|
||||||
|
match find_toplevel K_parameter toplevel,
|
||||||
|
find_toplevel K_storage toplevel,
|
||||||
|
find_toplevel K_code toplevel with
|
||||||
|
Some (Prim (_, K_parameter, [
|
||||||
|
Prim (_, parameter_type, parameter_expr, parameter_annot)
|
||||||
|
], prim_param_annot)),
|
||||||
|
Some (Prim (_, K_storage, [
|
||||||
|
Prim (_, code_storage_type, code_storage_expr, code_storage_annot)
|
||||||
|
], k_storage_annot)),
|
||||||
|
Some (Prim (_, K_code, [code_expr], code_annot)) ->
|
||||||
|
(* Note that we intentionally don't deal with potential duplicate entrypoints in this migration as there already might be some in contracts that we don't touch. *)
|
||||||
|
|
||||||
|
let migrated_code =
|
||||||
|
Seq (0, [
|
||||||
|
Prim (0, K_parameter, [
|
||||||
|
Prim (0, T_or, [
|
||||||
|
Prim (0, T_lambda, [
|
||||||
|
Prim (0, T_unit, [], []);
|
||||||
|
Prim (0, T_list, [
|
||||||
|
Prim (0, T_operation, [], [])
|
||||||
|
], [])
|
||||||
|
], ["%do"]);
|
||||||
|
Prim (0, parameter_type, parameter_expr, "%default" :: parameter_annot)
|
||||||
|
], [])
|
||||||
|
], prim_param_annot);
|
||||||
|
Prim (0, K_storage, [
|
||||||
|
Prim (0, T_pair, [
|
||||||
|
Prim (0, T_key_hash, [], []);
|
||||||
|
Prim (0, code_storage_type, code_storage_expr, code_storage_annot)
|
||||||
|
], [])
|
||||||
|
], k_storage_annot);
|
||||||
|
Prim (0, K_code, [
|
||||||
|
Seq (0, [
|
||||||
|
Prim (0, I_DUP, [], []);
|
||||||
|
Prim (0, I_CAR, [], []);
|
||||||
|
Prim (0, I_IF_LEFT, [
|
||||||
|
Seq (0, [
|
||||||
|
Prim (0, I_PUSH, [
|
||||||
|
Prim (0, T_mutez, [], []);
|
||||||
|
Int (0, Z.zero)
|
||||||
|
], []);
|
||||||
|
Prim (0, I_AMOUNT, [], []);
|
||||||
|
Seq (0, [
|
||||||
|
Seq (0, [
|
||||||
|
Prim (0, I_COMPARE, [], []);
|
||||||
|
Prim (0, I_EQ, [], [])
|
||||||
|
]);
|
||||||
|
Prim (0, I_IF, [
|
||||||
|
Seq (0, []);
|
||||||
|
Seq (0, [
|
||||||
|
Seq (0, [
|
||||||
|
Prim (0, I_UNIT, [], []);
|
||||||
|
Prim (0, I_FAILWITH, [], [])
|
||||||
|
])
|
||||||
|
])
|
||||||
|
], [])
|
||||||
|
]);
|
||||||
|
Seq (0, [
|
||||||
|
Prim (0, I_DIP, [
|
||||||
|
Seq (0, [
|
||||||
|
Prim (0, I_DUP, [], [])
|
||||||
|
])
|
||||||
|
], []);
|
||||||
|
Prim (0, I_SWAP, [], [])
|
||||||
|
]);
|
||||||
|
Prim (0, I_CDR, [], []);
|
||||||
|
Prim (0, I_CAR, [], []);
|
||||||
|
Prim (0, I_IMPLICIT_ACCOUNT, [], []);
|
||||||
|
Prim (0, I_ADDRESS, [], []);
|
||||||
|
Prim (0, I_SENDER, [], []);
|
||||||
|
Seq (0, [
|
||||||
|
Prim (0, I_COMPARE, [], []);
|
||||||
|
Prim (0, I_NEQ, [], []);
|
||||||
|
Prim (0, I_IF, [
|
||||||
|
Seq (0, [
|
||||||
|
Prim (0, I_SENDER, [], []);
|
||||||
|
Prim (0, I_PUSH, [
|
||||||
|
Prim (0, T_string, [], []);
|
||||||
|
String (0, "Only the owner can operate.")
|
||||||
|
], []);
|
||||||
|
Prim (0, I_PAIR, [], []);
|
||||||
|
Prim (0, I_FAILWITH, [], [])
|
||||||
|
]);
|
||||||
|
Seq (0, [
|
||||||
|
Prim (0, I_UNIT, [], []);
|
||||||
|
Prim (0, I_EXEC, [], []);
|
||||||
|
Prim (0, I_DIP, [
|
||||||
|
Seq (0, [
|
||||||
|
Prim (0, I_CDR, [], [])
|
||||||
|
])
|
||||||
|
], []);
|
||||||
|
Prim (0, I_PAIR, [], [])
|
||||||
|
])
|
||||||
|
], [])
|
||||||
|
])
|
||||||
|
]);
|
||||||
|
Seq (0, [
|
||||||
|
Prim (0, I_DIP, [
|
||||||
|
Seq (0, [
|
||||||
|
Prim (0, I_CDR, [], []);
|
||||||
|
Prim (0, I_DUP, [], []);
|
||||||
|
Prim (0, I_CDR, [], [])
|
||||||
|
])
|
||||||
|
], []);
|
||||||
|
Prim (0, I_PAIR, [], []);
|
||||||
|
|
||||||
|
code_expr;
|
||||||
|
|
||||||
|
Prim (0, I_SWAP, [], []);
|
||||||
|
Prim (0, I_CAR, [], []);
|
||||||
|
Prim (0, I_SWAP, [], []);
|
||||||
|
Seq (0, [
|
||||||
|
Seq (0, [
|
||||||
|
Prim (0, I_DUP, [], []);
|
||||||
|
Prim (0, I_CAR, [], []);
|
||||||
|
Prim (0, I_DIP, [
|
||||||
|
Seq (0, [
|
||||||
|
Prim (0, I_CDR, [], [])
|
||||||
|
])
|
||||||
|
], [])
|
||||||
|
])
|
||||||
|
]);
|
||||||
|
Prim (0, I_DIP, [
|
||||||
|
Seq (0, [
|
||||||
|
Prim (0, I_SWAP, [], []);
|
||||||
|
Prim (0, I_PAIR, [], [])
|
||||||
|
])
|
||||||
|
], []);
|
||||||
|
Prim (0, I_PAIR, [], [])
|
||||||
|
])
|
||||||
|
], [])
|
||||||
|
])
|
||||||
|
], code_annot)
|
||||||
|
])
|
||||||
|
in
|
||||||
|
let migrated_storage = Prim (0, D_Pair, [
|
||||||
|
(* Instead of
|
||||||
|
`String (0, Signature.Public_key_hash.to_b58check manager_pkh)`
|
||||||
|
the storage is written as unparsed with [Optimized] *)
|
||||||
|
Bytes (0, Data_encoding.Binary.to_bytes_exn Signature.Public_key_hash.encoding manager_pkh) ;
|
||||||
|
storage_expr
|
||||||
|
], []) in
|
||||||
|
Script_repr.lazy_expr @@ strip_locations migrated_code,
|
||||||
|
Script_repr.lazy_expr @@ strip_locations migrated_storage
|
||||||
|
| _ ->
|
||||||
|
script_code, script_storage
|
||||||
|
end
|
||||||
|
| _ ->
|
||||||
|
script_code, script_storage
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
let add_set_delegate:
|
||||||
|
manager_pkh: Signature.Public_key_hash.t ->
|
||||||
|
script_code: Script_repr.lazy_expr ->
|
||||||
|
script_storage: Script_repr.lazy_expr ->
|
||||||
|
(Script_repr.lazy_expr * Script_repr.lazy_expr) tzresult Lwt.t =
|
||||||
|
fun ~manager_pkh ~script_code ~script_storage ->
|
||||||
|
let open Micheline in
|
||||||
|
let open Michelson_v1_primitives in
|
||||||
|
Lwt.return (Script_repr.force_decode script_code) >>=? fun (script_code_expr, _gas_cost) ->
|
||||||
|
Lwt.return (Script_repr.force_decode script_storage) >>|? fun (script_storage_expr, _gas_cost) ->
|
||||||
|
let storage_expr = root script_storage_expr in
|
||||||
|
match root script_code_expr with
|
||||||
|
| Seq (_, toplevel)
|
||||||
|
-> begin
|
||||||
|
match find_toplevel K_parameter toplevel,
|
||||||
|
find_toplevel K_storage toplevel,
|
||||||
|
find_toplevel K_code toplevel with
|
||||||
|
Some (Prim (_, K_parameter, [
|
||||||
|
Prim (_, parameter_type, parameter_expr, parameter_annot)
|
||||||
|
], prim_param_annot)),
|
||||||
|
Some (Prim (_, K_storage, [
|
||||||
|
Prim (_, code_storage_type, code_storage_expr, code_storage_annot)
|
||||||
|
], k_storage_annot)),
|
||||||
|
Some (Prim (_, K_code, [code_expr], code_annot)) ->
|
||||||
|
(* Note that we intentionally don't deal with potential duplicate entrypoints in this migration as there already might be some in contracts that we don't touch. *)
|
||||||
|
|
||||||
|
let migrated_code =
|
||||||
|
Seq (0, [
|
||||||
|
Prim (0, K_parameter, [
|
||||||
|
Prim (0, T_or, [
|
||||||
|
Prim (0, T_or, [
|
||||||
|
Prim (0, T_key_hash, [], ["%set_delegate"]);
|
||||||
|
Prim (0, T_unit, [], ["%remove_delegate"])
|
||||||
|
], []);
|
||||||
|
Prim (0, parameter_type, parameter_expr, "%default" :: parameter_annot)
|
||||||
|
], [])
|
||||||
|
], prim_param_annot);
|
||||||
|
Prim (0, K_storage, [
|
||||||
|
Prim (0, T_pair, [
|
||||||
|
Prim (0, T_key_hash, [], []);
|
||||||
|
Prim (0, code_storage_type, code_storage_expr, code_storage_annot)
|
||||||
|
], [])
|
||||||
|
], k_storage_annot);
|
||||||
|
Prim (0, K_code, [
|
||||||
|
Seq (0, [
|
||||||
|
Prim (0, I_DUP, [], []);
|
||||||
|
Prim (0, I_CAR, [], []);
|
||||||
|
Prim (0, I_IF_LEFT, [
|
||||||
|
Seq (0, [
|
||||||
|
Prim (0, I_PUSH, [
|
||||||
|
Prim (0, T_mutez, [], []);
|
||||||
|
Int (0, Z.zero)
|
||||||
|
], []);
|
||||||
|
Prim (0, I_AMOUNT, [], []);
|
||||||
|
Seq (0, [
|
||||||
|
Seq (0, [
|
||||||
|
Prim (0, I_COMPARE, [], []);
|
||||||
|
Prim (0, I_EQ, [], [])
|
||||||
|
]);
|
||||||
|
Prim (0, I_IF, [
|
||||||
|
Seq (0, []);
|
||||||
|
Seq (0, [
|
||||||
|
Seq (0, [
|
||||||
|
Prim (0, I_UNIT, [], []);
|
||||||
|
Prim (0, I_FAILWITH, [], [])
|
||||||
|
])
|
||||||
|
])
|
||||||
|
], [])
|
||||||
|
]);
|
||||||
|
Seq (0, [
|
||||||
|
Prim (0, I_DIP, [
|
||||||
|
Seq (0, [
|
||||||
|
Prim (0, I_DUP, [], [])
|
||||||
|
])
|
||||||
|
], []);
|
||||||
|
Prim (0, I_SWAP, [], [])
|
||||||
|
]);
|
||||||
|
Prim (0, I_CDR, [], []);
|
||||||
|
Prim (0, I_CAR, [], []);
|
||||||
|
Prim (0, I_IMPLICIT_ACCOUNT, [], []);
|
||||||
|
Prim (0, I_ADDRESS, [], []);
|
||||||
|
Prim (0, I_SENDER, [], []);
|
||||||
|
Seq (0, [
|
||||||
|
Prim (0, I_COMPARE, [], []);
|
||||||
|
Prim (0, I_NEQ, [], []);
|
||||||
|
Prim (0, I_IF, [
|
||||||
|
Seq (0, [
|
||||||
|
Prim (0, I_SENDER, [], []);
|
||||||
|
Prim (0, I_PUSH, [
|
||||||
|
Prim (0, T_string, [], []);
|
||||||
|
String (0, "Only the owner can operate.")
|
||||||
|
], []);
|
||||||
|
Prim (0, I_PAIR, [], []);
|
||||||
|
Prim (0, I_FAILWITH, [], [])
|
||||||
|
]);
|
||||||
|
Seq (0, [
|
||||||
|
Prim (0, I_DIP, [
|
||||||
|
Seq (0, [
|
||||||
|
Prim (0, I_CDR, [], []);
|
||||||
|
Prim (0, I_NIL, [
|
||||||
|
Prim (0, T_operation, [], [])
|
||||||
|
], [])
|
||||||
|
])
|
||||||
|
], []);
|
||||||
|
Prim (0, I_IF_LEFT, [
|
||||||
|
Seq (0, [
|
||||||
|
Prim (0, I_SOME, [], []);
|
||||||
|
Prim (0, I_SET_DELEGATE, [], []);
|
||||||
|
Prim (0, I_CONS, [], []);
|
||||||
|
Prim (0, I_PAIR, [], [])
|
||||||
|
]);
|
||||||
|
Seq (0, [
|
||||||
|
Prim (0, I_DROP, [], []);
|
||||||
|
Prim (0, I_NONE, [
|
||||||
|
Prim (0, T_key_hash, [], [])
|
||||||
|
], []);
|
||||||
|
Prim (0, I_SET_DELEGATE, [], []);
|
||||||
|
Prim (0, I_CONS, [], []);
|
||||||
|
Prim (0, I_PAIR, [], [])
|
||||||
|
])
|
||||||
|
], [])
|
||||||
|
])
|
||||||
|
], [])
|
||||||
|
])
|
||||||
|
]);
|
||||||
|
Seq (0, [
|
||||||
|
Prim (0, I_DIP, [
|
||||||
|
Seq (0, [
|
||||||
|
Prim (0, I_CDR, [], []);
|
||||||
|
Prim (0, I_DUP, [], []);
|
||||||
|
Prim (0, I_CDR, [], [])
|
||||||
|
])
|
||||||
|
], []);
|
||||||
|
Prim (0, I_PAIR, [], []);
|
||||||
|
|
||||||
|
code_expr;
|
||||||
|
|
||||||
|
Prim (0, I_SWAP, [], []);
|
||||||
|
Prim (0, I_CAR, [], []);
|
||||||
|
Prim (0, I_SWAP, [], []);
|
||||||
|
Seq (0, [
|
||||||
|
Seq (0, [
|
||||||
|
Prim (0, I_DUP, [], []);
|
||||||
|
Prim (0, I_CAR, [], []);
|
||||||
|
Prim (0, I_DIP, [
|
||||||
|
Seq (0, [
|
||||||
|
Prim (0, I_CDR, [], [])
|
||||||
|
])
|
||||||
|
], [])
|
||||||
|
])
|
||||||
|
]);
|
||||||
|
Prim (0, I_DIP, [
|
||||||
|
Seq (0, [
|
||||||
|
Prim (0, I_SWAP, [], []);
|
||||||
|
Prim (0, I_PAIR, [], [])
|
||||||
|
])
|
||||||
|
], []);
|
||||||
|
Prim (0, I_PAIR, [], [])
|
||||||
|
])
|
||||||
|
], [])
|
||||||
|
])
|
||||||
|
], code_annot)
|
||||||
|
])
|
||||||
|
in
|
||||||
|
let migrated_storage = Prim (0, D_Pair, [
|
||||||
|
(* Instead of
|
||||||
|
`String (0, Signature.Public_key_hash.to_b58check manager_pkh)`
|
||||||
|
the storage is written as unparsed with [Optimized] *)
|
||||||
|
Bytes (0, Data_encoding.Binary.to_bytes_exn Signature.Public_key_hash.encoding manager_pkh) ;
|
||||||
|
storage_expr
|
||||||
|
], []) in
|
||||||
|
Script_repr.lazy_expr @@ strip_locations migrated_code,
|
||||||
|
Script_repr.lazy_expr @@ strip_locations migrated_storage
|
||||||
|
| _ ->
|
||||||
|
script_code, script_storage
|
||||||
|
end
|
||||||
|
| _ ->
|
||||||
|
script_code, script_storage
|
||||||
|
|
||||||
|
let has_default_entrypoint expr =
|
||||||
|
let open Micheline in
|
||||||
|
let open Michelson_v1_primitives in
|
||||||
|
match Script_repr.force_decode expr with
|
||||||
|
| Error _ -> false
|
||||||
|
| Ok (expr, _) ->
|
||||||
|
match root expr with
|
||||||
|
| Seq (_, toplevel) -> begin
|
||||||
|
match find_toplevel K_parameter toplevel with
|
||||||
|
| Some (Prim (_, K_parameter, [ _ ], [ "%default" ])) -> false
|
||||||
|
| Some (Prim (_, K_parameter, [ parameter_expr ], _)) ->
|
||||||
|
let rec has_default = function
|
||||||
|
| Prim (_, T_or, [ l ; r ], annots) ->
|
||||||
|
List.exists (String.equal "%default") annots || has_default l || has_default r
|
||||||
|
| Prim (_, _, _, annots) ->
|
||||||
|
List.exists (String.equal "%default") annots
|
||||||
|
| _ -> false
|
||||||
|
in
|
||||||
|
has_default parameter_expr
|
||||||
|
| Some _ | None -> false
|
||||||
|
end
|
||||||
|
| _ -> false
|
||||||
|
|
||||||
|
let add_root_entrypoint
|
||||||
|
: script_code: Script_repr.lazy_expr -> Script_repr.lazy_expr tzresult Lwt.t
|
||||||
|
= fun ~script_code ->
|
||||||
|
let open Micheline in
|
||||||
|
let open Michelson_v1_primitives in
|
||||||
|
Lwt.return (Script_repr.force_decode script_code) >>|? fun (script_code_expr, _gas_cost) ->
|
||||||
|
match root script_code_expr with
|
||||||
|
| Seq (_, toplevel) ->
|
||||||
|
let migrated_code =
|
||||||
|
Seq (0, List.map (function
|
||||||
|
| Prim (_, K_parameter, [ parameter_expr ], _) ->
|
||||||
|
Prim (0, K_parameter, [ parameter_expr ], [ "%root" ])
|
||||||
|
| Prim (_, K_code, exprs, annots) ->
|
||||||
|
let rec rewrite_self = function
|
||||||
|
| Int _ | String _ | Bytes _ | Prim (_, I_CREATE_CONTRACT, _, _) as leaf -> leaf
|
||||||
|
| Prim (_, I_SELF, [], annots) ->
|
||||||
|
Prim (0, I_SELF, [], "%root" :: annots)
|
||||||
|
| Prim (_, name, args, annots) ->
|
||||||
|
Prim (0, name, List.map rewrite_self args, annots)
|
||||||
|
| Seq (_, args) ->
|
||||||
|
Seq (0, List.map rewrite_self args) in
|
||||||
|
Prim (0, K_code, List.map rewrite_self exprs, annots)
|
||||||
|
| other -> other)
|
||||||
|
toplevel) in
|
||||||
|
Script_repr.lazy_expr @@ strip_locations migrated_code
|
||||||
|
| _ ->
|
||||||
|
script_code
|
69
vendors/ligo-utils/tezos-protocol-alpha/legacy_script_support_repr.mli
vendored
Normal file
69
vendors/ligo-utils/tezos-protocol-alpha/legacy_script_support_repr.mli
vendored
Normal file
@ -0,0 +1,69 @@
|
|||||||
|
(*****************************************************************************)
|
||||||
|
(* *)
|
||||||
|
(* Open Source License *)
|
||||||
|
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
|
||||||
|
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com> *)
|
||||||
|
(* Copyright (c) 2019 Cryptium Labs <contact@cryptium-labs.com> *)
|
||||||
|
(* *)
|
||||||
|
(* Permission is hereby granted, free of charge, to any person obtaining a *)
|
||||||
|
(* copy of this software and associated documentation files (the "Software"),*)
|
||||||
|
(* to deal in the Software without restriction, including without limitation *)
|
||||||
|
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
|
||||||
|
(* and/or sell copies of the Software, and to permit persons to whom the *)
|
||||||
|
(* Software is furnished to do so, subject to the following conditions: *)
|
||||||
|
(* *)
|
||||||
|
(* The above copyright notice and this permission notice shall be included *)
|
||||||
|
(* in all copies or substantial portions of the Software. *)
|
||||||
|
(* *)
|
||||||
|
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
|
||||||
|
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
|
||||||
|
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
|
||||||
|
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
|
||||||
|
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
|
||||||
|
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
|
||||||
|
(* DEALINGS IN THE SOFTWARE. *)
|
||||||
|
(* *)
|
||||||
|
(*****************************************************************************)
|
||||||
|
|
||||||
|
(** This code mimics the now defunct scriptless KT1s.
|
||||||
|
|
||||||
|
The manager contract is from:
|
||||||
|
https://gitlab.com/nomadic-labs/mi-cho-coq/blob/7b42f2e970e1541af54f8a9b6820b4f18e847575/src/contracts/manager.tz
|
||||||
|
The formal proof is at:
|
||||||
|
https://gitlab.com/nomadic-labs/mi-cho-coq/blob/a7603e12021166e15890f6d504feebec2f945502/src/contracts_coq/manager.v *)
|
||||||
|
val manager_script_code: Script_repr.lazy_expr
|
||||||
|
|
||||||
|
(** This code mimics the now defunct "spendable" flags of KT1s by
|
||||||
|
adding a [do] entrypoint, preserving the original script's at
|
||||||
|
'default' entrypoint.
|
||||||
|
|
||||||
|
The pseudo-code for the applied transformations is from:
|
||||||
|
https://gitlab.com/nomadic-labs/mi-cho-coq/blob/7b42f2e970e1541af54f8a9b6820b4f18e847575/src/contracts/transform/add_do.tz *)
|
||||||
|
val add_do:
|
||||||
|
manager_pkh: Signature.Public_key_hash.t ->
|
||||||
|
script_code: Script_repr.lazy_expr ->
|
||||||
|
script_storage: Script_repr.lazy_expr ->
|
||||||
|
(Script_repr.lazy_expr * Script_repr.lazy_expr) tzresult Lwt.t
|
||||||
|
|
||||||
|
(** This code mimics the now defunct "spendable" flags of KT1s by
|
||||||
|
adding a [do] entrypoint, preserving the original script's at
|
||||||
|
'default' entrypoint.
|
||||||
|
|
||||||
|
The pseudo-code for the applied transformations is from:
|
||||||
|
https://gitlab.com/nomadic-labs/mi-cho-coq/blob/7b42f2e970e1541af54f8a9b6820b4f18e847575/src/contracts/transform/add_set_delegate.tz *)
|
||||||
|
val add_set_delegate:
|
||||||
|
manager_pkh: Signature.Public_key_hash.t ->
|
||||||
|
script_code: Script_repr.lazy_expr ->
|
||||||
|
script_storage: Script_repr.lazy_expr ->
|
||||||
|
(Script_repr.lazy_expr * Script_repr.lazy_expr) tzresult Lwt.t
|
||||||
|
|
||||||
|
(** Checks if a contract was declaring a default entrypoint somewhere
|
||||||
|
else than at the root, in which case its type changes when
|
||||||
|
entrypoints are activated. *)
|
||||||
|
val has_default_entrypoint:
|
||||||
|
Script_repr.lazy_expr -> bool
|
||||||
|
|
||||||
|
(** Adds a [%root] annotation on the toplevel parameter construct. *)
|
||||||
|
val add_root_entrypoint:
|
||||||
|
script_code: Script_repr.lazy_expr ->
|
||||||
|
Script_repr.lazy_expr tzresult Lwt.t
|
63
vendors/ligo-utils/tezos-protocol-alpha/main.ml
vendored
63
vendors/ligo-utils/tezos-protocol-alpha/main.ml
vendored
@ -54,7 +54,6 @@ type operation = Alpha_context.packed_operation = {
|
|||||||
protocol_data: operation_data ;
|
protocol_data: operation_data ;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
let acceptable_passes = Alpha_context.Operation.acceptable_passes
|
let acceptable_passes = Alpha_context.Operation.acceptable_passes
|
||||||
|
|
||||||
let max_block_length =
|
let max_block_length =
|
||||||
@ -81,10 +80,12 @@ type validation_mode =
|
|||||||
| Application of {
|
| Application of {
|
||||||
block_header : Alpha_context.Block_header.t ;
|
block_header : Alpha_context.Block_header.t ;
|
||||||
baker : Alpha_context.public_key_hash ;
|
baker : Alpha_context.public_key_hash ;
|
||||||
|
block_delay : Alpha_context.Period.t ;
|
||||||
}
|
}
|
||||||
| Partial_application of {
|
| Partial_application of {
|
||||||
block_header : Alpha_context.Block_header.t ;
|
block_header : Alpha_context.Block_header.t ;
|
||||||
baker : Alpha_context.public_key_hash ;
|
baker : Alpha_context.public_key_hash ;
|
||||||
|
block_delay : Alpha_context.Period.t ;
|
||||||
}
|
}
|
||||||
| Partial_construction of {
|
| Partial_construction of {
|
||||||
predecessor : Block_hash.t ;
|
predecessor : Block_hash.t ;
|
||||||
@ -93,6 +94,7 @@ type validation_mode =
|
|||||||
predecessor : Block_hash.t ;
|
predecessor : Block_hash.t ;
|
||||||
protocol_data : Alpha_context.Block_header.contents ;
|
protocol_data : Alpha_context.Block_header.contents ;
|
||||||
baker : Alpha_context.public_key_hash ;
|
baker : Alpha_context.public_key_hash ;
|
||||||
|
block_delay : Alpha_context.Period.t ;
|
||||||
}
|
}
|
||||||
|
|
||||||
type validation_state =
|
type validation_state =
|
||||||
@ -114,12 +116,12 @@ let begin_partial_application
|
|||||||
let level = block_header.shell.level in
|
let level = block_header.shell.level in
|
||||||
let fitness = predecessor_fitness in
|
let fitness = predecessor_fitness in
|
||||||
let timestamp = block_header.shell.timestamp in
|
let timestamp = block_header.shell.timestamp in
|
||||||
Alpha_context.prepare ~level ~timestamp ~fitness ctxt >>=? fun ctxt ->
|
Alpha_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt >>=? fun ctxt ->
|
||||||
Apply.begin_application
|
Apply.begin_application
|
||||||
ctxt chain_id block_header predecessor_timestamp >>=? fun (ctxt, baker) ->
|
ctxt chain_id block_header predecessor_timestamp >>=? fun (ctxt, baker, block_delay) ->
|
||||||
let mode =
|
let mode =
|
||||||
Partial_application
|
Partial_application
|
||||||
{ block_header ; baker = Signature.Public_key.hash baker } in
|
{ block_header ; baker = Signature.Public_key.hash baker ; block_delay } in
|
||||||
return { mode ; chain_id ; ctxt ; op_count = 0 }
|
return { mode ; chain_id ; ctxt ; op_count = 0 }
|
||||||
|
|
||||||
let begin_application
|
let begin_application
|
||||||
@ -131,16 +133,17 @@ let begin_application
|
|||||||
let level = block_header.shell.level in
|
let level = block_header.shell.level in
|
||||||
let fitness = predecessor_fitness in
|
let fitness = predecessor_fitness in
|
||||||
let timestamp = block_header.shell.timestamp in
|
let timestamp = block_header.shell.timestamp in
|
||||||
Alpha_context.prepare ~level ~timestamp ~fitness ctxt >>=? fun ctxt ->
|
Alpha_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt >>=? fun ctxt ->
|
||||||
Apply.begin_application
|
Apply.begin_application
|
||||||
ctxt chain_id block_header predecessor_timestamp >>=? fun (ctxt, baker) ->
|
ctxt chain_id block_header predecessor_timestamp >>=? fun (ctxt, baker, block_delay) ->
|
||||||
let mode = Application { block_header ; baker = Signature.Public_key.hash baker } in
|
let mode =
|
||||||
|
Application { block_header ; baker = Signature.Public_key.hash baker ; block_delay } in
|
||||||
return { mode ; chain_id ; ctxt ; op_count = 0 }
|
return { mode ; chain_id ; ctxt ; op_count = 0 }
|
||||||
|
|
||||||
let begin_construction
|
let begin_construction
|
||||||
~chain_id
|
~chain_id
|
||||||
~predecessor_context:ctxt
|
~predecessor_context:ctxt
|
||||||
~predecessor_timestamp:pred_timestamp
|
~predecessor_timestamp
|
||||||
~predecessor_level:pred_level
|
~predecessor_level:pred_level
|
||||||
~predecessor_fitness:pred_fitness
|
~predecessor_fitness:pred_fitness
|
||||||
~predecessor
|
~predecessor
|
||||||
@ -149,7 +152,7 @@ let begin_construction
|
|||||||
() =
|
() =
|
||||||
let level = Int32.succ pred_level in
|
let level = Int32.succ pred_level in
|
||||||
let fitness = pred_fitness in
|
let fitness = pred_fitness in
|
||||||
Alpha_context.prepare ~timestamp ~level ~fitness ctxt >>=? fun ctxt ->
|
Alpha_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt >>=? fun ctxt ->
|
||||||
begin
|
begin
|
||||||
match protocol_data with
|
match protocol_data with
|
||||||
| None ->
|
| None ->
|
||||||
@ -158,11 +161,11 @@ let begin_construction
|
|||||||
return (mode, ctxt)
|
return (mode, ctxt)
|
||||||
| Some proto_header ->
|
| Some proto_header ->
|
||||||
Apply.begin_full_construction
|
Apply.begin_full_construction
|
||||||
ctxt pred_timestamp
|
ctxt predecessor_timestamp
|
||||||
proto_header.contents >>=? fun (ctxt, protocol_data, baker) ->
|
proto_header.contents >>=? fun (ctxt, protocol_data, baker, block_delay) ->
|
||||||
let mode =
|
let mode =
|
||||||
let baker = Signature.Public_key.hash baker in
|
let baker = Signature.Public_key.hash baker in
|
||||||
Full_construction { predecessor ; baker ; protocol_data } in
|
Full_construction { predecessor ; baker ; protocol_data ; block_delay } in
|
||||||
return (mode, ctxt)
|
return (mode, ctxt)
|
||||||
end >>=? fun (mode, ctxt) ->
|
end >>=? fun (mode, ctxt) ->
|
||||||
return { mode ; chain_id ; ctxt ; op_count = 0 }
|
return { mode ; chain_id ; ctxt ; op_count = 0 }
|
||||||
@ -192,13 +195,7 @@ let apply_operation
|
|||||||
| Partial_construction { predecessor }
|
| Partial_construction { predecessor }
|
||||||
-> predecessor, Signature.Public_key_hash.zero
|
-> predecessor, Signature.Public_key_hash.zero
|
||||||
in
|
in
|
||||||
let partial =
|
Apply.apply_operation ctxt chain_id Optimized predecessor baker
|
||||||
match mode with
|
|
||||||
| Partial_construction _ -> true
|
|
||||||
| Application _
|
|
||||||
| Full_construction _
|
|
||||||
| Partial_application _ -> false in
|
|
||||||
Apply.apply_operation ~partial ctxt chain_id Optimized predecessor baker
|
|
||||||
(Alpha_context.Operation.hash operation)
|
(Alpha_context.Operation.hash operation)
|
||||||
operation >>=? fun (ctxt, result) ->
|
operation >>=? fun (ctxt, result) ->
|
||||||
let op_count = op_count + 1 in
|
let op_count = op_count + 1 in
|
||||||
@ -224,8 +221,12 @@ let finalize_block { mode ; ctxt ; op_count } =
|
|||||||
consumed_gas = Z.zero ;
|
consumed_gas = Z.zero ;
|
||||||
deactivated = [];
|
deactivated = [];
|
||||||
balance_updates = []})
|
balance_updates = []})
|
||||||
| Partial_application { baker ; _ } ->
|
| Partial_application { block_header ; baker ; block_delay } ->
|
||||||
let level = Alpha_context. Level.current ctxt in
|
let level = Alpha_context.Level.current ctxt in
|
||||||
|
let included_endorsements = Alpha_context.included_endorsements ctxt in
|
||||||
|
Apply.check_minimum_endorsements ctxt
|
||||||
|
block_header.protocol_data.contents
|
||||||
|
block_delay included_endorsements >>=? fun () ->
|
||||||
Alpha_context.Vote.get_current_period_kind ctxt >>=? fun voting_period_kind ->
|
Alpha_context.Vote.get_current_period_kind ctxt >>=? fun voting_period_kind ->
|
||||||
let ctxt = Alpha_context.finalize ctxt in
|
let ctxt = Alpha_context.finalize ctxt in
|
||||||
return (ctxt, Apply_results.{ baker ;
|
return (ctxt, Apply_results.{ baker ;
|
||||||
@ -236,16 +237,16 @@ let finalize_block { mode ; ctxt ; op_count } =
|
|||||||
deactivated = [];
|
deactivated = [];
|
||||||
balance_updates = []})
|
balance_updates = []})
|
||||||
| Application
|
| Application
|
||||||
{ baker ; block_header = { protocol_data = { contents = protocol_data ; _ } ; _ } }
|
{ baker ; block_delay ; block_header = { protocol_data = { contents = protocol_data ; _ } ; _ } }
|
||||||
| Full_construction { protocol_data ; baker ; _ } ->
|
| Full_construction { protocol_data ; baker ; block_delay ; _ } ->
|
||||||
Apply.finalize_application ctxt protocol_data baker >>=? fun (ctxt, receipt) ->
|
Apply.finalize_application ctxt protocol_data baker ~block_delay >>=? fun (ctxt, receipt) ->
|
||||||
let level = Alpha_context.Level.current ctxt in
|
let level = Alpha_context.Level.current ctxt in
|
||||||
let priority = protocol_data.priority in
|
let priority = protocol_data.priority in
|
||||||
let raw_level = Alpha_context.Raw_level.to_int32 level.level in
|
let raw_level = Alpha_context.Raw_level.to_int32 level.level in
|
||||||
let fitness = Alpha_context.Fitness.current ctxt in
|
let fitness = Alpha_context.Fitness.current ctxt in
|
||||||
let commit_message =
|
let commit_message =
|
||||||
Format.asprintf
|
Format.asprintf
|
||||||
"lvl %ld, fit %Ld, prio %d, %d ops"
|
"lvl %ld, fit 1:%Ld, prio %d, %d ops"
|
||||||
raw_level fitness priority op_count in
|
raw_level fitness priority op_count in
|
||||||
let ctxt = Alpha_context.finalize ~commit_message ctxt in
|
let ctxt = Alpha_context.finalize ~commit_message ctxt in
|
||||||
return (ctxt, receipt)
|
return (ctxt, receipt)
|
||||||
@ -298,11 +299,17 @@ let init ctxt block_header =
|
|||||||
let fitness = block_header.fitness in
|
let fitness = block_header.fitness in
|
||||||
let timestamp = block_header.timestamp in
|
let timestamp = block_header.timestamp in
|
||||||
let typecheck (ctxt:Alpha_context.context) (script:Alpha_context.Script.t) =
|
let typecheck (ctxt:Alpha_context.context) (script:Alpha_context.Script.t) =
|
||||||
Script_ir_translator.parse_script ctxt script >>=? fun (ex_script, ctxt) ->
|
Script_ir_translator.parse_script ctxt ~legacy:false script >>=? fun (Ex_script parsed_script, ctxt) ->
|
||||||
Script_ir_translator.big_map_initialization ctxt Optimized ex_script >>=? fun (big_map_diff, ctxt) ->
|
Script_ir_translator.extract_big_map_diff ctxt Optimized parsed_script.storage_type parsed_script.storage
|
||||||
return ((script, big_map_diff), ctxt)
|
~to_duplicate: Script_ir_translator.no_big_map_id
|
||||||
|
~to_update: Script_ir_translator.no_big_map_id
|
||||||
|
~temporary:false >>=? fun (storage, big_map_diff, ctxt) ->
|
||||||
|
Script_ir_translator.unparse_data ctxt Optimized parsed_script.storage_type storage >>=? fun (storage, ctxt) ->
|
||||||
|
let storage = Alpha_context.Script.lazy_expr (Micheline.strip_locations storage) in
|
||||||
|
return (({ script with storage }, big_map_diff), ctxt)
|
||||||
in
|
in
|
||||||
Alpha_context.prepare_first_block
|
Alpha_context.prepare_first_block
|
||||||
~typecheck
|
~typecheck
|
||||||
~level ~timestamp ~fitness ctxt >>=? fun ctxt ->
|
~level ~timestamp ~fitness ctxt >>=? fun ctxt ->
|
||||||
return (Alpha_context.finalize ctxt)
|
return (Alpha_context.finalize ctxt)
|
||||||
|
(* Vanity nonce: 415767323 *)
|
||||||
|
@ -29,10 +29,12 @@ type validation_mode =
|
|||||||
| Application of {
|
| Application of {
|
||||||
block_header : Alpha_context.Block_header.t ;
|
block_header : Alpha_context.Block_header.t ;
|
||||||
baker : Alpha_context.public_key_hash ;
|
baker : Alpha_context.public_key_hash ;
|
||||||
|
block_delay : Alpha_context.Period.t ;
|
||||||
}
|
}
|
||||||
| Partial_application of {
|
| Partial_application of {
|
||||||
block_header : Alpha_context.Block_header.t ;
|
block_header : Alpha_context.Block_header.t ;
|
||||||
baker : Alpha_context.public_key_hash ;
|
baker : Alpha_context.public_key_hash ;
|
||||||
|
block_delay : Alpha_context.Period.t ;
|
||||||
}
|
}
|
||||||
| Partial_construction of {
|
| Partial_construction of {
|
||||||
predecessor : Block_hash.t ;
|
predecessor : Block_hash.t ;
|
||||||
@ -41,6 +43,7 @@ type validation_mode =
|
|||||||
predecessor : Block_hash.t ;
|
predecessor : Block_hash.t ;
|
||||||
protocol_data : Alpha_context.Block_header.contents ;
|
protocol_data : Alpha_context.Block_header.contents ;
|
||||||
baker : Alpha_context.public_key_hash ;
|
baker : Alpha_context.public_key_hash ;
|
||||||
|
block_delay : Alpha_context.Period.t ;
|
||||||
}
|
}
|
||||||
|
|
||||||
type validation_state =
|
type validation_state =
|
||||||
|
@ -27,48 +27,6 @@ open Alpha_context
|
|||||||
open Gas
|
open Gas
|
||||||
|
|
||||||
module Cost_of = struct
|
module Cost_of = struct
|
||||||
let cycle = step_cost 1
|
|
||||||
let nop = free
|
|
||||||
|
|
||||||
let stack_op = step_cost 1
|
|
||||||
|
|
||||||
let bool_binop _ _ = step_cost 1
|
|
||||||
let bool_unop _ = step_cost 1
|
|
||||||
|
|
||||||
let pair = alloc_cost 2
|
|
||||||
let pair_access = step_cost 1
|
|
||||||
|
|
||||||
let cons = alloc_cost 2
|
|
||||||
|
|
||||||
let variant_no_data = alloc_cost 1
|
|
||||||
|
|
||||||
let branch = step_cost 2
|
|
||||||
|
|
||||||
let string length =
|
|
||||||
alloc_bytes_cost length
|
|
||||||
|
|
||||||
let bytes length =
|
|
||||||
alloc_mbytes_cost length
|
|
||||||
|
|
||||||
let zint z =
|
|
||||||
alloc_bits_cost (Z.numbits z)
|
|
||||||
|
|
||||||
let concat cost length ss =
|
|
||||||
let rec cum acc = function
|
|
||||||
| [] -> acc
|
|
||||||
| s :: ss -> cum (cost (length s) +@ acc) ss in
|
|
||||||
cum free ss
|
|
||||||
|
|
||||||
let concat_string ss = concat string String.length ss
|
|
||||||
let concat_bytes ss = concat bytes MBytes.length ss
|
|
||||||
|
|
||||||
let slice_string length = string length
|
|
||||||
let slice_bytes = alloc_cost 0
|
|
||||||
|
|
||||||
(* Cost per cycle of a loop, fold, etc *)
|
|
||||||
let loop_cycle = step_cost 2
|
|
||||||
|
|
||||||
let list_size = step_cost 1
|
|
||||||
|
|
||||||
let log2 =
|
let log2 =
|
||||||
let rec help acc = function
|
let rec help acc = function
|
||||||
@ -76,166 +34,257 @@ module Cost_of = struct
|
|||||||
| n -> help (acc + 1) (n / 2)
|
| n -> help (acc + 1) (n / 2)
|
||||||
in help 1
|
in help 1
|
||||||
|
|
||||||
let module_cost = alloc_cost 10
|
let z_bytes (z : Z.t) =
|
||||||
|
let bits = Z.numbits z in
|
||||||
|
(7 + bits) / 8
|
||||||
|
|
||||||
let map_access : type key value. (key, value) Script_typed_ir.map -> int
|
let int_bytes (z : 'a Script_int.num) =
|
||||||
|
z_bytes (Script_int.to_zint z)
|
||||||
|
|
||||||
|
let timestamp_bytes (t : Script_timestamp.t) =
|
||||||
|
let z = Script_timestamp.to_zint t in
|
||||||
|
z_bytes z
|
||||||
|
|
||||||
|
(* For now, returns size in bytes, but this could get more complicated... *)
|
||||||
|
let rec size_of_comparable : type a b. (a, b) Script_typed_ir.comparable_struct -> a -> int =
|
||||||
|
fun wit v ->
|
||||||
|
match wit with
|
||||||
|
| Int_key _ -> int_bytes v
|
||||||
|
| Nat_key _ -> int_bytes v
|
||||||
|
| String_key _ -> String.length v
|
||||||
|
| Bytes_key _ -> MBytes.length v
|
||||||
|
| Bool_key _ -> 8
|
||||||
|
| Key_hash_key _ -> Signature.Public_key_hash.size
|
||||||
|
| Timestamp_key _ -> timestamp_bytes v
|
||||||
|
| Address_key _ -> Signature.Public_key_hash.size
|
||||||
|
| Mutez_key _ -> 8
|
||||||
|
| Pair_key ((l, _), (r, _), _) ->
|
||||||
|
let (lval, rval) = v in
|
||||||
|
size_of_comparable l lval + size_of_comparable r rval
|
||||||
|
|
||||||
|
let string length =
|
||||||
|
alloc_bytes_cost length
|
||||||
|
|
||||||
|
let bytes length =
|
||||||
|
alloc_mbytes_cost length
|
||||||
|
|
||||||
|
let manager_operation = step_cost 10_000
|
||||||
|
|
||||||
|
module Legacy = struct
|
||||||
|
let zint z =
|
||||||
|
alloc_bits_cost (Z.numbits z)
|
||||||
|
|
||||||
|
let set_to_list : type item. item Script_typed_ir.set -> cost
|
||||||
= fun (module Box) ->
|
= fun (module Box) ->
|
||||||
log2 (snd Box.boxed)
|
alloc_cost @@ Pervasives.(Box.size * 2)
|
||||||
|
|
||||||
let map_to_list : type key value. (key, value) Script_typed_ir.map -> cost
|
let map_to_list : type key value. (key, value) Script_typed_ir.map -> cost
|
||||||
= fun (module Box) ->
|
= fun (module Box) ->
|
||||||
let size = snd Box.boxed in
|
let size = snd Box.boxed in
|
||||||
3 *@ alloc_cost size
|
3 *@ alloc_cost size
|
||||||
|
|
||||||
let map_mem _key map = step_cost (map_access map)
|
let z_to_int64 = step_cost 2 +@ alloc_cost 1
|
||||||
|
|
||||||
let map_get = map_mem
|
let hash data len = 10 *@ step_cost (MBytes.length data) +@ bytes len
|
||||||
|
|
||||||
let map_update _ _ map =
|
|
||||||
map_access map *@ alloc_cost 3
|
|
||||||
|
|
||||||
let map_size = step_cost 2
|
|
||||||
|
|
||||||
let big_map_mem _key _map = step_cost 50
|
|
||||||
let big_map_get _key _map = step_cost 50
|
|
||||||
let big_map_update _key _value _map = step_cost 10
|
|
||||||
|
|
||||||
let set_access : type elt. elt -> elt Script_typed_ir.set -> int
|
let set_access : type elt. elt -> elt Script_typed_ir.set -> int
|
||||||
= fun _key (module Box) ->
|
= fun _key (module Box) ->
|
||||||
log2 @@ Box.size
|
log2 @@ Box.size
|
||||||
|
|
||||||
let set_mem key set = step_cost (set_access key set)
|
|
||||||
|
|
||||||
let set_update key _presence set =
|
let set_update key _presence set =
|
||||||
set_access key set *@ alloc_cost 3
|
set_access key set *@ alloc_cost 3
|
||||||
|
end
|
||||||
|
|
||||||
(* for LEFT, RIGHT, SOME *)
|
module Interpreter = struct
|
||||||
let wrap = alloc_cost 1
|
let cycle = atomic_step_cost 10
|
||||||
|
let nop = free
|
||||||
|
let stack_op = atomic_step_cost 10
|
||||||
|
let push = atomic_step_cost 10
|
||||||
|
let wrap = atomic_step_cost 10
|
||||||
|
let variant_no_data = atomic_step_cost 10
|
||||||
|
let branch = atomic_step_cost 10
|
||||||
|
let pair = atomic_step_cost 10
|
||||||
|
let pair_access = atomic_step_cost 10
|
||||||
|
let cons = atomic_step_cost 10
|
||||||
|
let loop_size = atomic_step_cost 5
|
||||||
|
let loop_cycle = atomic_step_cost 10
|
||||||
|
let loop_iter = atomic_step_cost 20
|
||||||
|
let loop_map = atomic_step_cost 30
|
||||||
|
let empty_set = atomic_step_cost 10
|
||||||
|
let set_to_list : type elt. elt Script_typed_ir.set -> cost =
|
||||||
|
fun (module Box) ->
|
||||||
|
atomic_step_cost (Box.size * 20)
|
||||||
|
|
||||||
let mul n1 n2 =
|
let set_mem : type elt. elt -> elt Script_typed_ir.set -> cost =
|
||||||
let steps =
|
fun elt (module Box) ->
|
||||||
(Z.numbits (Script_int.to_zint n1))
|
let elt_bytes = size_of_comparable Box.elt_ty elt in
|
||||||
* (Z.numbits (Script_int.to_zint n2)) in
|
atomic_step_cost ((1 + (elt_bytes / 82)) * log2 Box.size)
|
||||||
let bits =
|
|
||||||
(Z.numbits (Script_int.to_zint n1))
|
|
||||||
+ (Z.numbits (Script_int.to_zint n2)) in
|
|
||||||
step_cost steps +@ alloc_bits_cost bits
|
|
||||||
|
|
||||||
let div n1 n2 =
|
let set_update : type elt. elt -> bool -> elt Script_typed_ir.set -> cost =
|
||||||
mul n1 n2 +@ alloc_cost 2
|
fun elt _ (module Box) ->
|
||||||
|
let elt_bytes = size_of_comparable Box.elt_ty elt in
|
||||||
|
atomic_step_cost ((1 + (elt_bytes / 82)) * log2 Box.size)
|
||||||
|
|
||||||
let add_sub_z n1 n2 =
|
let set_size = atomic_step_cost 10
|
||||||
let bits =
|
let empty_map = atomic_step_cost 10
|
||||||
Compare.Int.max (Z.numbits n1) (Z.numbits n2) in
|
let map_to_list : type key value. (key, value) Script_typed_ir.map -> cost =
|
||||||
step_cost bits +@ alloc_cost bits
|
fun (module Box) ->
|
||||||
|
let size = snd Box.boxed in
|
||||||
|
atomic_step_cost (size * 20)
|
||||||
|
|
||||||
let add n1 n2 =
|
let map_access : type key value. key -> (key, value) Script_typed_ir.map -> cost
|
||||||
add_sub_z (Script_int.to_zint n1) (Script_int.to_zint n2)
|
= fun key (module Box) ->
|
||||||
|
let map_card = snd Box.boxed in
|
||||||
|
let key_bytes = size_of_comparable Box.key_ty key in
|
||||||
|
atomic_step_cost ((1 + (key_bytes / 70)) * log2 map_card)
|
||||||
|
|
||||||
|
let map_mem = map_access
|
||||||
|
let map_get = map_access
|
||||||
|
|
||||||
|
let map_update : type key value. key -> value option -> (key, value) Script_typed_ir.map -> cost
|
||||||
|
= fun key _value (module Box) ->
|
||||||
|
let map_card = snd Box.boxed in
|
||||||
|
let key_bytes = size_of_comparable Box.key_ty key in
|
||||||
|
atomic_step_cost ((1 + (key_bytes / 38)) * log2 map_card)
|
||||||
|
|
||||||
|
let map_size = atomic_step_cost 10
|
||||||
|
|
||||||
|
let add_timestamp (t1 : Script_timestamp.t) (t2 : 'a Script_int.num) =
|
||||||
|
let bytes1 = timestamp_bytes t1 in
|
||||||
|
let bytes2 = int_bytes t2 in
|
||||||
|
atomic_step_cost (51 + (Compare.Int.max bytes1 bytes2 / 62))
|
||||||
|
let sub_timestamp = add_timestamp
|
||||||
|
let diff_timestamps (t1 : Script_timestamp.t) (t2 : Script_timestamp.t) =
|
||||||
|
let bytes1 = timestamp_bytes t1 in
|
||||||
|
let bytes2 = timestamp_bytes t2 in
|
||||||
|
atomic_step_cost (51 + (Compare.Int.max bytes1 bytes2 / 62))
|
||||||
|
|
||||||
|
let rec concat_loop l acc =
|
||||||
|
match l with
|
||||||
|
| [] -> 30
|
||||||
|
| _ :: tl -> concat_loop tl (acc + 30)
|
||||||
|
|
||||||
|
let concat_string string_list =
|
||||||
|
atomic_step_cost (concat_loop string_list 0)
|
||||||
|
|
||||||
|
let slice_string string_length =
|
||||||
|
atomic_step_cost (40 + (string_length / 70))
|
||||||
|
|
||||||
|
let concat_bytes bytes_list =
|
||||||
|
atomic_step_cost (concat_loop bytes_list 0)
|
||||||
|
|
||||||
|
let int64_op = atomic_step_cost 61
|
||||||
|
let z_to_int64 = atomic_step_cost 20
|
||||||
|
let int64_to_z = atomic_step_cost 20
|
||||||
|
let bool_binop _ _ = atomic_step_cost 10
|
||||||
|
let bool_unop _ = atomic_step_cost 10
|
||||||
|
|
||||||
|
let abs int = atomic_step_cost (61 + ((int_bytes int) / 70))
|
||||||
|
let int _int = free
|
||||||
|
let neg = abs
|
||||||
|
let add i1 i2 = atomic_step_cost (51 + (Compare.Int.max (int_bytes i1) (int_bytes i2) / 62))
|
||||||
let sub = add
|
let sub = add
|
||||||
|
|
||||||
let abs n =
|
let mul i1 i2 =
|
||||||
alloc_bits_cost (Z.numbits @@ Script_int.to_zint n)
|
let bytes = Compare.Int.max (int_bytes i1) (int_bytes i2) in
|
||||||
|
atomic_step_cost (51 + (bytes / 6 * log2 bytes))
|
||||||
|
|
||||||
let neg = abs
|
let indic_lt x y = if Compare.Int.(x < y) then 1 else 0
|
||||||
let int _ = step_cost 1
|
|
||||||
|
|
||||||
let add_timestamp t n =
|
let div i1 i2 =
|
||||||
add_sub_z (Script_timestamp.to_zint t) (Script_int.to_zint n)
|
let bytes1 = int_bytes i1 in
|
||||||
|
let bytes2 = int_bytes i2 in
|
||||||
|
let cost = indic_lt bytes2 bytes1 * (bytes1 - bytes2) * bytes2 in
|
||||||
|
atomic_step_cost (51 + (cost / 3151))
|
||||||
|
|
||||||
let sub_timestamp t n =
|
let shift_left _i _shift_bits = atomic_step_cost 30
|
||||||
add_sub_z (Script_timestamp.to_zint t) (Script_int.to_zint n)
|
let shift_right _i _shift_bits = atomic_step_cost 30
|
||||||
|
let logor i1 i2 =
|
||||||
|
let bytes1 = int_bytes i1 in
|
||||||
|
let bytes2 = int_bytes i2 in
|
||||||
|
atomic_step_cost (51 + ((Compare.Int.max bytes1 bytes2) / 70))
|
||||||
|
let logand i1 i2 =
|
||||||
|
let bytes1 = int_bytes i1 in
|
||||||
|
let bytes2 = int_bytes i2 in
|
||||||
|
atomic_step_cost (51 + ((Compare.Int.min bytes1 bytes2) / 70))
|
||||||
|
let logxor = logor
|
||||||
|
let lognot i = atomic_step_cost (51 + ((int_bytes i) / 20))
|
||||||
|
let exec = atomic_step_cost 10
|
||||||
|
let compare_bool _ _ = atomic_step_cost 30
|
||||||
|
|
||||||
let diff_timestamps t1 t2 =
|
let compare_string s1 s2 =
|
||||||
add_sub_z (Script_timestamp.to_zint t1) (Script_timestamp.to_zint t2)
|
let bytes1 = String.length s1 in
|
||||||
|
let bytes2 = String.length s2 in
|
||||||
|
atomic_step_cost (30 + ((Compare.Int.min bytes1 bytes2) / 123))
|
||||||
|
let compare_bytes b1 b2 =
|
||||||
|
let bytes1 = MBytes.length b1 in
|
||||||
|
let bytes2 = MBytes.length b2 in
|
||||||
|
atomic_step_cost (30 + ((Compare.Int.min bytes1 bytes2) / 123))
|
||||||
|
let compare_tez _ _ = atomic_step_cost 30
|
||||||
|
let compare_zint i1 i2 =
|
||||||
|
atomic_step_cost (51 + ((Compare.Int.min (int_bytes i1) (int_bytes i2)) / 82))
|
||||||
|
let compare_key_hash _ _ = atomic_step_cost 92
|
||||||
|
|
||||||
let empty_set = module_cost
|
let compare_timestamp t1 t2 =
|
||||||
|
let bytes1 = timestamp_bytes t1 in
|
||||||
let set_size = step_cost 2
|
let bytes2 = timestamp_bytes t2 in
|
||||||
|
atomic_step_cost (51 + ((Compare.Int.min bytes1 bytes2) / 82))
|
||||||
let set_to_list : type item. item Script_typed_ir.set -> cost
|
|
||||||
= fun (module Box) ->
|
|
||||||
alloc_cost @@ Pervasives.(Box.size * 2)
|
|
||||||
|
|
||||||
let empty_map = module_cost
|
|
||||||
|
|
||||||
let int64_op = step_cost 1 +@ alloc_cost 1
|
|
||||||
|
|
||||||
let z_to_int64 = step_cost 2 +@ alloc_cost 1
|
|
||||||
|
|
||||||
let int64_to_z = step_cost 2 +@ alloc_cost 1
|
|
||||||
|
|
||||||
let bitwise_binop n1 n2 =
|
|
||||||
let bits = Compare.Int.max (Z.numbits (Script_int.to_zint n1)) (Z.numbits (Script_int.to_zint n2)) in
|
|
||||||
step_cost bits +@ alloc_bits_cost bits
|
|
||||||
|
|
||||||
let logor = bitwise_binop
|
|
||||||
let logand = bitwise_binop
|
|
||||||
let logxor = bitwise_binop
|
|
||||||
let lognot n =
|
|
||||||
let bits = Z.numbits @@ Script_int.to_zint n in
|
|
||||||
step_cost bits +@ alloc_cost bits
|
|
||||||
|
|
||||||
let unopt ~default = function
|
|
||||||
| None -> default
|
|
||||||
| Some x -> x
|
|
||||||
|
|
||||||
let max_int = 1073741823
|
|
||||||
|
|
||||||
let shift_left x y =
|
|
||||||
alloc_bits_cost
|
|
||||||
(Z.numbits (Script_int.to_zint x) +
|
|
||||||
(unopt (Script_int.to_int y) ~default:max_int))
|
|
||||||
|
|
||||||
let shift_right x y =
|
|
||||||
alloc_bits_cost
|
|
||||||
(Compare.Int.max 1
|
|
||||||
(Z.numbits (Script_int.to_zint x) -
|
|
||||||
unopt (Script_int.to_int y) ~default:max_int))
|
|
||||||
|
|
||||||
let exec = step_cost 1
|
|
||||||
|
|
||||||
let push = step_cost 1
|
|
||||||
|
|
||||||
let compare_res = step_cost 1
|
|
||||||
|
|
||||||
|
let compare_address _ _ = atomic_step_cost 92
|
||||||
|
let compare_res = atomic_step_cost 30
|
||||||
let unpack_failed bytes =
|
let unpack_failed bytes =
|
||||||
(* We cannot instrument failed deserialization,
|
(* We cannot instrument failed deserialization,
|
||||||
so we take worst case fees: a set of size 1 bytes values. *)
|
so we take worst case fees: a set of size 1 bytes values. *)
|
||||||
let len = MBytes.length bytes in
|
let len = MBytes.length bytes in
|
||||||
(len *@ alloc_mbytes_cost 1) +@
|
(len *@ alloc_mbytes_cost 1) +@
|
||||||
(len *@ (log2 len *@ (alloc_cost 3 +@ step_cost 1)))
|
(len *@ (log2 len *@ (alloc_cost 3 +@ step_cost 1)))
|
||||||
|
let address = atomic_step_cost 10
|
||||||
let address = step_cost 1
|
let contract = step_cost 10000
|
||||||
let contract = Gas.read_bytes_cost Z.zero +@ step_cost 10000
|
|
||||||
let transfer = step_cost 10
|
let transfer = step_cost 10
|
||||||
let create_account = step_cost 10
|
let create_account = step_cost 10
|
||||||
let create_contract = step_cost 10
|
let create_contract = step_cost 10
|
||||||
let implicit_account = step_cost 10
|
let implicit_account = step_cost 10
|
||||||
let set_delegate = step_cost 10 +@ write_bytes_cost (Z.of_int 32)
|
let set_delegate = step_cost 10 +@ write_bytes_cost (Z.of_int 32)
|
||||||
let balance = step_cost 1 +@ read_bytes_cost (Z.of_int 8)
|
let balance = atomic_step_cost 10
|
||||||
let now = step_cost 5
|
let now = atomic_step_cost 10
|
||||||
let check_signature = step_cost 1000
|
let check_signature_secp256k1 bytes = atomic_step_cost (10342 + (bytes / 5))
|
||||||
let hash_key = step_cost 3 +@ bytes 20
|
let check_signature_ed25519 bytes = atomic_step_cost (36864 + (bytes / 5))
|
||||||
let hash data len = 10 *@ step_cost (MBytes.length data) +@ bytes len
|
let check_signature_p256 bytes = atomic_step_cost (36864 + (bytes / 5))
|
||||||
let steps_to_quota = step_cost 1
|
let check_signature (pkey : Signature.public_key) bytes =
|
||||||
let source = step_cost 1
|
match pkey with
|
||||||
let self = step_cost 1
|
| Ed25519 _ -> check_signature_ed25519 (MBytes.length bytes)
|
||||||
let amount = step_cost 1
|
| Secp256k1 _ -> check_signature_secp256k1 (MBytes.length bytes)
|
||||||
let compare_bool _ _ = step_cost 1
|
| P256 _ -> check_signature_p256 (MBytes.length bytes)
|
||||||
let compare_string s1 s2 =
|
let hash_key = atomic_step_cost 30
|
||||||
step_cost ((7 + Compare.Int.max (String.length s1) (String.length s2)) / 8) +@ step_cost 1
|
let hash_blake2b b = atomic_step_cost (102 + ((MBytes.length b) / 5))
|
||||||
let compare_bytes s1 s2 =
|
let hash_sha256 b = atomic_step_cost (409 + (MBytes.length b))
|
||||||
step_cost ((7 + Compare.Int.max (MBytes.length s1) (MBytes.length s2)) / 8) +@ step_cost 1
|
let hash_sha512 b =
|
||||||
let compare_tez _ _ = step_cost 1
|
let bytes = MBytes.length b in atomic_step_cost (409 + ((bytes lsr 1) + (bytes lsr 4)))
|
||||||
let compare_zint n1 n2 = step_cost ((7 + Compare.Int.max (Z.numbits n1) (Z.numbits n2)) / 8) +@ step_cost 1
|
let steps_to_quota = atomic_step_cost 10
|
||||||
let compare_int n1 n2 = compare_zint (Script_int.to_zint n1) (Script_int.to_zint n2)
|
let source = atomic_step_cost 10
|
||||||
let compare_nat = compare_int
|
let self = atomic_step_cost 10
|
||||||
let compare_key_hash _ _ = alloc_bytes_cost 36
|
let amount = atomic_step_cost 10
|
||||||
let compare_timestamp t1 t2 = compare_zint (Script_timestamp.to_zint t1) (Script_timestamp.to_zint t2)
|
let chain_id = step_cost 1
|
||||||
let compare_address _ _ = step_cost 20
|
let stack_n_op n = atomic_step_cost (20 + (((n lsr 1) + (n lsr 2)) + (n lsr 4)))
|
||||||
|
let apply = alloc_cost 8 +@ step_cost 1
|
||||||
|
|
||||||
let manager_operation = step_cost 10_000
|
let rec compare : type a s. (a, s) Script_typed_ir.comparable_struct -> a -> a -> cost = fun ty x y ->
|
||||||
|
match ty with
|
||||||
|
| Bool_key _ -> compare_bool x y
|
||||||
|
| String_key _ -> compare_string x y
|
||||||
|
| Bytes_key _ -> compare_bytes x y
|
||||||
|
| Mutez_key _ -> compare_tez x y
|
||||||
|
| Int_key _ -> compare_zint x y
|
||||||
|
| Nat_key _ -> compare_zint x y
|
||||||
|
| Key_hash_key _ -> compare_key_hash x y
|
||||||
|
| Timestamp_key _ -> compare_timestamp x y
|
||||||
|
| Address_key _ -> compare_address x y
|
||||||
|
| Pair_key ((tl, _), (tr, _), _) ->
|
||||||
|
(* Reasonable over-approximation of the cost of lexicographic comparison. *)
|
||||||
|
let (xl, xr) = x and (yl, yr) = y in
|
||||||
|
compare tl xl yl +@ compare tr xr yr
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
module Typechecking = struct
|
module Typechecking = struct
|
||||||
let cycle = step_cost 1
|
let cycle = step_cost 1
|
||||||
@ -243,7 +292,7 @@ module Cost_of = struct
|
|||||||
let unit = free
|
let unit = free
|
||||||
let string = string
|
let string = string
|
||||||
let bytes = bytes
|
let bytes = bytes
|
||||||
let z = zint
|
let z = Legacy.zint
|
||||||
let int_of_string str =
|
let int_of_string str =
|
||||||
alloc_cost @@ (Pervasives.(/) (String.length str) 5)
|
alloc_cost @@ (Pervasives.(/) (String.length str) 5)
|
||||||
let tez = step_cost 1 +@ alloc_cost 1
|
let tez = step_cost 1 +@ alloc_cost 1
|
||||||
@ -251,6 +300,7 @@ module Cost_of = struct
|
|||||||
let key = step_cost 3 +@ alloc_cost 3
|
let key = step_cost 3 +@ alloc_cost 3
|
||||||
let key_hash = step_cost 1 +@ alloc_cost 1
|
let key_hash = step_cost 1 +@ alloc_cost 1
|
||||||
let signature = step_cost 1 +@ alloc_cost 1
|
let signature = step_cost 1 +@ alloc_cost 1
|
||||||
|
let chain_id = step_cost 1 +@ alloc_cost 1
|
||||||
let contract = step_cost 5
|
let contract = step_cost 5
|
||||||
let get_script = step_cost 20 +@ alloc_cost 5
|
let get_script = step_cost 20 +@ alloc_cost 5
|
||||||
let contract_exists = step_cost 15 +@ alloc_cost 5
|
let contract_exists = step_cost 15 +@ alloc_cost 5
|
||||||
@ -308,6 +358,7 @@ module Cost_of = struct
|
|||||||
| Map_get -> alloc_cost 1
|
| Map_get -> alloc_cost 1
|
||||||
| Map_update -> alloc_cost 1
|
| Map_update -> alloc_cost 1
|
||||||
| Map_size -> alloc_cost 1
|
| Map_size -> alloc_cost 1
|
||||||
|
| Empty_big_map _ -> alloc_cost 2
|
||||||
| Big_map_mem -> alloc_cost 1
|
| Big_map_mem -> alloc_cost 1
|
||||||
| Big_map_get -> alloc_cost 1
|
| Big_map_get -> alloc_cost 1
|
||||||
| Big_map_update -> alloc_cost 1
|
| Big_map_update -> alloc_cost 1
|
||||||
@ -365,6 +416,7 @@ module Cost_of = struct
|
|||||||
| Loop_left _ -> alloc_cost 5
|
| Loop_left _ -> alloc_cost 5
|
||||||
| Dip _ -> alloc_cost 4
|
| Dip _ -> alloc_cost 4
|
||||||
| Exec -> alloc_cost 1
|
| Exec -> alloc_cost 1
|
||||||
|
| Apply _ -> alloc_cost 1
|
||||||
| Lambda _ -> alloc_cost 2
|
| Lambda _ -> alloc_cost 2
|
||||||
| Failwith _ -> alloc_cost 1
|
| Failwith _ -> alloc_cost 1
|
||||||
| Nop -> alloc_cost 0
|
| Nop -> alloc_cost 0
|
||||||
@ -381,6 +433,12 @@ module Cost_of = struct
|
|||||||
| Create_account -> alloc_cost 2
|
| Create_account -> alloc_cost 2
|
||||||
| Implicit_account -> alloc_cost 1
|
| Implicit_account -> alloc_cost 1
|
||||||
| Create_contract _ -> alloc_cost 8
|
| Create_contract _ -> alloc_cost 8
|
||||||
|
(* Deducted the cost of removed arguments manager, spendable and delegatable:
|
||||||
|
- manager: key_hash = 1
|
||||||
|
- spendable: bool = 0
|
||||||
|
- delegatable: bool = 0
|
||||||
|
*)
|
||||||
|
| Create_contract_2 _ -> alloc_cost 7
|
||||||
| Set_delegate -> alloc_cost 1
|
| Set_delegate -> alloc_cost 1
|
||||||
| Now -> alloc_cost 1
|
| Now -> alloc_cost 1
|
||||||
| Balance -> alloc_cost 1
|
| Balance -> alloc_cost 1
|
||||||
@ -396,6 +454,11 @@ module Cost_of = struct
|
|||||||
| Sender -> alloc_cost 1
|
| Sender -> alloc_cost 1
|
||||||
| Self _ -> alloc_cost 2
|
| Self _ -> alloc_cost 2
|
||||||
| Amount -> alloc_cost 1
|
| Amount -> alloc_cost 1
|
||||||
|
| Dig (n,_) -> n *@ alloc_cost 1 (* _ is a unary development of n *)
|
||||||
|
| Dug (n,_) -> n *@ alloc_cost 1
|
||||||
|
| Dipn (n,_,_) -> n *@ alloc_cost 1
|
||||||
|
| Dropn (n,_) -> n *@ alloc_cost 1
|
||||||
|
| ChainId -> alloc_cost 1
|
||||||
end
|
end
|
||||||
|
|
||||||
module Unparse = struct
|
module Unparse = struct
|
||||||
@ -415,6 +478,7 @@ module Cost_of = struct
|
|||||||
let tez = Script.int_node_cost_of_numbits 60 (* int64 bound *)
|
let tez = Script.int_node_cost_of_numbits 60 (* int64 bound *)
|
||||||
let timestamp x = Script_timestamp.to_zint x |> Script_int.of_zint |> int
|
let timestamp x = Script_timestamp.to_zint x |> Script_int.of_zint |> int
|
||||||
let operation bytes = Script.bytes_node_cost bytes
|
let operation bytes = Script.bytes_node_cost bytes
|
||||||
|
let chain_id bytes = Script.bytes_node_cost bytes
|
||||||
let key = string_cost 54
|
let key = string_cost 54
|
||||||
let key_hash = string_cost 36
|
let key_hash = string_cost 36
|
||||||
let signature = string_cost 128
|
let signature = string_cost 128
|
||||||
@ -429,8 +493,8 @@ module Cost_of = struct
|
|||||||
let one_arg_type = prim_cost 1
|
let one_arg_type = prim_cost 1
|
||||||
let two_arg_type = prim_cost 2
|
let two_arg_type = prim_cost 2
|
||||||
|
|
||||||
let set_to_list = set_to_list
|
let set_to_list = Legacy.set_to_list
|
||||||
let map_to_list = map_to_list
|
let map_to_list = Legacy.map_to_list
|
||||||
end
|
end
|
||||||
|
|
||||||
end
|
end
|
||||||
|
@ -26,11 +26,26 @@
|
|||||||
open Alpha_context
|
open Alpha_context
|
||||||
|
|
||||||
module Cost_of : sig
|
module Cost_of : sig
|
||||||
|
|
||||||
|
val manager_operation : Gas.cost
|
||||||
|
|
||||||
|
module Legacy : sig
|
||||||
|
val z_to_int64 : Gas.cost
|
||||||
|
val hash : MBytes.t -> int -> Gas.cost
|
||||||
|
val map_to_list :
|
||||||
|
('b, 'c) Script_typed_ir.map -> Gas.cost
|
||||||
|
val set_update : 'a -> bool -> 'a Script_typed_ir.set -> Gas.cost
|
||||||
|
end
|
||||||
|
|
||||||
|
module Interpreter : sig
|
||||||
val cycle : Gas.cost
|
val cycle : Gas.cost
|
||||||
val loop_cycle : Gas.cost
|
val loop_cycle : Gas.cost
|
||||||
val list_size : Gas.cost
|
val loop_size : Gas.cost
|
||||||
|
val loop_iter : Gas.cost
|
||||||
|
val loop_map : Gas.cost
|
||||||
val nop : Gas.cost
|
val nop : Gas.cost
|
||||||
val stack_op : Gas.cost
|
val stack_op : Gas.cost
|
||||||
|
val stack_n_op : int -> Gas.cost
|
||||||
val bool_binop : 'a -> 'b -> Gas.cost
|
val bool_binop : 'a -> 'b -> Gas.cost
|
||||||
val bool_unop : 'a -> Gas.cost
|
val bool_unop : 'a -> Gas.cost
|
||||||
val pair : Gas.cost
|
val pair : Gas.cost
|
||||||
@ -41,19 +56,11 @@ module Cost_of : sig
|
|||||||
val concat_string : string list -> Gas.cost
|
val concat_string : string list -> Gas.cost
|
||||||
val concat_bytes : MBytes.t list -> Gas.cost
|
val concat_bytes : MBytes.t list -> Gas.cost
|
||||||
val slice_string : int -> Gas.cost
|
val slice_string : int -> Gas.cost
|
||||||
val slice_bytes : Gas.cost
|
val map_mem : 'a -> ('a, 'b) Script_typed_ir.map -> Gas.cost
|
||||||
val map_mem :
|
val map_to_list : ('a, 'b) Script_typed_ir.map -> Gas.cost
|
||||||
'a -> ('b, 'c) Script_typed_ir.map -> Gas.cost
|
val map_get : 'a -> ('a, 'b) Script_typed_ir.map -> Gas.cost
|
||||||
val map_to_list :
|
val map_update : 'a -> 'b option -> ('a, 'b) Script_typed_ir.map -> Gas.cost
|
||||||
('b, 'c) Script_typed_ir.map -> Gas.cost
|
|
||||||
val map_get :
|
|
||||||
'a -> ('b, 'c) Script_typed_ir.map -> Gas.cost
|
|
||||||
val map_update :
|
|
||||||
'a -> 'b -> ('c, 'd) Script_typed_ir.map -> Gas.cost
|
|
||||||
val map_size : Gas.cost
|
val map_size : Gas.cost
|
||||||
val big_map_mem : 'key -> ('key, 'value) Script_typed_ir.big_map -> Gas.cost
|
|
||||||
val big_map_get : 'key -> ('key, 'value) Script_typed_ir.big_map -> Gas.cost
|
|
||||||
val big_map_update : 'key -> 'value option -> ('key, 'value) Script_typed_ir.big_map -> Gas.cost
|
|
||||||
val set_to_list : 'a Script_typed_ir.set -> Gas.cost
|
val set_to_list : 'a Script_typed_ir.set -> Gas.cost
|
||||||
val set_update : 'a -> bool -> 'a Script_typed_ir.set -> Gas.cost
|
val set_update : 'a -> bool -> 'a Script_typed_ir.set -> Gas.cost
|
||||||
val set_mem : 'a -> 'a Script_typed_ir.set -> Gas.cost
|
val set_mem : 'a -> 'a Script_typed_ir.set -> Gas.cost
|
||||||
@ -73,7 +80,6 @@ module Cost_of : sig
|
|||||||
val int64_op : Gas.cost
|
val int64_op : Gas.cost
|
||||||
val z_to_int64 : Gas.cost
|
val z_to_int64 : Gas.cost
|
||||||
val int64_to_z : Gas.cost
|
val int64_to_z : Gas.cost
|
||||||
val bitwise_binop : 'a Script_int.num -> 'b Script_int.num -> Gas.cost
|
|
||||||
val logor : 'a Script_int.num -> 'b Script_int.num -> Gas.cost
|
val logor : 'a Script_int.num -> 'b Script_int.num -> Gas.cost
|
||||||
val logand : 'a Script_int.num -> 'b Script_int.num -> Gas.cost
|
val logand : 'a Script_int.num -> 'b Script_int.num -> Gas.cost
|
||||||
val logxor : 'a Script_int.num -> 'b Script_int.num -> Gas.cost
|
val logxor : 'a Script_int.num -> 'b Script_int.num -> Gas.cost
|
||||||
@ -93,25 +99,20 @@ module Cost_of : sig
|
|||||||
val set_delegate : Gas.cost
|
val set_delegate : Gas.cost
|
||||||
val balance : Gas.cost
|
val balance : Gas.cost
|
||||||
val now : Gas.cost
|
val now : Gas.cost
|
||||||
val check_signature : Gas.cost
|
val check_signature : public_key -> MBytes.t -> Gas.cost
|
||||||
val hash_key : Gas.cost
|
val hash_key : Gas.cost
|
||||||
val hash : MBytes.t -> int -> Gas.cost
|
val hash_blake2b : MBytes.t -> Gas.cost
|
||||||
|
val hash_sha256 : MBytes.t -> Gas.cost
|
||||||
|
val hash_sha512 : MBytes.t -> Gas.cost
|
||||||
val steps_to_quota : Gas.cost
|
val steps_to_quota : Gas.cost
|
||||||
val source : Gas.cost
|
val source : Gas.cost
|
||||||
val self : Gas.cost
|
val self : Gas.cost
|
||||||
val amount : Gas.cost
|
val amount : Gas.cost
|
||||||
|
val chain_id : Gas.cost
|
||||||
val wrap : Gas.cost
|
val wrap : Gas.cost
|
||||||
val compare_bool : 'a -> 'b -> Gas.cost
|
val compare : 'a Script_typed_ir.comparable_ty -> 'a -> 'a -> Gas.cost
|
||||||
val compare_string : string -> string -> Gas.cost
|
val apply : Gas.cost
|
||||||
val compare_bytes : MBytes.t -> MBytes.t -> Gas.cost
|
end
|
||||||
val compare_tez : 'a -> 'b -> Gas.cost
|
|
||||||
val compare_int : 'a Script_int.num -> 'b Script_int.num -> Gas.cost
|
|
||||||
val compare_nat : 'a Script_int.num -> 'b Script_int.num -> Gas.cost
|
|
||||||
val compare_key_hash : 'a -> 'b -> Gas.cost
|
|
||||||
val compare_timestamp : Script_timestamp.t -> Script_timestamp.t -> Gas.cost
|
|
||||||
val compare_address : Contract.t -> Contract.t -> Gas.cost
|
|
||||||
|
|
||||||
val manager_operation : Gas.cost
|
|
||||||
|
|
||||||
module Typechecking : sig
|
module Typechecking : sig
|
||||||
val cycle : Gas.cost
|
val cycle : Gas.cost
|
||||||
@ -126,6 +127,7 @@ module Cost_of : sig
|
|||||||
val key : Gas.cost
|
val key : Gas.cost
|
||||||
val key_hash : Gas.cost
|
val key_hash : Gas.cost
|
||||||
val signature : Gas.cost
|
val signature : Gas.cost
|
||||||
|
val chain_id : Gas.cost
|
||||||
|
|
||||||
val contract : Gas.cost
|
val contract : Gas.cost
|
||||||
|
|
||||||
@ -177,6 +179,7 @@ module Cost_of : sig
|
|||||||
val key_hash : Gas.cost
|
val key_hash : Gas.cost
|
||||||
val signature : Gas.cost
|
val signature : Gas.cost
|
||||||
val operation : MBytes.t -> Gas.cost
|
val operation : MBytes.t -> Gas.cost
|
||||||
|
val chain_id : MBytes.t -> Gas.cost
|
||||||
|
|
||||||
val contract : Gas.cost
|
val contract : Gas.cost
|
||||||
|
|
||||||
|
@ -54,6 +54,7 @@ type prim =
|
|||||||
| I_BALANCE
|
| I_BALANCE
|
||||||
| I_CAR
|
| I_CAR
|
||||||
| I_CDR
|
| I_CDR
|
||||||
|
| I_CHAIN_ID
|
||||||
| I_CHECK_SIGNATURE
|
| I_CHECK_SIGNATURE
|
||||||
| I_COMPARE
|
| I_COMPARE
|
||||||
| I_CONCAT
|
| I_CONCAT
|
||||||
@ -65,10 +66,12 @@ type prim =
|
|||||||
| I_DROP
|
| I_DROP
|
||||||
| I_DUP
|
| I_DUP
|
||||||
| I_EDIV
|
| I_EDIV
|
||||||
|
| I_EMPTY_BIG_MAP
|
||||||
| I_EMPTY_MAP
|
| I_EMPTY_MAP
|
||||||
| I_EMPTY_SET
|
| I_EMPTY_SET
|
||||||
| I_EQ
|
| I_EQ
|
||||||
| I_EXEC
|
| I_EXEC
|
||||||
|
| I_APPLY
|
||||||
| I_FAILWITH
|
| I_FAILWITH
|
||||||
| I_GE
|
| I_GE
|
||||||
| I_GET
|
| I_GET
|
||||||
@ -120,6 +123,8 @@ type prim =
|
|||||||
| I_ISNAT
|
| I_ISNAT
|
||||||
| I_CAST
|
| I_CAST
|
||||||
| I_RENAME
|
| I_RENAME
|
||||||
|
| I_DIG
|
||||||
|
| I_DUG
|
||||||
| T_bool
|
| T_bool
|
||||||
| T_contract
|
| T_contract
|
||||||
| T_int
|
| T_int
|
||||||
@ -142,6 +147,7 @@ type prim =
|
|||||||
| T_unit
|
| T_unit
|
||||||
| T_operation
|
| T_operation
|
||||||
| T_address
|
| T_address
|
||||||
|
| T_chain_id
|
||||||
|
|
||||||
let valid_case name =
|
let valid_case name =
|
||||||
let is_lower = function '_' | 'a'..'z' -> true | _ -> false in
|
let is_lower = function '_' | 'a'..'z' -> true | _ -> false in
|
||||||
@ -187,6 +193,7 @@ let string_of_prim = function
|
|||||||
| I_BALANCE -> "BALANCE"
|
| I_BALANCE -> "BALANCE"
|
||||||
| I_CAR -> "CAR"
|
| I_CAR -> "CAR"
|
||||||
| I_CDR -> "CDR"
|
| I_CDR -> "CDR"
|
||||||
|
| I_CHAIN_ID -> "CHAIN_ID"
|
||||||
| I_CHECK_SIGNATURE -> "CHECK_SIGNATURE"
|
| I_CHECK_SIGNATURE -> "CHECK_SIGNATURE"
|
||||||
| I_COMPARE -> "COMPARE"
|
| I_COMPARE -> "COMPARE"
|
||||||
| I_CONCAT -> "CONCAT"
|
| I_CONCAT -> "CONCAT"
|
||||||
@ -198,10 +205,12 @@ let string_of_prim = function
|
|||||||
| I_DROP -> "DROP"
|
| I_DROP -> "DROP"
|
||||||
| I_DUP -> "DUP"
|
| I_DUP -> "DUP"
|
||||||
| I_EDIV -> "EDIV"
|
| I_EDIV -> "EDIV"
|
||||||
|
| I_EMPTY_BIG_MAP -> "EMPTY_BIG_MAP"
|
||||||
| I_EMPTY_MAP -> "EMPTY_MAP"
|
| I_EMPTY_MAP -> "EMPTY_MAP"
|
||||||
| I_EMPTY_SET -> "EMPTY_SET"
|
| I_EMPTY_SET -> "EMPTY_SET"
|
||||||
| I_EQ -> "EQ"
|
| I_EQ -> "EQ"
|
||||||
| I_EXEC -> "EXEC"
|
| I_EXEC -> "EXEC"
|
||||||
|
| I_APPLY -> "APPLY"
|
||||||
| I_FAILWITH -> "FAILWITH"
|
| I_FAILWITH -> "FAILWITH"
|
||||||
| I_GE -> "GE"
|
| I_GE -> "GE"
|
||||||
| I_GET -> "GET"
|
| I_GET -> "GET"
|
||||||
@ -253,6 +262,8 @@ let string_of_prim = function
|
|||||||
| I_ISNAT -> "ISNAT"
|
| I_ISNAT -> "ISNAT"
|
||||||
| I_CAST -> "CAST"
|
| I_CAST -> "CAST"
|
||||||
| I_RENAME -> "RENAME"
|
| I_RENAME -> "RENAME"
|
||||||
|
| I_DIG -> "DIG"
|
||||||
|
| I_DUG -> "DUG"
|
||||||
| T_bool -> "bool"
|
| T_bool -> "bool"
|
||||||
| T_contract -> "contract"
|
| T_contract -> "contract"
|
||||||
| T_int -> "int"
|
| T_int -> "int"
|
||||||
@ -275,6 +286,7 @@ let string_of_prim = function
|
|||||||
| T_unit -> "unit"
|
| T_unit -> "unit"
|
||||||
| T_operation -> "operation"
|
| T_operation -> "operation"
|
||||||
| T_address -> "address"
|
| T_address -> "address"
|
||||||
|
| T_chain_id -> "chain_id"
|
||||||
|
|
||||||
let prim_of_string = function
|
let prim_of_string = function
|
||||||
| "parameter" -> ok K_parameter
|
| "parameter" -> ok K_parameter
|
||||||
@ -301,6 +313,7 @@ let prim_of_string = function
|
|||||||
| "BALANCE" -> ok I_BALANCE
|
| "BALANCE" -> ok I_BALANCE
|
||||||
| "CAR" -> ok I_CAR
|
| "CAR" -> ok I_CAR
|
||||||
| "CDR" -> ok I_CDR
|
| "CDR" -> ok I_CDR
|
||||||
|
| "CHAIN_ID" -> ok I_CHAIN_ID
|
||||||
| "CHECK_SIGNATURE" -> ok I_CHECK_SIGNATURE
|
| "CHECK_SIGNATURE" -> ok I_CHECK_SIGNATURE
|
||||||
| "COMPARE" -> ok I_COMPARE
|
| "COMPARE" -> ok I_COMPARE
|
||||||
| "CONCAT" -> ok I_CONCAT
|
| "CONCAT" -> ok I_CONCAT
|
||||||
@ -312,10 +325,12 @@ let prim_of_string = function
|
|||||||
| "DROP" -> ok I_DROP
|
| "DROP" -> ok I_DROP
|
||||||
| "DUP" -> ok I_DUP
|
| "DUP" -> ok I_DUP
|
||||||
| "EDIV" -> ok I_EDIV
|
| "EDIV" -> ok I_EDIV
|
||||||
|
| "EMPTY_BIG_MAP" -> ok I_EMPTY_BIG_MAP
|
||||||
| "EMPTY_MAP" -> ok I_EMPTY_MAP
|
| "EMPTY_MAP" -> ok I_EMPTY_MAP
|
||||||
| "EMPTY_SET" -> ok I_EMPTY_SET
|
| "EMPTY_SET" -> ok I_EMPTY_SET
|
||||||
| "EQ" -> ok I_EQ
|
| "EQ" -> ok I_EQ
|
||||||
| "EXEC" -> ok I_EXEC
|
| "EXEC" -> ok I_EXEC
|
||||||
|
| "APPLY" -> ok I_APPLY
|
||||||
| "FAILWITH" -> ok I_FAILWITH
|
| "FAILWITH" -> ok I_FAILWITH
|
||||||
| "GE" -> ok I_GE
|
| "GE" -> ok I_GE
|
||||||
| "GET" -> ok I_GET
|
| "GET" -> ok I_GET
|
||||||
@ -367,6 +382,8 @@ let prim_of_string = function
|
|||||||
| "ISNAT" -> ok I_ISNAT
|
| "ISNAT" -> ok I_ISNAT
|
||||||
| "CAST" -> ok I_CAST
|
| "CAST" -> ok I_CAST
|
||||||
| "RENAME" -> ok I_RENAME
|
| "RENAME" -> ok I_RENAME
|
||||||
|
| "DIG" -> ok I_DIG
|
||||||
|
| "DUG" -> ok I_DUG
|
||||||
| "bool" -> ok T_bool
|
| "bool" -> ok T_bool
|
||||||
| "contract" -> ok T_contract
|
| "contract" -> ok T_contract
|
||||||
| "int" -> ok T_int
|
| "int" -> ok T_int
|
||||||
@ -389,6 +406,7 @@ let prim_of_string = function
|
|||||||
| "unit" -> ok T_unit
|
| "unit" -> ok T_unit
|
||||||
| "operation" -> ok T_operation
|
| "operation" -> ok T_operation
|
||||||
| "address" -> ok T_address
|
| "address" -> ok T_address
|
||||||
|
| "chain_id" -> ok T_chain_id
|
||||||
| n ->
|
| n ->
|
||||||
if valid_case n then
|
if valid_case n then
|
||||||
error (Unknown_primitive_name n)
|
error (Unknown_primitive_name n)
|
||||||
@ -436,6 +454,7 @@ let prim_encoding =
|
|||||||
let open Data_encoding in
|
let open Data_encoding in
|
||||||
def "michelson.v1.primitives" @@
|
def "michelson.v1.primitives" @@
|
||||||
string_enum [
|
string_enum [
|
||||||
|
(* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
|
||||||
("parameter", K_parameter) ;
|
("parameter", K_parameter) ;
|
||||||
("storage", K_storage) ;
|
("storage", K_storage) ;
|
||||||
("code", K_code) ;
|
("code", K_code) ;
|
||||||
@ -446,6 +465,7 @@ let prim_encoding =
|
|||||||
("Pair", D_Pair) ;
|
("Pair", D_Pair) ;
|
||||||
("Right", D_Right) ;
|
("Right", D_Right) ;
|
||||||
("Some", D_Some) ;
|
("Some", D_Some) ;
|
||||||
|
(* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
|
||||||
("True", D_True) ;
|
("True", D_True) ;
|
||||||
("Unit", D_Unit) ;
|
("Unit", D_Unit) ;
|
||||||
("PACK", I_PACK) ;
|
("PACK", I_PACK) ;
|
||||||
@ -456,6 +476,7 @@ let prim_encoding =
|
|||||||
("ABS", I_ABS) ;
|
("ABS", I_ABS) ;
|
||||||
("ADD", I_ADD) ;
|
("ADD", I_ADD) ;
|
||||||
("AMOUNT", I_AMOUNT) ;
|
("AMOUNT", I_AMOUNT) ;
|
||||||
|
(* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
|
||||||
("AND", I_AND) ;
|
("AND", I_AND) ;
|
||||||
("BALANCE", I_BALANCE) ;
|
("BALANCE", I_BALANCE) ;
|
||||||
("CAR", I_CAR) ;
|
("CAR", I_CAR) ;
|
||||||
@ -466,6 +487,7 @@ let prim_encoding =
|
|||||||
("CONS", I_CONS) ;
|
("CONS", I_CONS) ;
|
||||||
("CREATE_ACCOUNT", I_CREATE_ACCOUNT) ;
|
("CREATE_ACCOUNT", I_CREATE_ACCOUNT) ;
|
||||||
("CREATE_CONTRACT", I_CREATE_CONTRACT) ;
|
("CREATE_CONTRACT", I_CREATE_CONTRACT) ;
|
||||||
|
(* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
|
||||||
("IMPLICIT_ACCOUNT", I_IMPLICIT_ACCOUNT) ;
|
("IMPLICIT_ACCOUNT", I_IMPLICIT_ACCOUNT) ;
|
||||||
("DIP", I_DIP) ;
|
("DIP", I_DIP) ;
|
||||||
("DROP", I_DROP) ;
|
("DROP", I_DROP) ;
|
||||||
@ -476,6 +498,7 @@ let prim_encoding =
|
|||||||
("EQ", I_EQ) ;
|
("EQ", I_EQ) ;
|
||||||
("EXEC", I_EXEC) ;
|
("EXEC", I_EXEC) ;
|
||||||
("FAILWITH", I_FAILWITH) ;
|
("FAILWITH", I_FAILWITH) ;
|
||||||
|
(* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
|
||||||
("GE", I_GE) ;
|
("GE", I_GE) ;
|
||||||
("GET", I_GET) ;
|
("GET", I_GET) ;
|
||||||
("GT", I_GT) ;
|
("GT", I_GT) ;
|
||||||
@ -486,6 +509,7 @@ let prim_encoding =
|
|||||||
("IF_NONE", I_IF_NONE) ;
|
("IF_NONE", I_IF_NONE) ;
|
||||||
("INT", I_INT) ;
|
("INT", I_INT) ;
|
||||||
("LAMBDA", I_LAMBDA) ;
|
("LAMBDA", I_LAMBDA) ;
|
||||||
|
(* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
|
||||||
("LE", I_LE) ;
|
("LE", I_LE) ;
|
||||||
("LEFT", I_LEFT) ;
|
("LEFT", I_LEFT) ;
|
||||||
("LOOP", I_LOOP) ;
|
("LOOP", I_LOOP) ;
|
||||||
@ -496,6 +520,7 @@ let prim_encoding =
|
|||||||
("MEM", I_MEM) ;
|
("MEM", I_MEM) ;
|
||||||
("MUL", I_MUL) ;
|
("MUL", I_MUL) ;
|
||||||
("NEG", I_NEG) ;
|
("NEG", I_NEG) ;
|
||||||
|
(* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
|
||||||
("NEQ", I_NEQ) ;
|
("NEQ", I_NEQ) ;
|
||||||
("NIL", I_NIL) ;
|
("NIL", I_NIL) ;
|
||||||
("NONE", I_NONE) ;
|
("NONE", I_NONE) ;
|
||||||
@ -506,6 +531,7 @@ let prim_encoding =
|
|||||||
("PUSH", I_PUSH) ;
|
("PUSH", I_PUSH) ;
|
||||||
("RIGHT", I_RIGHT) ;
|
("RIGHT", I_RIGHT) ;
|
||||||
("SIZE", I_SIZE) ;
|
("SIZE", I_SIZE) ;
|
||||||
|
(* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
|
||||||
("SOME", I_SOME) ;
|
("SOME", I_SOME) ;
|
||||||
("SOURCE", I_SOURCE) ;
|
("SOURCE", I_SOURCE) ;
|
||||||
("SENDER", I_SENDER) ;
|
("SENDER", I_SENDER) ;
|
||||||
@ -516,6 +542,7 @@ let prim_encoding =
|
|||||||
("TRANSFER_TOKENS", I_TRANSFER_TOKENS) ;
|
("TRANSFER_TOKENS", I_TRANSFER_TOKENS) ;
|
||||||
("SET_DELEGATE", I_SET_DELEGATE) ;
|
("SET_DELEGATE", I_SET_DELEGATE) ;
|
||||||
("UNIT", I_UNIT) ;
|
("UNIT", I_UNIT) ;
|
||||||
|
(* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
|
||||||
("UPDATE", I_UPDATE) ;
|
("UPDATE", I_UPDATE) ;
|
||||||
("XOR", I_XOR) ;
|
("XOR", I_XOR) ;
|
||||||
("ITER", I_ITER) ;
|
("ITER", I_ITER) ;
|
||||||
@ -526,6 +553,7 @@ let prim_encoding =
|
|||||||
("CAST", I_CAST) ;
|
("CAST", I_CAST) ;
|
||||||
("RENAME", I_RENAME) ;
|
("RENAME", I_RENAME) ;
|
||||||
("bool", T_bool) ;
|
("bool", T_bool) ;
|
||||||
|
(* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
|
||||||
("contract", T_contract) ;
|
("contract", T_contract) ;
|
||||||
("int", T_int) ;
|
("int", T_int) ;
|
||||||
("key", T_key) ;
|
("key", T_key) ;
|
||||||
@ -536,6 +564,7 @@ let prim_encoding =
|
|||||||
("big_map", T_big_map) ;
|
("big_map", T_big_map) ;
|
||||||
("nat", T_nat) ;
|
("nat", T_nat) ;
|
||||||
("option", T_option) ;
|
("option", T_option) ;
|
||||||
|
(* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
|
||||||
("or", T_or) ;
|
("or", T_or) ;
|
||||||
("pair", T_pair) ;
|
("pair", T_pair) ;
|
||||||
("set", T_set) ;
|
("set", T_set) ;
|
||||||
@ -546,9 +575,18 @@ let prim_encoding =
|
|||||||
("timestamp", T_timestamp) ;
|
("timestamp", T_timestamp) ;
|
||||||
("unit", T_unit) ;
|
("unit", T_unit) ;
|
||||||
("operation", T_operation) ;
|
("operation", T_operation) ;
|
||||||
|
(* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
|
||||||
("address", T_address) ;
|
("address", T_address) ;
|
||||||
(* Alpha_002 addition *)
|
(* Alpha_002 addition *)
|
||||||
("SLICE", I_SLICE) ;
|
("SLICE", I_SLICE) ;
|
||||||
|
(* Alpha_005 addition *)
|
||||||
|
("DIG", I_DIG) ;
|
||||||
|
("DUG", I_DUG) ;
|
||||||
|
("EMPTY_BIG_MAP", I_EMPTY_BIG_MAP) ;
|
||||||
|
("APPLY", I_APPLY) ;
|
||||||
|
("chain_id", T_chain_id) ;
|
||||||
|
("CHAIN_ID", I_CHAIN_ID)
|
||||||
|
(* New instructions must be added here, for backward compatibility of the encoding. *)
|
||||||
]
|
]
|
||||||
|
|
||||||
let () =
|
let () =
|
||||||
|
@ -52,6 +52,7 @@ type prim =
|
|||||||
| I_BALANCE
|
| I_BALANCE
|
||||||
| I_CAR
|
| I_CAR
|
||||||
| I_CDR
|
| I_CDR
|
||||||
|
| I_CHAIN_ID
|
||||||
| I_CHECK_SIGNATURE
|
| I_CHECK_SIGNATURE
|
||||||
| I_COMPARE
|
| I_COMPARE
|
||||||
| I_CONCAT
|
| I_CONCAT
|
||||||
@ -63,10 +64,12 @@ type prim =
|
|||||||
| I_DROP
|
| I_DROP
|
||||||
| I_DUP
|
| I_DUP
|
||||||
| I_EDIV
|
| I_EDIV
|
||||||
|
| I_EMPTY_BIG_MAP
|
||||||
| I_EMPTY_MAP
|
| I_EMPTY_MAP
|
||||||
| I_EMPTY_SET
|
| I_EMPTY_SET
|
||||||
| I_EQ
|
| I_EQ
|
||||||
| I_EXEC
|
| I_EXEC
|
||||||
|
| I_APPLY
|
||||||
| I_FAILWITH
|
| I_FAILWITH
|
||||||
| I_GE
|
| I_GE
|
||||||
| I_GET
|
| I_GET
|
||||||
@ -118,6 +121,8 @@ type prim =
|
|||||||
| I_ISNAT
|
| I_ISNAT
|
||||||
| I_CAST
|
| I_CAST
|
||||||
| I_RENAME
|
| I_RENAME
|
||||||
|
| I_DIG
|
||||||
|
| I_DUG
|
||||||
| T_bool
|
| T_bool
|
||||||
| T_contract
|
| T_contract
|
||||||
| T_int
|
| T_int
|
||||||
@ -140,6 +145,7 @@ type prim =
|
|||||||
| T_unit
|
| T_unit
|
||||||
| T_operation
|
| T_operation
|
||||||
| T_address
|
| T_address
|
||||||
|
| T_chain_id
|
||||||
|
|
||||||
val prim_encoding : prim Data_encoding.encoding
|
val prim_encoding : prim Data_encoding.encoding
|
||||||
|
|
||||||
|
@ -23,7 +23,7 @@
|
|||||||
(* *)
|
(* *)
|
||||||
(*****************************************************************************)
|
(*****************************************************************************)
|
||||||
|
|
||||||
(** {2 Stuff} ****************************************************************)
|
(** {2 Helper functions} *)
|
||||||
|
|
||||||
type 'a lazyt = unit -> 'a
|
type 'a lazyt = unit -> 'a
|
||||||
type 'a lazy_list_t = LCons of 'a * ('a lazy_list_t tzresult Lwt.t lazyt)
|
type 'a lazy_list_t = LCons of 'a * ('a lazy_list_t tzresult Lwt.t lazyt)
|
||||||
|
@ -98,7 +98,7 @@ and _ contents =
|
|||||||
ballot: Vote_repr.ballot ;
|
ballot: Vote_repr.ballot ;
|
||||||
} -> Kind.ballot contents
|
} -> Kind.ballot contents
|
||||||
| Manager_operation : {
|
| Manager_operation : {
|
||||||
source: Contract_repr.contract ;
|
source: Signature.public_key_hash ;
|
||||||
fee: Tez_repr.tez ;
|
fee: Tez_repr.tez ;
|
||||||
counter: counter ;
|
counter: counter ;
|
||||||
operation: 'kind manager_operation ;
|
operation: 'kind manager_operation ;
|
||||||
@ -110,15 +110,13 @@ and _ manager_operation =
|
|||||||
| Reveal : Signature.Public_key.t -> Kind.reveal manager_operation
|
| Reveal : Signature.Public_key.t -> Kind.reveal manager_operation
|
||||||
| Transaction : {
|
| Transaction : {
|
||||||
amount: Tez_repr.tez ;
|
amount: Tez_repr.tez ;
|
||||||
parameters: Script_repr.lazy_expr option ;
|
parameters: Script_repr.lazy_expr ;
|
||||||
|
entrypoint: string ;
|
||||||
destination: Contract_repr.contract ;
|
destination: Contract_repr.contract ;
|
||||||
} -> Kind.transaction manager_operation
|
} -> Kind.transaction manager_operation
|
||||||
| Origination : {
|
| Origination : {
|
||||||
manager: Signature.Public_key_hash.t ;
|
|
||||||
delegate: Signature.Public_key_hash.t option ;
|
delegate: Signature.Public_key_hash.t option ;
|
||||||
script: Script_repr.t option ;
|
script: Script_repr.t ;
|
||||||
spendable: bool ;
|
|
||||||
delegatable: bool ;
|
|
||||||
credit: Tez_repr.tez ;
|
credit: Tez_repr.tez ;
|
||||||
preorigination: Contract_repr.t option ;
|
preorigination: Contract_repr.t option ;
|
||||||
} -> Kind.origination manager_operation
|
} -> Kind.origination manager_operation
|
||||||
@ -225,6 +223,22 @@ module Encoding = struct
|
|||||||
(fun pkh -> Reveal pkh)
|
(fun pkh -> Reveal pkh)
|
||||||
}
|
}
|
||||||
|
|
||||||
|
let entrypoint_encoding =
|
||||||
|
def
|
||||||
|
~title:"entrypoint"
|
||||||
|
~description:"Named entrypoint to a Michelson smart contract"
|
||||||
|
"entrypoint" @@
|
||||||
|
let builtin_case tag name =
|
||||||
|
Data_encoding.case (Tag tag) ~title:name
|
||||||
|
(constant name)
|
||||||
|
(fun n -> if Compare.String.(n = name) then Some () else None) (fun () -> name) in
|
||||||
|
union [ builtin_case 0 "default" ;
|
||||||
|
builtin_case 1 "root" ;
|
||||||
|
builtin_case 2 "do" ;
|
||||||
|
builtin_case 3 "set_delegate" ;
|
||||||
|
builtin_case 4 "remove_delegate" ;
|
||||||
|
Data_encoding.case (Tag 255) ~title:"named" (Bounded.string 31) (fun s -> Some s) (fun s -> s) ]
|
||||||
|
|
||||||
let transaction_case =
|
let transaction_case =
|
||||||
MCase {
|
MCase {
|
||||||
tag = 1 ;
|
tag = 1 ;
|
||||||
@ -233,18 +247,29 @@ module Encoding = struct
|
|||||||
(obj3
|
(obj3
|
||||||
(req "amount" Tez_repr.encoding)
|
(req "amount" Tez_repr.encoding)
|
||||||
(req "destination" Contract_repr.encoding)
|
(req "destination" Contract_repr.encoding)
|
||||||
(opt "parameters" Script_repr.lazy_expr_encoding)) ;
|
(opt "parameters"
|
||||||
|
(obj2
|
||||||
|
(req "entrypoint" entrypoint_encoding)
|
||||||
|
(req "value" Script_repr.lazy_expr_encoding)))) ;
|
||||||
select =
|
select =
|
||||||
(function
|
(function
|
||||||
| Manager (Transaction _ as op) -> Some op
|
| Manager (Transaction _ as op) -> Some op
|
||||||
| _ -> None) ;
|
| _ -> None) ;
|
||||||
proj =
|
proj =
|
||||||
(function
|
(function
|
||||||
| Transaction { amount ; destination ; parameters } ->
|
| Transaction { amount ; destination ; parameters ; entrypoint } ->
|
||||||
|
let parameters =
|
||||||
|
if Script_repr.is_unit_parameter parameters && Compare.String.(entrypoint = "default") then
|
||||||
|
None
|
||||||
|
else
|
||||||
|
Some (entrypoint, parameters) in
|
||||||
(amount, destination, parameters)) ;
|
(amount, destination, parameters)) ;
|
||||||
inj =
|
inj =
|
||||||
(fun (amount, destination, parameters) ->
|
(fun (amount, destination, parameters) ->
|
||||||
Transaction { amount ; destination ; parameters })
|
let entrypoint, parameters = match parameters with
|
||||||
|
| None -> "default", Script_repr.unit_parameter
|
||||||
|
| Some (entrypoint, value) -> entrypoint, value in
|
||||||
|
Transaction { amount ; destination ; parameters ; entrypoint })
|
||||||
}
|
}
|
||||||
|
|
||||||
let origination_case =
|
let origination_case =
|
||||||
@ -252,32 +277,26 @@ module Encoding = struct
|
|||||||
tag = 2 ;
|
tag = 2 ;
|
||||||
name = "origination" ;
|
name = "origination" ;
|
||||||
encoding =
|
encoding =
|
||||||
(obj6
|
(obj3
|
||||||
(req "manager_pubkey" Signature.Public_key_hash.encoding)
|
|
||||||
(req "balance" Tez_repr.encoding)
|
(req "balance" Tez_repr.encoding)
|
||||||
(dft "spendable" bool true)
|
|
||||||
(dft "delegatable" bool true)
|
|
||||||
(opt "delegate" Signature.Public_key_hash.encoding)
|
(opt "delegate" Signature.Public_key_hash.encoding)
|
||||||
(opt "script" Script_repr.encoding)) ;
|
(req "script" Script_repr.encoding)) ;
|
||||||
select =
|
select =
|
||||||
(function
|
(function
|
||||||
| Manager (Origination _ as op) -> Some op
|
| Manager (Origination _ as op) -> Some op
|
||||||
| _ -> None) ;
|
| _ -> None) ;
|
||||||
proj =
|
proj =
|
||||||
(function
|
(function
|
||||||
| Origination { manager ; credit ; spendable ;
|
| Origination { credit ; delegate ; script ;
|
||||||
delegatable ; delegate ; script ;
|
|
||||||
preorigination = _
|
preorigination = _
|
||||||
(* the hash is only used internally
|
(* the hash is only used internally
|
||||||
when originating from smart
|
when originating from smart
|
||||||
contracts, don't serialize it *) } ->
|
contracts, don't serialize it *) } ->
|
||||||
(manager, credit, spendable,
|
(credit, delegate, script)) ;
|
||||||
delegatable, delegate, script)) ;
|
|
||||||
inj =
|
inj =
|
||||||
(fun (manager, credit, spendable, delegatable, delegate, script) ->
|
(fun (credit, delegate, script) ->
|
||||||
Origination
|
Origination
|
||||||
{manager ; credit ; spendable ; delegatable ;
|
{credit ; delegate ; script ; preorigination = None })
|
||||||
delegate ; script ; preorigination = None })
|
|
||||||
}
|
}
|
||||||
|
|
||||||
let delegation_case =
|
let delegation_case =
|
||||||
@ -482,7 +501,7 @@ module Encoding = struct
|
|||||||
|
|
||||||
let manager_encoding =
|
let manager_encoding =
|
||||||
(obj5
|
(obj5
|
||||||
(req "source" Contract_repr.encoding)
|
(req "source" Signature.Public_key_hash.encoding)
|
||||||
(req "fee" Tez_repr.encoding)
|
(req "fee" Tez_repr.encoding)
|
||||||
(req "counter" (check_size 10 n))
|
(req "counter" (check_size 10 n))
|
||||||
(req "gas_limit" (check_size 10 n))
|
(req "gas_limit" (check_size 10 n))
|
||||||
@ -526,10 +545,10 @@ module Encoding = struct
|
|||||||
(rebuild op (mcase.inj contents)))
|
(rebuild op (mcase.inj contents)))
|
||||||
}
|
}
|
||||||
|
|
||||||
let reveal_case = make_manager_case 7 Manager_operations.reveal_case
|
let reveal_case = make_manager_case 107 Manager_operations.reveal_case
|
||||||
let transaction_case = make_manager_case 8 Manager_operations.transaction_case
|
let transaction_case = make_manager_case 108 Manager_operations.transaction_case
|
||||||
let origination_case = make_manager_case 9 Manager_operations.origination_case
|
let origination_case = make_manager_case 109 Manager_operations.origination_case
|
||||||
let delegation_case = make_manager_case 10 Manager_operations.delegation_case
|
let delegation_case = make_manager_case 110 Manager_operations.delegation_case
|
||||||
|
|
||||||
let contents_encoding =
|
let contents_encoding =
|
||||||
let make (Case { tag ; name ; encoding ; select ; proj ; inj }) =
|
let make (Case { tag ; name ; encoding ; select ; proj ; inj }) =
|
||||||
@ -668,12 +687,12 @@ let check_signature_sync (type kind) key chain_id ({ shell ; protocol_data } : k
|
|||||||
if Signature.check ~watermark key signature unsigned_operation then
|
if Signature.check ~watermark key signature unsigned_operation then
|
||||||
Ok ()
|
Ok ()
|
||||||
else
|
else
|
||||||
Error [Invalid_signature] in
|
error Invalid_signature in
|
||||||
match protocol_data.contents, protocol_data.signature with
|
match protocol_data.contents, protocol_data.signature with
|
||||||
| Single _, None ->
|
| Single _, None ->
|
||||||
Error [Missing_signature]
|
error Missing_signature
|
||||||
| Cons _, None ->
|
| Cons _, None ->
|
||||||
Error [Missing_signature]
|
error Missing_signature
|
||||||
| Single (Endorsement _) as contents, Some signature ->
|
| Single (Endorsement _) as contents, Some signature ->
|
||||||
check ~watermark:(Endorsement chain_id) (Contents_list contents) signature
|
check ~watermark:(Endorsement chain_id) (Contents_list contents) signature
|
||||||
| Single _ as contents, Some signature ->
|
| Single _ as contents, Some signature ->
|
||||||
|
@ -99,7 +99,7 @@ and _ contents =
|
|||||||
ballot: Vote_repr.ballot ;
|
ballot: Vote_repr.ballot ;
|
||||||
} -> Kind.ballot contents
|
} -> Kind.ballot contents
|
||||||
| Manager_operation : {
|
| Manager_operation : {
|
||||||
source: Contract_repr.contract ;
|
source: Signature.Public_key_hash.t ;
|
||||||
fee: Tez_repr.tez ;
|
fee: Tez_repr.tez ;
|
||||||
counter: counter ;
|
counter: counter ;
|
||||||
operation: 'kind manager_operation ;
|
operation: 'kind manager_operation ;
|
||||||
@ -111,15 +111,13 @@ and _ manager_operation =
|
|||||||
| Reveal : Signature.Public_key.t -> Kind.reveal manager_operation
|
| Reveal : Signature.Public_key.t -> Kind.reveal manager_operation
|
||||||
| Transaction : {
|
| Transaction : {
|
||||||
amount: Tez_repr.tez ;
|
amount: Tez_repr.tez ;
|
||||||
parameters: Script_repr.lazy_expr option ;
|
parameters: Script_repr.lazy_expr ;
|
||||||
|
entrypoint: string ;
|
||||||
destination: Contract_repr.contract ;
|
destination: Contract_repr.contract ;
|
||||||
} -> Kind.transaction manager_operation
|
} -> Kind.transaction manager_operation
|
||||||
| Origination : {
|
| Origination : {
|
||||||
manager: Signature.Public_key_hash.t ;
|
|
||||||
delegate: Signature.Public_key_hash.t option ;
|
delegate: Signature.Public_key_hash.t option ;
|
||||||
script: Script_repr.t option ;
|
script: Script_repr.t ;
|
||||||
spendable: bool ;
|
|
||||||
delegatable: bool ;
|
|
||||||
credit: Tez_repr.tez ;
|
credit: Tez_repr.tez ;
|
||||||
preorigination: Contract_repr.t option ;
|
preorigination: Contract_repr.t option ;
|
||||||
} -> Kind.origination manager_operation
|
} -> Kind.origination manager_operation
|
||||||
|
@ -85,17 +85,98 @@ let bootstrap_contract_encoding =
|
|||||||
(req "amount" Tez_repr.encoding)
|
(req "amount" Tez_repr.encoding)
|
||||||
(req "script" Script_repr.encoding))
|
(req "script" Script_repr.encoding))
|
||||||
|
|
||||||
(* This encoding is used to read configuration files (e.g. sandbox.json)
|
let encoding =
|
||||||
where some fields can be missing, in that case they are replaced by
|
|
||||||
the default. *)
|
|
||||||
let constants_encoding =
|
|
||||||
let open Data_encoding in
|
let open Data_encoding in
|
||||||
conv
|
conv
|
||||||
(fun (c : Constants_repr.parametric) ->
|
(fun { bootstrap_accounts ; bootstrap_contracts ; commitments ; constants ;
|
||||||
|
security_deposit_ramp_up_cycles ; no_reward_cycles } ->
|
||||||
|
((bootstrap_accounts, bootstrap_contracts, commitments,
|
||||||
|
security_deposit_ramp_up_cycles, no_reward_cycles),
|
||||||
|
constants))
|
||||||
|
(fun ( (bootstrap_accounts, bootstrap_contracts, commitments,
|
||||||
|
security_deposit_ramp_up_cycles, no_reward_cycles),
|
||||||
|
constants) ->
|
||||||
|
{ bootstrap_accounts ; bootstrap_contracts ; commitments ; constants ;
|
||||||
|
security_deposit_ramp_up_cycles ; no_reward_cycles })
|
||||||
|
(merge_objs
|
||||||
|
(obj5
|
||||||
|
(req "bootstrap_accounts" (list bootstrap_account_encoding))
|
||||||
|
(dft "bootstrap_contracts" (list bootstrap_contract_encoding) [])
|
||||||
|
(dft "commitments" (list Commitment_repr.encoding) [])
|
||||||
|
(opt "security_deposit_ramp_up_cycles" int31)
|
||||||
|
(opt "no_reward_cycles" int31))
|
||||||
|
Constants_repr.parametric_encoding)
|
||||||
|
|
||||||
|
|
||||||
|
(* Only for migration from 004 to 005 *)
|
||||||
|
|
||||||
|
module Proto_004 = struct
|
||||||
|
|
||||||
|
type parametric = {
|
||||||
|
preserved_cycles: int ;
|
||||||
|
blocks_per_cycle: int32 ;
|
||||||
|
blocks_per_commitment: int32 ;
|
||||||
|
blocks_per_roll_snapshot: int32 ;
|
||||||
|
blocks_per_voting_period: int32 ;
|
||||||
|
time_between_blocks: Period_repr.t list ;
|
||||||
|
endorsers_per_block: int ;
|
||||||
|
hard_gas_limit_per_operation: Z.t ;
|
||||||
|
hard_gas_limit_per_block: Z.t ;
|
||||||
|
proof_of_work_threshold: int64 ;
|
||||||
|
tokens_per_roll: Tez_repr.t ;
|
||||||
|
michelson_maximum_type_size: int;
|
||||||
|
seed_nonce_revelation_tip: Tez_repr.t ;
|
||||||
|
origination_size: int ;
|
||||||
|
block_security_deposit: Tez_repr.t ;
|
||||||
|
endorsement_security_deposit: Tez_repr.t ;
|
||||||
|
block_reward: Tez_repr.t ;
|
||||||
|
endorsement_reward: Tez_repr.t ;
|
||||||
|
cost_per_byte: Tez_repr.t ;
|
||||||
|
hard_storage_limit_per_operation: Z.t ;
|
||||||
|
test_chain_duration: int64 ; (* in seconds *)
|
||||||
|
}
|
||||||
|
|
||||||
|
let default = {
|
||||||
|
preserved_cycles = 5 ;
|
||||||
|
blocks_per_cycle = 4096l ;
|
||||||
|
blocks_per_commitment = 32l ;
|
||||||
|
blocks_per_roll_snapshot = 256l ;
|
||||||
|
blocks_per_voting_period = 32768l ;
|
||||||
|
time_between_blocks =
|
||||||
|
List.map Period_repr.of_seconds_exn [ 60L ; 75L ] ;
|
||||||
|
endorsers_per_block = 32 ;
|
||||||
|
hard_gas_limit_per_operation = Z.of_int 800_000 ;
|
||||||
|
hard_gas_limit_per_block = Z.of_int 8_000_000 ;
|
||||||
|
proof_of_work_threshold =
|
||||||
|
Int64.(sub (shift_left 1L 46) 1L) ;
|
||||||
|
tokens_per_roll =
|
||||||
|
Tez_repr.(mul_exn one 8_000) ;
|
||||||
|
michelson_maximum_type_size = 1000 ;
|
||||||
|
seed_nonce_revelation_tip = begin
|
||||||
|
match Tez_repr.(one /? 8L) with
|
||||||
|
| Ok c -> c
|
||||||
|
| Error _ -> assert false
|
||||||
|
end ;
|
||||||
|
origination_size = 257 ;
|
||||||
|
block_security_deposit = Tez_repr.(mul_exn one 512) ;
|
||||||
|
endorsement_security_deposit = Tez_repr.(mul_exn one 64) ;
|
||||||
|
block_reward = Tez_repr.(mul_exn one 16) ;
|
||||||
|
endorsement_reward = Tez_repr.(mul_exn one 2) ;
|
||||||
|
hard_storage_limit_per_operation = Z.of_int 60_000 ;
|
||||||
|
cost_per_byte = Tez_repr.of_mutez_exn 1_000L ;
|
||||||
|
test_chain_duration = Int64.mul 32768L 60L;
|
||||||
|
}
|
||||||
|
|
||||||
|
(* This encoding is used to read configuration files (e.g. sandbox.json)
|
||||||
|
where some fields can be missing, in that case they are replaced by
|
||||||
|
the default. *)
|
||||||
|
let constants_encoding =
|
||||||
|
let open Data_encoding in
|
||||||
|
conv
|
||||||
|
(fun (c : parametric) ->
|
||||||
let module Compare_time_between_blocks = Compare.List (Period_repr) in
|
let module Compare_time_between_blocks = Compare.List (Period_repr) in
|
||||||
let module Compare_keys = Compare.List (Ed25519.Public_key) in
|
let module Compare_keys = Compare.List (Ed25519.Public_key) in
|
||||||
let opt (=) def v = if def = v then None else Some v in
|
let opt (=) def v = if def = v then None else Some v in
|
||||||
let default = Constants_repr.default in
|
|
||||||
let preserved_cycles =
|
let preserved_cycles =
|
||||||
opt Compare.Int.(=)
|
opt Compare.Int.(=)
|
||||||
default.preserved_cycles c.preserved_cycles
|
default.preserved_cycles c.preserved_cycles
|
||||||
@ -203,8 +284,7 @@ let constants_encoding =
|
|||||||
hard_storage_limit_per_operation,
|
hard_storage_limit_per_operation,
|
||||||
test_chain_duration))) ->
|
test_chain_duration))) ->
|
||||||
let unopt def = function None -> def | Some v -> v in
|
let unopt def = function None -> def | Some v -> v in
|
||||||
let default = Constants_repr.default in
|
{ preserved_cycles =
|
||||||
{ Constants_repr.preserved_cycles =
|
|
||||||
unopt default.preserved_cycles preserved_cycles ;
|
unopt default.preserved_cycles preserved_cycles ;
|
||||||
blocks_per_cycle =
|
blocks_per_cycle =
|
||||||
unopt default.blocks_per_cycle blocks_per_cycle ;
|
unopt default.blocks_per_cycle blocks_per_cycle ;
|
||||||
@ -275,24 +355,4 @@ let constants_encoding =
|
|||||||
(opt "hard_storage_limit_per_operation" z)
|
(opt "hard_storage_limit_per_operation" z)
|
||||||
(opt "test_chain_duration" int64))))
|
(opt "test_chain_duration" int64))))
|
||||||
|
|
||||||
let encoding =
|
end
|
||||||
let open Data_encoding in
|
|
||||||
conv
|
|
||||||
(fun { bootstrap_accounts ; bootstrap_contracts ; commitments ; constants ;
|
|
||||||
security_deposit_ramp_up_cycles ; no_reward_cycles } ->
|
|
||||||
((bootstrap_accounts, bootstrap_contracts, commitments,
|
|
||||||
security_deposit_ramp_up_cycles, no_reward_cycles),
|
|
||||||
constants))
|
|
||||||
(fun ( (bootstrap_accounts, bootstrap_contracts, commitments,
|
|
||||||
security_deposit_ramp_up_cycles, no_reward_cycles),
|
|
||||||
constants) ->
|
|
||||||
{ bootstrap_accounts ; bootstrap_contracts ; commitments ; constants ;
|
|
||||||
security_deposit_ramp_up_cycles ; no_reward_cycles })
|
|
||||||
(merge_objs
|
|
||||||
(obj5
|
|
||||||
(req "bootstrap_accounts" (list bootstrap_account_encoding))
|
|
||||||
(dft "bootstrap_contracts" (list bootstrap_contract_encoding) [])
|
|
||||||
(dft "commitments" (list Commitment_repr.encoding) [])
|
|
||||||
(opt "security_deposit_ramp_up_cycles" int31)
|
|
||||||
(opt "no_reward_cycles" int31))
|
|
||||||
constants_encoding)
|
|
||||||
|
@ -45,4 +45,34 @@ type t = {
|
|||||||
}
|
}
|
||||||
|
|
||||||
val encoding: t Data_encoding.t
|
val encoding: t Data_encoding.t
|
||||||
val constants_encoding: Constants_repr.parametric Data_encoding.t
|
|
||||||
|
|
||||||
|
(* Only for migration from 004 to 005 *)
|
||||||
|
|
||||||
|
module Proto_004 : sig
|
||||||
|
type parametric = {
|
||||||
|
preserved_cycles: int ;
|
||||||
|
blocks_per_cycle: int32 ;
|
||||||
|
blocks_per_commitment: int32 ;
|
||||||
|
blocks_per_roll_snapshot: int32 ;
|
||||||
|
blocks_per_voting_period: int32 ;
|
||||||
|
time_between_blocks: Period_repr.t list ;
|
||||||
|
endorsers_per_block: int ;
|
||||||
|
hard_gas_limit_per_operation: Z.t ;
|
||||||
|
hard_gas_limit_per_block: Z.t ;
|
||||||
|
proof_of_work_threshold: int64 ;
|
||||||
|
tokens_per_roll: Tez_repr.t ;
|
||||||
|
michelson_maximum_type_size: int;
|
||||||
|
seed_nonce_revelation_tip: Tez_repr.t ;
|
||||||
|
origination_size: int ;
|
||||||
|
block_security_deposit: Tez_repr.t ;
|
||||||
|
endorsement_security_deposit: Tez_repr.t ;
|
||||||
|
block_reward: Tez_repr.t ;
|
||||||
|
endorsement_reward: Tez_repr.t ;
|
||||||
|
cost_per_byte: Tez_repr.t ;
|
||||||
|
hard_storage_limit_per_operation: Z.t ;
|
||||||
|
test_chain_duration: int64 ;
|
||||||
|
}
|
||||||
|
|
||||||
|
val constants_encoding: parametric Data_encoding.t
|
||||||
|
end
|
||||||
|
@ -28,6 +28,8 @@ type period = t
|
|||||||
include (Compare.Int64 : Compare.S with type t := t)
|
include (Compare.Int64 : Compare.S with type t := t)
|
||||||
let encoding = Data_encoding.int64
|
let encoding = Data_encoding.int64
|
||||||
|
|
||||||
|
let rpc_arg = RPC_arg.int64
|
||||||
|
|
||||||
let pp ppf v = Format.fprintf ppf "%Ld" v
|
let pp ppf v = Format.fprintf ppf "%Ld" v
|
||||||
|
|
||||||
type error += (* `Permanent *)
|
type error += (* `Permanent *)
|
||||||
@ -73,6 +75,7 @@ let mult i p =
|
|||||||
then error Invalid_arg
|
then error Invalid_arg
|
||||||
else ok (Int64.mul (Int64.of_int32 i) p)
|
else ok (Int64.mul (Int64.of_int32 i) p)
|
||||||
|
|
||||||
|
let zero = of_seconds_exn 0L
|
||||||
let one_second = of_seconds_exn 1L
|
let one_second = of_seconds_exn 1L
|
||||||
let one_minute = of_seconds_exn 60L
|
let one_minute = of_seconds_exn 60L
|
||||||
let one_hour = of_seconds_exn 3600L
|
let one_hour = of_seconds_exn 3600L
|
||||||
|
@ -27,6 +27,7 @@ type t
|
|||||||
type period = t
|
type period = t
|
||||||
include Compare.S with type t := t
|
include Compare.S with type t := t
|
||||||
val encoding : period Data_encoding.t
|
val encoding : period Data_encoding.t
|
||||||
|
val rpc_arg : period RPC_arg.t
|
||||||
val pp: Format.formatter -> period -> unit
|
val pp: Format.formatter -> period -> unit
|
||||||
|
|
||||||
|
|
||||||
@ -41,6 +42,7 @@ val of_seconds_exn : int64 -> period
|
|||||||
|
|
||||||
val mult : int32 -> period -> period tzresult
|
val mult : int32 -> period -> period tzresult
|
||||||
|
|
||||||
|
val zero : period
|
||||||
val one_second : period
|
val one_second : period
|
||||||
val one_minute : period
|
val one_minute : period
|
||||||
val one_hour : period
|
val one_hour : period
|
||||||
|
@ -30,18 +30,22 @@ type t = {
|
|||||||
constants: Constants_repr.parametric ;
|
constants: Constants_repr.parametric ;
|
||||||
first_level: Raw_level_repr.t ;
|
first_level: Raw_level_repr.t ;
|
||||||
level: Level_repr.t ;
|
level: Level_repr.t ;
|
||||||
|
predecessor_timestamp: Time.t ;
|
||||||
timestamp: Time.t ;
|
timestamp: Time.t ;
|
||||||
fitness: Int64.t ;
|
fitness: Int64.t ;
|
||||||
deposits: Tez_repr.t Signature.Public_key_hash.Map.t ;
|
deposits: Tez_repr.t Signature.Public_key_hash.Map.t ;
|
||||||
|
included_endorsements: int ;
|
||||||
allowed_endorsements:
|
allowed_endorsements:
|
||||||
(Signature.Public_key.t * int list * bool) Signature.Public_key_hash.Map.t ;
|
(Signature.Public_key.t * int list * bool) Signature.Public_key_hash.Map.t ;
|
||||||
fees: Tez_repr.t ;
|
fees: Tez_repr.t ;
|
||||||
rewards: Tez_repr.t ;
|
rewards: Tez_repr.t ;
|
||||||
block_gas: Z.t ;
|
block_gas: Z.t ;
|
||||||
operation_gas: Gas_limit_repr.t ;
|
operation_gas: Gas_limit_repr.t ;
|
||||||
|
internal_gas: Gas_limit_repr.internal_gas ;
|
||||||
storage_space_to_pay: Z.t option ;
|
storage_space_to_pay: Z.t option ;
|
||||||
allocated_contracts: int option ;
|
allocated_contracts: int option ;
|
||||||
origination_nonce: Contract_repr.origination_nonce option ;
|
origination_nonce: Contract_repr.origination_nonce option ;
|
||||||
|
temporary_big_map: Z.t ;
|
||||||
internal_nonce: int ;
|
internal_nonce: int ;
|
||||||
internal_nonces_used: Int_set.t ;
|
internal_nonces_used: Int_set.t ;
|
||||||
}
|
}
|
||||||
@ -50,6 +54,7 @@ type context = t
|
|||||||
type root_context = t
|
type root_context = t
|
||||||
|
|
||||||
let current_level ctxt = ctxt.level
|
let current_level ctxt = ctxt.level
|
||||||
|
let predecessor_timestamp ctxt = ctxt.predecessor_timestamp
|
||||||
let current_timestamp ctxt = ctxt.timestamp
|
let current_timestamp ctxt = ctxt.timestamp
|
||||||
let current_fitness ctxt = ctxt.fitness
|
let current_fitness ctxt = ctxt.fitness
|
||||||
let first_level ctxt = ctxt.first_level
|
let first_level ctxt = ctxt.first_level
|
||||||
@ -62,6 +67,7 @@ let record_endorsement ctxt k =
|
|||||||
| Some (_, _, true) -> assert false (* right already used *)
|
| Some (_, _, true) -> assert false (* right already used *)
|
||||||
| Some (d, s, false) ->
|
| Some (d, s, false) ->
|
||||||
{ ctxt with
|
{ ctxt with
|
||||||
|
included_endorsements = ctxt.included_endorsements + (List.length s);
|
||||||
allowed_endorsements =
|
allowed_endorsements =
|
||||||
Signature.Public_key_hash.Map.add k (d,s,true) ctxt.allowed_endorsements }
|
Signature.Public_key_hash.Map.add k (d,s,true) ctxt.allowed_endorsements }
|
||||||
|
|
||||||
@ -77,6 +83,8 @@ let init_endorsements ctxt allowed_endorsements =
|
|||||||
let allowed_endorsements ctxt =
|
let allowed_endorsements ctxt =
|
||||||
ctxt.allowed_endorsements
|
ctxt.allowed_endorsements
|
||||||
|
|
||||||
|
let included_endorsements ctxt = ctxt.included_endorsements
|
||||||
|
|
||||||
type error += Too_many_internal_operations (* `Permanent *)
|
type error += Too_many_internal_operations (* `Permanent *)
|
||||||
|
|
||||||
let () =
|
let () =
|
||||||
@ -184,16 +192,22 @@ let check_gas_limit ctxt remaining =
|
|||||||
else
|
else
|
||||||
ok ()
|
ok ()
|
||||||
let set_gas_limit ctxt remaining =
|
let set_gas_limit ctxt remaining =
|
||||||
{ ctxt with operation_gas = Limited { remaining } }
|
{ ctxt with operation_gas = Limited { remaining } ;
|
||||||
|
internal_gas = Gas_limit_repr.internal_gas_zero }
|
||||||
let set_gas_unlimited ctxt =
|
let set_gas_unlimited ctxt =
|
||||||
{ ctxt with operation_gas = Unaccounted }
|
{ ctxt with operation_gas = Unaccounted }
|
||||||
let consume_gas ctxt cost =
|
let consume_gas ctxt cost =
|
||||||
Gas_limit_repr.consume ctxt.block_gas ctxt.operation_gas cost >>? fun (block_gas, operation_gas) ->
|
Gas_limit_repr.consume
|
||||||
ok { ctxt with block_gas ; operation_gas }
|
ctxt.block_gas
|
||||||
|
ctxt.operation_gas
|
||||||
|
ctxt.internal_gas
|
||||||
|
cost >>? fun (block_gas, operation_gas, internal_gas) ->
|
||||||
|
ok { ctxt with block_gas ; operation_gas ; internal_gas }
|
||||||
let check_enough_gas ctxt cost =
|
let check_enough_gas ctxt cost =
|
||||||
Gas_limit_repr.check_enough ctxt.block_gas ctxt.operation_gas cost
|
Gas_limit_repr.check_enough ctxt.block_gas ctxt.operation_gas ctxt.internal_gas cost
|
||||||
let gas_level ctxt = ctxt.operation_gas
|
let gas_level ctxt = ctxt.operation_gas
|
||||||
let block_gas_level ctxt = ctxt.block_gas
|
let block_gas_level ctxt = ctxt.block_gas
|
||||||
|
|
||||||
let gas_consumed ~since ~until =
|
let gas_consumed ~since ~until =
|
||||||
match gas_level since, gas_level until with
|
match gas_level since, gas_level until with
|
||||||
| Limited { remaining = before }, Limited { remaining = after } -> Z.sub before after
|
| Limited { remaining = before }, Limited { remaining = after } -> Z.sub before after
|
||||||
@ -318,7 +332,7 @@ let storage_error err = fail (Storage_error err)
|
|||||||
(* This key should always be populated for every version of the
|
(* This key should always be populated for every version of the
|
||||||
protocol. It's absence meaning that the context is empty. *)
|
protocol. It's absence meaning that the context is empty. *)
|
||||||
let version_key = ["version"]
|
let version_key = ["version"]
|
||||||
let version_value = "alpha_current"
|
let version_value = "babylon_005"
|
||||||
|
|
||||||
let version = "v1"
|
let version = "v1"
|
||||||
let first_level_key = [ version ; "first_level" ]
|
let first_level_key = [ version ; "first_level" ]
|
||||||
@ -400,7 +414,7 @@ let get_proto_param ctxt =
|
|||||||
let set_constants ctxt constants =
|
let set_constants ctxt constants =
|
||||||
let bytes =
|
let bytes =
|
||||||
Data_encoding.Binary.to_bytes_exn
|
Data_encoding.Binary.to_bytes_exn
|
||||||
Parameters_repr.constants_encoding constants in
|
Constants_repr.parametric_encoding constants in
|
||||||
Context.set ctxt constants_key bytes
|
Context.set ctxt constants_key bytes
|
||||||
|
|
||||||
let get_constants ctxt =
|
let get_constants ctxt =
|
||||||
@ -409,7 +423,20 @@ let get_constants ctxt =
|
|||||||
failwith "Internal error: cannot read constants in context."
|
failwith "Internal error: cannot read constants in context."
|
||||||
| Some bytes ->
|
| Some bytes ->
|
||||||
match
|
match
|
||||||
Data_encoding.Binary.of_bytes Parameters_repr.constants_encoding bytes
|
Data_encoding.Binary.of_bytes Constants_repr.parametric_encoding bytes
|
||||||
|
with
|
||||||
|
| None ->
|
||||||
|
failwith "Internal error: cannot parse constants in context."
|
||||||
|
| Some constants -> return constants
|
||||||
|
|
||||||
|
(* only for migration from 004 to 005 *)
|
||||||
|
let get_004_constants ctxt =
|
||||||
|
Context.get ctxt constants_key >>= function
|
||||||
|
| None ->
|
||||||
|
failwith "Internal error: cannot read constants in context."
|
||||||
|
| Some bytes ->
|
||||||
|
match
|
||||||
|
Data_encoding.Binary.of_bytes Parameters_repr.Proto_004.constants_encoding bytes
|
||||||
with
|
with
|
||||||
| None ->
|
| None ->
|
||||||
failwith "Internal error: cannot parse constants in context."
|
failwith "Internal error: cannot parse constants in context."
|
||||||
@ -431,7 +458,7 @@ let check_inited ctxt =
|
|||||||
else
|
else
|
||||||
storage_error (Incompatible_protocol_version s)
|
storage_error (Incompatible_protocol_version s)
|
||||||
|
|
||||||
let prepare ~level ~timestamp ~fitness ctxt =
|
let prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt =
|
||||||
Lwt.return (Raw_level_repr.of_int32 level) >>=? fun level ->
|
Lwt.return (Raw_level_repr.of_int32 level) >>=? fun level ->
|
||||||
Lwt.return (Fitness_repr.to_int64 fitness) >>=? fun fitness ->
|
Lwt.return (Fitness_repr.to_int64 fitness) >>=? fun fitness ->
|
||||||
check_inited ctxt >>=? fun () ->
|
check_inited ctxt >>=? fun () ->
|
||||||
@ -446,23 +473,27 @@ let prepare ~level ~timestamp ~fitness ctxt =
|
|||||||
level in
|
level in
|
||||||
return {
|
return {
|
||||||
context = ctxt ; constants ; level ;
|
context = ctxt ; constants ; level ;
|
||||||
|
predecessor_timestamp ;
|
||||||
timestamp ; fitness ; first_level ;
|
timestamp ; fitness ; first_level ;
|
||||||
allowed_endorsements = Signature.Public_key_hash.Map.empty ;
|
allowed_endorsements = Signature.Public_key_hash.Map.empty ;
|
||||||
|
included_endorsements = 0 ;
|
||||||
fees = Tez_repr.zero ;
|
fees = Tez_repr.zero ;
|
||||||
rewards = Tez_repr.zero ;
|
rewards = Tez_repr.zero ;
|
||||||
deposits = Signature.Public_key_hash.Map.empty ;
|
deposits = Signature.Public_key_hash.Map.empty ;
|
||||||
operation_gas = Unaccounted ;
|
operation_gas = Unaccounted ;
|
||||||
|
internal_gas = Gas_limit_repr.internal_gas_zero ;
|
||||||
storage_space_to_pay = None ;
|
storage_space_to_pay = None ;
|
||||||
allocated_contracts = None ;
|
allocated_contracts = None ;
|
||||||
block_gas = constants.Constants_repr.hard_gas_limit_per_block ;
|
block_gas = constants.Constants_repr.hard_gas_limit_per_block ;
|
||||||
origination_nonce = None ;
|
origination_nonce = None ;
|
||||||
|
temporary_big_map = Z.sub Z.zero Z.one ;
|
||||||
internal_nonce = 0 ;
|
internal_nonce = 0 ;
|
||||||
internal_nonces_used = Int_set.empty ;
|
internal_nonces_used = Int_set.empty ;
|
||||||
}
|
}
|
||||||
|
|
||||||
type previous_protocol =
|
type previous_protocol =
|
||||||
| Genesis of Parameters_repr.t
|
| Genesis of Parameters_repr.t
|
||||||
| Alpha_previous
|
| Athens_004
|
||||||
|
|
||||||
let check_and_update_protocol_version ctxt =
|
let check_and_update_protocol_version ctxt =
|
||||||
begin
|
begin
|
||||||
@ -476,8 +507,8 @@ let check_and_update_protocol_version ctxt =
|
|||||||
else if Compare.String.(s = "genesis") then
|
else if Compare.String.(s = "genesis") then
|
||||||
get_proto_param ctxt >>=? fun (param, ctxt) ->
|
get_proto_param ctxt >>=? fun (param, ctxt) ->
|
||||||
return (Genesis param, ctxt)
|
return (Genesis param, ctxt)
|
||||||
else if Compare.String.(s = "alpha_previous") then
|
else if Compare.String.(s = "athens_004") then
|
||||||
return (Alpha_previous, ctxt)
|
return (Athens_004, ctxt)
|
||||||
else
|
else
|
||||||
storage_error (Incompatible_protocol_version s)
|
storage_error (Incompatible_protocol_version s)
|
||||||
end >>=? fun (previous_proto, ctxt) ->
|
end >>=? fun (previous_proto, ctxt) ->
|
||||||
@ -494,10 +525,41 @@ let prepare_first_block ~level ~timestamp ~fitness ctxt =
|
|||||||
set_first_level ctxt first_level >>=? fun ctxt ->
|
set_first_level ctxt first_level >>=? fun ctxt ->
|
||||||
set_constants ctxt param.constants >>= fun ctxt ->
|
set_constants ctxt param.constants >>= fun ctxt ->
|
||||||
return ctxt
|
return ctxt
|
||||||
| Alpha_previous ->
|
| Athens_004 ->
|
||||||
|
get_004_constants ctxt >>=? fun c ->
|
||||||
|
let constants = Constants_repr.{
|
||||||
|
preserved_cycles = c.preserved_cycles ;
|
||||||
|
blocks_per_cycle = c.blocks_per_cycle ;
|
||||||
|
blocks_per_commitment = c.blocks_per_commitment ;
|
||||||
|
blocks_per_roll_snapshot = c.blocks_per_roll_snapshot ;
|
||||||
|
blocks_per_voting_period = c.blocks_per_voting_period ;
|
||||||
|
time_between_blocks =
|
||||||
|
List.map Period_repr.of_seconds_exn [ 60L ; 40L ] ;
|
||||||
|
endorsers_per_block = c.endorsers_per_block ;
|
||||||
|
hard_gas_limit_per_operation = c.hard_gas_limit_per_operation ;
|
||||||
|
hard_gas_limit_per_block = c.hard_gas_limit_per_block ;
|
||||||
|
proof_of_work_threshold = c.proof_of_work_threshold ;
|
||||||
|
tokens_per_roll = c.tokens_per_roll ;
|
||||||
|
michelson_maximum_type_size = c.michelson_maximum_type_size;
|
||||||
|
seed_nonce_revelation_tip = c.seed_nonce_revelation_tip ;
|
||||||
|
origination_size = c.origination_size ;
|
||||||
|
block_security_deposit = c.block_security_deposit ;
|
||||||
|
endorsement_security_deposit = c.endorsement_security_deposit ;
|
||||||
|
block_reward = c.block_reward ;
|
||||||
|
endorsement_reward = c.endorsement_reward ;
|
||||||
|
cost_per_byte = c.cost_per_byte ;
|
||||||
|
hard_storage_limit_per_operation = c.hard_storage_limit_per_operation ;
|
||||||
|
test_chain_duration = c.test_chain_duration ;
|
||||||
|
quorum_min = 20_00l ; (* quorum is in centile of a percentage *)
|
||||||
|
quorum_max = 70_00l ;
|
||||||
|
min_proposal_quorum = 5_00l ;
|
||||||
|
initial_endorsers = 24 ;
|
||||||
|
delay_per_missing_endorsement = Period_repr.of_seconds_exn 8L ;
|
||||||
|
} in
|
||||||
|
set_constants ctxt constants >>= fun ctxt ->
|
||||||
return ctxt
|
return ctxt
|
||||||
end >>=? fun ctxt ->
|
end >>=? fun ctxt ->
|
||||||
prepare ctxt ~level ~timestamp ~fitness >>=? fun ctxt ->
|
prepare ctxt ~level ~predecessor_timestamp:timestamp ~timestamp ~fitness >>=? fun ctxt ->
|
||||||
return (previous_proto, ctxt)
|
return (previous_proto, ctxt)
|
||||||
|
|
||||||
let activate ({ context = c ; _ } as s) h =
|
let activate ({ context = c ; _ } as s) h =
|
||||||
@ -507,30 +569,6 @@ let fork_test_chain ({ context = c ; _ } as s) protocol expiration =
|
|||||||
Updater.fork_test_chain c ~protocol ~expiration >>= fun c ->
|
Updater.fork_test_chain c ~protocol ~expiration >>= fun c ->
|
||||||
Lwt.return { s with context = 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 ;
|
|
||||||
allowed_endorsements = Signature.Public_key_hash.Map.empty ;
|
|
||||||
storage_space_to_pay = None ;
|
|
||||||
allocated_contracts = None ;
|
|
||||||
fees = Tez_repr.zero ;
|
|
||||||
rewards = Tez_repr.zero ;
|
|
||||||
deposits = Signature.Public_key_hash.Map.empty ;
|
|
||||||
block_gas = Constants_repr.default.hard_gas_limit_per_block ;
|
|
||||||
operation_gas = Unaccounted ;
|
|
||||||
origination_nonce = None ;
|
|
||||||
internal_nonce = 0 ;
|
|
||||||
internal_nonces_used = Int_set.empty ;
|
|
||||||
} in
|
|
||||||
resolve faked_context str in
|
|
||||||
Context.register_resolver enc resolve
|
|
||||||
|
|
||||||
(* Generic context ********************************************************)
|
(* Generic context ********************************************************)
|
||||||
|
|
||||||
type key = string list
|
type key = string list
|
||||||
@ -650,3 +688,19 @@ let project x = x
|
|||||||
let absolute_key _ k = k
|
let absolute_key _ k = k
|
||||||
|
|
||||||
let description = Storage_description.create ()
|
let description = Storage_description.create ()
|
||||||
|
|
||||||
|
let fresh_temporary_big_map ctxt =
|
||||||
|
{ ctxt with temporary_big_map = Z.sub ctxt.temporary_big_map Z.one },
|
||||||
|
ctxt.temporary_big_map
|
||||||
|
|
||||||
|
let reset_temporary_big_map ctxt =
|
||||||
|
{ ctxt with temporary_big_map = Z.sub Z.zero Z.one }
|
||||||
|
|
||||||
|
let temporary_big_maps ctxt f acc =
|
||||||
|
let rec iter acc id =
|
||||||
|
if Z.equal id ctxt.temporary_big_map then
|
||||||
|
Lwt.return acc
|
||||||
|
else
|
||||||
|
f acc id >>= fun acc ->
|
||||||
|
iter acc (Z.sub id Z.one) in
|
||||||
|
iter acc (Z.sub Z.zero Z.one)
|
||||||
|
@ -23,7 +23,7 @@
|
|||||||
(* *)
|
(* *)
|
||||||
(*****************************************************************************)
|
(*****************************************************************************)
|
||||||
|
|
||||||
(** {1 Errors} ****************************************************************)
|
(** {1 Errors} *)
|
||||||
|
|
||||||
type error += Too_many_internal_operations (* `Permanent *)
|
type error += Too_many_internal_operations (* `Permanent *)
|
||||||
|
|
||||||
@ -40,7 +40,7 @@ type error += Failed_to_decode_parameter of Data_encoding.json * string
|
|||||||
|
|
||||||
val storage_error: storage_error -> 'a tzresult Lwt.t
|
val storage_error: storage_error -> 'a tzresult Lwt.t
|
||||||
|
|
||||||
(** {1 Abstract Context} **************************************************)
|
(** {1 Abstract Context} *)
|
||||||
|
|
||||||
(** Abstract view of the context.
|
(** Abstract view of the context.
|
||||||
Includes a handle to the functional key-value database
|
Includes a handle to the functional key-value database
|
||||||
@ -54,13 +54,14 @@ type root_context = t
|
|||||||
with this version of the protocol. *)
|
with this version of the protocol. *)
|
||||||
val prepare:
|
val prepare:
|
||||||
level: Int32.t ->
|
level: Int32.t ->
|
||||||
|
predecessor_timestamp: Time.t ->
|
||||||
timestamp: Time.t ->
|
timestamp: Time.t ->
|
||||||
fitness: Fitness.t ->
|
fitness: Fitness.t ->
|
||||||
Context.t -> context tzresult Lwt.t
|
Context.t -> context tzresult Lwt.t
|
||||||
|
|
||||||
type previous_protocol =
|
type previous_protocol =
|
||||||
| Genesis of Parameters_repr.t
|
| Genesis of Parameters_repr.t
|
||||||
| Alpha_previous
|
| Athens_004
|
||||||
|
|
||||||
val prepare_first_block:
|
val prepare_first_block:
|
||||||
level:int32 ->
|
level:int32 ->
|
||||||
@ -71,14 +72,12 @@ val prepare_first_block:
|
|||||||
val activate: context -> Protocol_hash.t -> t Lwt.t
|
val activate: context -> Protocol_hash.t -> t Lwt.t
|
||||||
val fork_test_chain: context -> Protocol_hash.t -> Time.t -> t Lwt.t
|
val fork_test_chain: context -> Protocol_hash.t -> Time.t -> t Lwt.t
|
||||||
|
|
||||||
val register_resolvers:
|
|
||||||
'a Base58.encoding -> (context -> string -> 'a list Lwt.t) -> unit
|
|
||||||
|
|
||||||
(** Returns the state of the database resulting of operations on its
|
(** Returns the state of the database resulting of operations on its
|
||||||
abstract view *)
|
abstract view *)
|
||||||
val recover: context -> Context.t
|
val recover: context -> Context.t
|
||||||
|
|
||||||
val current_level: context -> Level_repr.t
|
val current_level: context -> Level_repr.t
|
||||||
|
val predecessor_timestamp: context -> Time.t
|
||||||
val current_timestamp: context -> Time.t
|
val current_timestamp: context -> Time.t
|
||||||
|
|
||||||
val current_fitness: context -> Int64.t
|
val current_fitness: context -> Int64.t
|
||||||
@ -129,7 +128,7 @@ val origination_nonce: t -> Contract_repr.origination_nonce tzresult
|
|||||||
val increment_origination_nonce: t -> (t * Contract_repr.origination_nonce) tzresult
|
val increment_origination_nonce: t -> (t * Contract_repr.origination_nonce) tzresult
|
||||||
val unset_origination_nonce: t -> t
|
val unset_origination_nonce: t -> t
|
||||||
|
|
||||||
(** {1 Generic accessors} *************************************************)
|
(** {1 Generic accessors} *)
|
||||||
|
|
||||||
type key = string list
|
type key = string list
|
||||||
|
|
||||||
@ -241,6 +240,9 @@ val allowed_endorsements:
|
|||||||
context ->
|
context ->
|
||||||
(Signature.Public_key.t * int list * bool) Signature.Public_key_hash.Map.t
|
(Signature.Public_key.t * int list * bool) Signature.Public_key_hash.Map.t
|
||||||
|
|
||||||
|
(** Keep track of the number of endorsements that are included in a block *)
|
||||||
|
val included_endorsements: context -> int
|
||||||
|
|
||||||
(** Initializes the map of allowed endorsements, this function must only be
|
(** Initializes the map of allowed endorsements, this function must only be
|
||||||
called once. *)
|
called once. *)
|
||||||
val init_endorsements:
|
val init_endorsements:
|
||||||
@ -251,3 +253,12 @@ val init_endorsements:
|
|||||||
(** Marks an endorsment in the map as used. *)
|
(** Marks an endorsment in the map as used. *)
|
||||||
val record_endorsement:
|
val record_endorsement:
|
||||||
context -> Signature.Public_key_hash.t -> context
|
context -> Signature.Public_key_hash.t -> context
|
||||||
|
|
||||||
|
(** Provide a fresh identifier for a temporary big map (negative index). *)
|
||||||
|
val fresh_temporary_big_map: context -> context * Z.t
|
||||||
|
|
||||||
|
(** Reset the temporary big_map identifier generator to [-1]. *)
|
||||||
|
val reset_temporary_big_map: context -> context
|
||||||
|
|
||||||
|
(** Iterate over all created temporary big maps since the last {!reset_temporary_big_map}. *)
|
||||||
|
val temporary_big_maps: context -> ('a -> Z.t -> 'a Lwt.t) -> 'a -> 'a Lwt.t
|
||||||
|
@ -72,7 +72,7 @@ let () =
|
|||||||
|
|
||||||
let of_int32 l =
|
let of_int32 l =
|
||||||
try Ok (of_int32_exn l)
|
try Ok (of_int32_exn l)
|
||||||
with _ -> Error [Unexpected_level l]
|
with _ -> error (Unexpected_level l)
|
||||||
|
|
||||||
module Index = struct
|
module Index = struct
|
||||||
type t = raw_level
|
type t = raw_level
|
||||||
|
@ -157,21 +157,41 @@ let unparse_stack ctxt (stack, stack_ty) =
|
|||||||
return ((data, annot) :: rest) in
|
return ((data, annot) :: rest) in
|
||||||
unparse_stack (stack, stack_ty)
|
unparse_stack (stack, stack_ty)
|
||||||
|
|
||||||
module Interp_costs = Michelson_v1_gas.Cost_of
|
module Interp_costs = Michelson_v1_gas.Cost_of.Interpreter
|
||||||
|
|
||||||
let rec interp
|
let rec interp_stack_prefix_preserving_operation : type fbef bef faft aft result .
|
||||||
: type p r.
|
(fbef stack -> (faft stack * result) tzresult Lwt.t)
|
||||||
(?log: execution_trace ref ->
|
-> (fbef, faft, bef, aft) stack_prefix_preservation_witness
|
||||||
context ->
|
-> bef stack
|
||||||
source: Contract.t -> payer:Contract.t -> self: Contract.t -> Tez.t ->
|
-> (aft stack * result) tzresult Lwt.t =
|
||||||
(p, r) lambda -> p ->
|
fun f n stk ->
|
||||||
(r * context) tzresult Lwt.t)
|
match n,stk with
|
||||||
= fun ?log ctxt ~source ~payer ~self amount (Lam (code, _)) arg ->
|
| Prefix (Prefix (Prefix (Prefix (Prefix (Prefix (Prefix (Prefix (Prefix (Prefix (Prefix (Prefix (Prefix (Prefix (Prefix (Prefix n))))))))))))))),
|
||||||
let rec step
|
Item (v0, Item (v1, Item (v2, Item (v3, Item (v4, Item (v5, Item (v6, Item (v7, Item (v8, Item (v9, Item (va, Item (vb, Item (vc, Item (vd, Item (ve, Item (vf, rest)))))))))))))))) ->
|
||||||
|
interp_stack_prefix_preserving_operation f n rest >>=? fun (rest', result) ->
|
||||||
|
return (Item (v0, Item (v1, Item (v2, Item (v3, Item (v4, Item (v5, Item (v6, Item (v7, Item (v8, Item (v9, Item (va, Item (vb, Item (vc, Item (vd, Item (ve, Item (vf, rest')))))))))))))))), result)
|
||||||
|
| Prefix (Prefix (Prefix (Prefix n))),
|
||||||
|
Item (v0, Item (v1, Item (v2, Item (v3, rest)))) ->
|
||||||
|
interp_stack_prefix_preserving_operation f n rest >>=? fun (rest', result) ->
|
||||||
|
return (Item (v0, Item (v1, Item (v2, Item (v3, rest')))), result)
|
||||||
|
| Prefix n, Item (v, rest) ->
|
||||||
|
interp_stack_prefix_preserving_operation f n rest >>=? fun (rest', result) ->
|
||||||
|
return (Item (v, rest'), result)
|
||||||
|
| Rest, v -> f v
|
||||||
|
|
||||||
|
type step_constants =
|
||||||
|
{ source : Contract.t ;
|
||||||
|
payer : Contract.t ;
|
||||||
|
self : Contract.t ;
|
||||||
|
amount : Tez.t ;
|
||||||
|
chain_id : Chain_id.t }
|
||||||
|
|
||||||
|
let rec step
|
||||||
: type b a.
|
: type b a.
|
||||||
context -> (b, a) descr -> b stack ->
|
(?log: execution_trace ref ->
|
||||||
(a stack * context) tzresult Lwt.t =
|
context -> step_constants -> (b, a) descr -> b stack ->
|
||||||
fun ctxt ({ instr ; loc ; _ } as descr) stack ->
|
(a stack * context) tzresult Lwt.t) =
|
||||||
|
fun ?log ctxt step_constants ({ instr ; loc ; _ } as descr) stack ->
|
||||||
Lwt.return (Gas.consume ctxt Interp_costs.cycle) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt Interp_costs.cycle) >>=? fun ctxt ->
|
||||||
let logged_return : type a b.
|
let logged_return : type a b.
|
||||||
(b, a) descr ->
|
(b, a) descr ->
|
||||||
@ -217,17 +237,6 @@ let rec interp
|
|||||||
fun descr (op, arg) cost_func rest ctxt ->
|
fun descr (op, arg) cost_func rest ctxt ->
|
||||||
Lwt.return (Gas.consume ctxt (cost_func arg)) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt (cost_func arg)) >>=? fun ctxt ->
|
||||||
logged_return descr (Item (op arg, rest), ctxt) in
|
logged_return descr (Item (op arg, rest), ctxt) in
|
||||||
let consume_gaz_comparison :
|
|
||||||
type t rest.
|
|
||||||
(t * (t * rest), Script_int.z Script_int.num * rest) descr ->
|
|
||||||
(t -> t -> int) ->
|
|
||||||
(t -> t -> Gas.cost) ->
|
|
||||||
t -> t ->
|
|
||||||
rest stack ->
|
|
||||||
((Script_int.z Script_int.num * rest) stack * context) tzresult Lwt.t =
|
|
||||||
fun descr op cost x1 x2 rest ->
|
|
||||||
Lwt.return (Gas.consume ctxt (cost x1 x2)) >>=? fun ctxt ->
|
|
||||||
logged_return descr (Item (Script_int.of_int @@ op x1 x2, rest), ctxt) in
|
|
||||||
let logged_return :
|
let logged_return :
|
||||||
a stack * context ->
|
a stack * context ->
|
||||||
(a stack * context) tzresult Lwt.t =
|
(a stack * context) tzresult Lwt.t =
|
||||||
@ -255,14 +264,22 @@ let rec interp
|
|||||||
logged_return (Item (None, rest), ctxt)
|
logged_return (Item (None, rest), ctxt)
|
||||||
| If_none (bt, _), Item (None, rest) ->
|
| If_none (bt, _), Item (None, rest) ->
|
||||||
Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt ->
|
||||||
step ctxt bt rest
|
step ?log ctxt step_constants bt rest
|
||||||
| If_none (_, bf), Item (Some v, rest) ->
|
| If_none (_, bf), Item (Some v, rest) ->
|
||||||
Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt ->
|
||||||
step ctxt bf (Item (v, rest))
|
step ?log ctxt step_constants bf (Item (v, rest))
|
||||||
(* pairs *)
|
(* pairs *)
|
||||||
| Cons_pair, Item (a, Item (b, rest)) ->
|
| Cons_pair, Item (a, Item (b, rest)) ->
|
||||||
Lwt.return (Gas.consume ctxt Interp_costs.pair) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt Interp_costs.pair) >>=? fun ctxt ->
|
||||||
logged_return (Item ((a, b), rest), ctxt)
|
logged_return (Item ((a, b), rest), ctxt)
|
||||||
|
(* Peephole optimization for UNPAIR *)
|
||||||
|
| Seq ({instr=Dup;_},
|
||||||
|
{instr=Seq ({instr=Car;_},
|
||||||
|
{instr=Seq ({instr=Dip {instr=Cdr}},
|
||||||
|
{instr=Nop;_});_});_}),
|
||||||
|
Item ((a, b), rest) ->
|
||||||
|
Lwt.return (Gas.consume ctxt Interp_costs.pair_access) >>=? fun ctxt ->
|
||||||
|
logged_return (Item (a, Item (b, rest)), ctxt)
|
||||||
| Car, Item ((a, _), rest) ->
|
| Car, Item ((a, _), rest) ->
|
||||||
Lwt.return (Gas.consume ctxt Interp_costs.pair_access) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt Interp_costs.pair_access) >>=? fun ctxt ->
|
||||||
logged_return (Item (a, rest), ctxt)
|
logged_return (Item (a, rest), ctxt)
|
||||||
@ -278,10 +295,10 @@ let rec interp
|
|||||||
logged_return (Item (R v, rest), ctxt)
|
logged_return (Item (R v, rest), ctxt)
|
||||||
| If_left (bt, _), Item (L v, rest) ->
|
| If_left (bt, _), Item (L v, rest) ->
|
||||||
Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt ->
|
||||||
step ctxt bt (Item (v, rest))
|
step ?log ctxt step_constants bt (Item (v, rest))
|
||||||
| If_left (_, bf), Item (R v, rest) ->
|
| If_left (_, bf), Item (R v, rest) ->
|
||||||
Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt ->
|
||||||
step ctxt bf (Item (v, rest))
|
step ?log ctxt step_constants bf (Item (v, rest))
|
||||||
(* lists *)
|
(* lists *)
|
||||||
| Cons_list, Item (hd, Item (tl, rest)) ->
|
| Cons_list, Item (hd, Item (tl, rest)) ->
|
||||||
Lwt.return (Gas.consume ctxt Interp_costs.cons) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt Interp_costs.cons) >>=? fun ctxt ->
|
||||||
@ -291,17 +308,17 @@ let rec interp
|
|||||||
logged_return (Item ([], rest), ctxt)
|
logged_return (Item ([], rest), ctxt)
|
||||||
| If_cons (_, bf), Item ([], rest) ->
|
| If_cons (_, bf), Item ([], rest) ->
|
||||||
Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt ->
|
||||||
step ctxt bf rest
|
step ?log ctxt step_constants bf rest
|
||||||
| If_cons (bt, _), Item (hd :: tl, rest) ->
|
| If_cons (bt, _), Item (hd :: tl, rest) ->
|
||||||
Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt ->
|
||||||
step ctxt bt (Item (hd, Item (tl, rest)))
|
step ?log ctxt step_constants bt (Item (hd, Item (tl, rest)))
|
||||||
| List_map body, Item (l, rest) ->
|
| List_map body, Item (l, rest) ->
|
||||||
let rec loop rest ctxt l acc =
|
let rec loop rest ctxt l acc =
|
||||||
Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt Interp_costs.loop_map) >>=? fun ctxt ->
|
||||||
match l with
|
match l with
|
||||||
| [] -> return (Item (List.rev acc, rest), ctxt)
|
| [] -> return (Item (List.rev acc, rest), ctxt)
|
||||||
| hd :: tl ->
|
| hd :: tl ->
|
||||||
step ctxt body (Item (hd, rest))
|
step ?log ctxt step_constants body (Item (hd, rest))
|
||||||
>>=? fun (Item (hd, rest), ctxt) ->
|
>>=? fun (Item (hd, rest), ctxt) ->
|
||||||
loop rest ctxt tl (hd :: acc)
|
loop rest ctxt tl (hd :: acc)
|
||||||
in loop rest ctxt l [] >>=? fun (res, ctxt) ->
|
in loop rest ctxt l [] >>=? fun (res, ctxt) ->
|
||||||
@ -311,17 +328,17 @@ let rec interp
|
|||||||
(List.fold_left
|
(List.fold_left
|
||||||
(fun acc _ ->
|
(fun acc _ ->
|
||||||
acc >>? fun (size, ctxt) ->
|
acc >>? fun (size, ctxt) ->
|
||||||
Gas.consume ctxt Interp_costs.list_size >>? fun ctxt ->
|
Gas.consume ctxt Interp_costs.loop_size >>? fun ctxt ->
|
||||||
ok (size + 1 (* FIXME: overflow *), ctxt))
|
ok (size + 1 (* FIXME: overflow *), ctxt))
|
||||||
(ok (0, ctxt)) list) >>=? fun (len, ctxt) ->
|
(ok (0, ctxt)) list) >>=? fun (len, ctxt) ->
|
||||||
logged_return (Item (Script_int.(abs (of_int len)), rest), ctxt)
|
logged_return (Item (Script_int.(abs (of_int len)), rest), ctxt)
|
||||||
| List_iter body, Item (l, init) ->
|
| List_iter body, Item (l, init) ->
|
||||||
let rec loop ctxt l stack =
|
let rec loop ctxt l stack =
|
||||||
Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt Interp_costs.loop_iter) >>=? fun ctxt ->
|
||||||
match l with
|
match l with
|
||||||
| [] -> return (stack, ctxt)
|
| [] -> return (stack, ctxt)
|
||||||
| hd :: tl ->
|
| hd :: tl ->
|
||||||
step ctxt body (Item (hd, stack))
|
step ?log ctxt step_constants body (Item (hd, stack))
|
||||||
>>=? fun (stack, ctxt) ->
|
>>=? fun (stack, ctxt) ->
|
||||||
loop ctxt tl stack
|
loop ctxt tl stack
|
||||||
in loop ctxt l init >>=? fun (res, ctxt) ->
|
in loop ctxt l init >>=? fun (res, ctxt) ->
|
||||||
@ -334,11 +351,11 @@ let rec interp
|
|||||||
Lwt.return (Gas.consume ctxt (Interp_costs.set_to_list set)) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt (Interp_costs.set_to_list set)) >>=? fun ctxt ->
|
||||||
let l = List.rev (set_fold (fun e acc -> e :: acc) set []) in
|
let l = List.rev (set_fold (fun e acc -> e :: acc) set []) in
|
||||||
let rec loop ctxt l stack =
|
let rec loop ctxt l stack =
|
||||||
Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt Interp_costs.loop_iter) >>=? fun ctxt ->
|
||||||
match l with
|
match l with
|
||||||
| [] -> return (stack, ctxt)
|
| [] -> return (stack, ctxt)
|
||||||
| hd :: tl ->
|
| hd :: tl ->
|
||||||
step ctxt body (Item (hd, stack))
|
step ?log ctxt step_constants body (Item (hd, stack))
|
||||||
>>=? fun (stack, ctxt) ->
|
>>=? fun (stack, ctxt) ->
|
||||||
loop ctxt tl stack
|
loop ctxt tl stack
|
||||||
in loop ctxt l init >>=? fun (res, ctxt) ->
|
in loop ctxt l init >>=? fun (res, ctxt) ->
|
||||||
@ -357,11 +374,11 @@ let rec interp
|
|||||||
Lwt.return (Gas.consume ctxt (Interp_costs.map_to_list map)) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt (Interp_costs.map_to_list map)) >>=? fun ctxt ->
|
||||||
let l = List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in
|
let l = List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in
|
||||||
let rec loop rest ctxt l acc =
|
let rec loop rest ctxt l acc =
|
||||||
Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt Interp_costs.loop_map) >>=? fun ctxt ->
|
||||||
match l with
|
match l with
|
||||||
| [] -> return (acc, ctxt)
|
| [] -> return (acc, ctxt)
|
||||||
| (k, _) as hd :: tl ->
|
| (k, _) as hd :: tl ->
|
||||||
step ctxt body (Item (hd, rest))
|
step ?log ctxt step_constants body (Item (hd, rest))
|
||||||
>>=? fun (Item (hd, rest), ctxt) ->
|
>>=? fun (Item (hd, rest), ctxt) ->
|
||||||
loop rest ctxt tl (map_update k (Some hd) acc)
|
loop rest ctxt tl (map_update k (Some hd) acc)
|
||||||
in loop rest ctxt l (empty_map (map_key_ty map)) >>=? fun (res, ctxt) ->
|
in loop rest ctxt l (empty_map (map_key_ty map)) >>=? fun (res, ctxt) ->
|
||||||
@ -370,11 +387,11 @@ let rec interp
|
|||||||
Lwt.return (Gas.consume ctxt (Interp_costs.map_to_list map)) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt (Interp_costs.map_to_list map)) >>=? fun ctxt ->
|
||||||
let l = List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in
|
let l = List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in
|
||||||
let rec loop ctxt l stack =
|
let rec loop ctxt l stack =
|
||||||
Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt Interp_costs.loop_iter) >>=? fun ctxt ->
|
||||||
match l with
|
match l with
|
||||||
| [] -> return (stack, ctxt)
|
| [] -> return (stack, ctxt)
|
||||||
| hd :: tl ->
|
| hd :: tl ->
|
||||||
step ctxt body (Item (hd, stack))
|
step ?log ctxt step_constants body (Item (hd, stack))
|
||||||
>>=? fun (stack, ctxt) ->
|
>>=? fun (stack, ctxt) ->
|
||||||
loop ctxt tl stack
|
loop ctxt tl stack
|
||||||
in loop ctxt l init >>=? fun (res, ctxt) ->
|
in loop ctxt l init >>=? fun (res, ctxt) ->
|
||||||
@ -388,18 +405,21 @@ let rec interp
|
|||||||
| Map_size, Item (map, rest) ->
|
| Map_size, Item (map, rest) ->
|
||||||
consume_gas_unop descr (map_size, map) (fun _ -> Interp_costs.map_size) rest ctxt
|
consume_gas_unop descr (map_size, map) (fun _ -> Interp_costs.map_size) rest ctxt
|
||||||
(* Big map operations *)
|
(* Big map operations *)
|
||||||
|
| Empty_big_map (tk, tv), rest ->
|
||||||
|
Lwt.return (Gas.consume ctxt Interp_costs.empty_map) >>=? fun ctxt ->
|
||||||
|
logged_return (Item (Script_ir_translator.empty_big_map tk tv, rest), ctxt)
|
||||||
| Big_map_mem, Item (key, Item (map, rest)) ->
|
| Big_map_mem, Item (key, Item (map, rest)) ->
|
||||||
Lwt.return (Gas.consume ctxt (Interp_costs.big_map_mem key map)) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt (Interp_costs.map_mem key map.diff)) >>=? fun ctxt ->
|
||||||
Script_ir_translator.big_map_mem ctxt self key map >>=? fun (res, ctxt) ->
|
Script_ir_translator.big_map_mem ctxt key map >>=? fun (res, ctxt) ->
|
||||||
logged_return (Item (res, rest), ctxt)
|
logged_return (Item (res, rest), ctxt)
|
||||||
| Big_map_get, Item (key, Item (map, rest)) ->
|
| Big_map_get, Item (key, Item (map, rest)) ->
|
||||||
Lwt.return (Gas.consume ctxt (Interp_costs.big_map_get key map)) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt (Interp_costs.map_get key map.diff)) >>=? fun ctxt ->
|
||||||
Script_ir_translator.big_map_get ctxt self key map >>=? fun (res, ctxt) ->
|
Script_ir_translator.big_map_get ctxt key map >>=? fun (res, ctxt) ->
|
||||||
logged_return (Item (res, rest), ctxt)
|
logged_return (Item (res, rest), ctxt)
|
||||||
| Big_map_update, Item (key, Item (maybe_value, Item (map, rest))) ->
|
| Big_map_update, Item (key, Item (maybe_value, Item (map, rest))) ->
|
||||||
consume_gas_terop descr
|
consume_gas_terop descr
|
||||||
(Script_ir_translator.big_map_update, key, maybe_value, map)
|
(Script_ir_translator.big_map_update, key, maybe_value, map)
|
||||||
Interp_costs.big_map_update rest
|
(fun k v m -> Interp_costs.map_update k (Some v) m.diff) rest
|
||||||
(* timestamp operations *)
|
(* timestamp operations *)
|
||||||
| Add_seconds_to_timestamp, Item (n, Item (t, rest)) ->
|
| Add_seconds_to_timestamp, Item (n, Item (t, rest)) ->
|
||||||
consume_gas_binop descr
|
consume_gas_binop descr
|
||||||
@ -603,35 +623,77 @@ let rec interp
|
|||||||
consume_gas_unop descr (Script_int.lognot, x) Interp_costs.lognot rest ctxt
|
consume_gas_unop descr (Script_int.lognot, x) Interp_costs.lognot rest ctxt
|
||||||
(* control *)
|
(* control *)
|
||||||
| Seq (hd, tl), stack ->
|
| Seq (hd, tl), stack ->
|
||||||
step ctxt hd stack >>=? fun (trans, ctxt) ->
|
step ?log ctxt step_constants hd stack >>=? fun (trans, ctxt) ->
|
||||||
step ctxt tl trans
|
step ?log ctxt step_constants tl trans
|
||||||
| If (bt, _), Item (true, rest) ->
|
| If (bt, _), Item (true, rest) ->
|
||||||
Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt ->
|
||||||
step ctxt bt rest
|
step ?log ctxt step_constants bt rest
|
||||||
| If (_, bf), Item (false, rest) ->
|
| If (_, bf), Item (false, rest) ->
|
||||||
Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt ->
|
||||||
step ctxt bf rest
|
step ?log ctxt step_constants bf rest
|
||||||
| Loop body, Item (true, rest) ->
|
| Loop body, Item (true, rest) ->
|
||||||
Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt ->
|
||||||
step ctxt body rest >>=? fun (trans, ctxt) ->
|
step ?log ctxt step_constants body rest >>=? fun (trans, ctxt) ->
|
||||||
step ctxt descr trans
|
step ?log ctxt step_constants descr trans
|
||||||
| Loop _, Item (false, rest) ->
|
| Loop _, Item (false, rest) ->
|
||||||
logged_return (rest, ctxt)
|
logged_return (rest, ctxt)
|
||||||
| Loop_left body, Item (L v, rest) ->
|
| Loop_left body, Item (L v, rest) ->
|
||||||
Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt ->
|
||||||
step ctxt body (Item (v, rest)) >>=? fun (trans, ctxt) ->
|
step ?log ctxt step_constants body (Item (v, rest)) >>=? fun (trans, ctxt) ->
|
||||||
step ctxt descr trans
|
step ?log ctxt step_constants descr trans
|
||||||
| Loop_left _, Item (R v, rest) ->
|
| Loop_left _, Item (R v, rest) ->
|
||||||
Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt ->
|
||||||
logged_return (Item (v, rest), ctxt)
|
logged_return (Item (v, rest), ctxt)
|
||||||
| Dip b, Item (ign, rest) ->
|
| Dip b, Item (ign, rest) ->
|
||||||
Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt ->
|
||||||
step ctxt b rest >>=? fun (res, ctxt) ->
|
step ?log ctxt step_constants b rest >>=? fun (res, ctxt) ->
|
||||||
logged_return (Item (ign, res), ctxt)
|
logged_return (Item (ign, res), ctxt)
|
||||||
| Exec, Item (arg, Item (lam, rest)) ->
|
| Exec, Item (arg, Item (lam, rest)) ->
|
||||||
Lwt.return (Gas.consume ctxt Interp_costs.exec) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt Interp_costs.exec) >>=? fun ctxt ->
|
||||||
interp ?log ctxt ~source ~payer ~self amount lam arg >>=? fun (res, ctxt) ->
|
interp ?log ctxt step_constants lam arg >>=? fun (res, ctxt) ->
|
||||||
logged_return (Item (res, rest), ctxt)
|
logged_return (Item (res, rest), ctxt)
|
||||||
|
| Apply capture_ty, Item (capture, Item (lam, rest)) -> (
|
||||||
|
Lwt.return (Gas.consume ctxt Interp_costs.apply) >>=? fun ctxt ->
|
||||||
|
let (Lam (descr, expr)) = lam in
|
||||||
|
let (Item_t (full_arg_ty , _ , _)) = descr.bef in
|
||||||
|
unparse_data ctxt Optimized capture_ty capture >>=? fun (const_expr, ctxt) ->
|
||||||
|
unparse_ty ctxt capture_ty >>=? fun (ty_expr, ctxt) ->
|
||||||
|
match full_arg_ty with
|
||||||
|
| Pair_t ((capture_ty, _, _), (arg_ty, _, _), _, _) -> (
|
||||||
|
let arg_stack_ty = Item_t (arg_ty, Empty_t, None) in
|
||||||
|
let const_descr = ({
|
||||||
|
loc = descr.loc ;
|
||||||
|
bef = arg_stack_ty ;
|
||||||
|
aft = Item_t (capture_ty, arg_stack_ty, None) ;
|
||||||
|
instr = Const capture ;
|
||||||
|
} : (_, _) descr) in
|
||||||
|
let pair_descr = ({
|
||||||
|
loc = descr.loc ;
|
||||||
|
bef = Item_t (capture_ty, arg_stack_ty, None) ;
|
||||||
|
aft = Item_t (full_arg_ty, Empty_t, None) ;
|
||||||
|
instr = Cons_pair ;
|
||||||
|
} : (_, _) descr) in
|
||||||
|
let seq_descr = ({
|
||||||
|
loc = descr.loc ;
|
||||||
|
bef = arg_stack_ty ;
|
||||||
|
aft = Item_t (full_arg_ty, Empty_t, None) ;
|
||||||
|
instr = Seq (const_descr, pair_descr) ;
|
||||||
|
} : (_, _) descr) in
|
||||||
|
let full_descr = ({
|
||||||
|
loc = descr.loc ;
|
||||||
|
bef = arg_stack_ty ;
|
||||||
|
aft = descr.aft ;
|
||||||
|
instr = Seq (seq_descr, descr) ;
|
||||||
|
} : (_, _) descr) in
|
||||||
|
let full_expr = Micheline.Seq (0, [
|
||||||
|
Prim (0, I_PUSH, [ ty_expr ; const_expr ], []) ;
|
||||||
|
Prim (0, I_PAIR, [], []) ;
|
||||||
|
expr ]) in
|
||||||
|
let lam' = Lam (full_descr, full_expr) in
|
||||||
|
logged_return (Item (lam', rest), ctxt)
|
||||||
|
)
|
||||||
|
| _ -> assert false
|
||||||
|
)
|
||||||
| Lambda lam, rest ->
|
| Lambda lam, rest ->
|
||||||
Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt ->
|
||||||
logged_return (Item (lam, rest), ctxt)
|
logged_return (Item (lam, rest), ctxt)
|
||||||
@ -643,25 +705,9 @@ let rec interp
|
|||||||
| Nop, stack ->
|
| Nop, stack ->
|
||||||
logged_return (stack, ctxt)
|
logged_return (stack, ctxt)
|
||||||
(* comparison *)
|
(* comparison *)
|
||||||
| Compare (Bool_key _), Item (a, Item (b, rest)) ->
|
| Compare ty, Item (a, Item (b, rest)) ->
|
||||||
consume_gaz_comparison descr Compare.Bool.compare Interp_costs.compare_bool a b rest
|
Lwt.return (Gas.consume ctxt (Interp_costs.compare ty a b)) >>=? fun ctxt ->
|
||||||
| Compare (String_key _), Item (a, Item (b, rest)) ->
|
logged_return (Item (Script_int.of_int @@ Script_ir_translator.compare_comparable ty a b, rest), ctxt)
|
||||||
consume_gaz_comparison descr Compare.String.compare Interp_costs.compare_string a b rest
|
|
||||||
| Compare (Bytes_key _), Item (a, Item (b, rest)) ->
|
|
||||||
consume_gaz_comparison descr MBytes.compare Interp_costs.compare_bytes a b rest
|
|
||||||
| Compare (Mutez_key _), Item (a, Item (b, rest)) ->
|
|
||||||
consume_gaz_comparison descr Tez.compare Interp_costs.compare_tez a b rest
|
|
||||||
| Compare (Int_key _), Item (a, Item (b, rest)) ->
|
|
||||||
consume_gaz_comparison descr Script_int.compare Interp_costs.compare_int a b rest
|
|
||||||
| Compare (Nat_key _), Item (a, Item (b, rest)) ->
|
|
||||||
consume_gaz_comparison descr Script_int.compare Interp_costs.compare_nat a b rest
|
|
||||||
| Compare (Key_hash_key _), Item (a, Item (b, rest)) ->
|
|
||||||
consume_gaz_comparison descr Signature.Public_key_hash.compare
|
|
||||||
Interp_costs.compare_key_hash a b rest
|
|
||||||
| Compare (Timestamp_key _), Item (a, Item (b, rest)) ->
|
|
||||||
consume_gaz_comparison descr Script_timestamp.compare Interp_costs.compare_timestamp a b rest
|
|
||||||
| Compare (Address_key _), Item (a, Item (b, rest)) ->
|
|
||||||
consume_gaz_comparison descr Contract.compare Interp_costs.compare_address a b rest
|
|
||||||
(* comparators *)
|
(* comparators *)
|
||||||
| Eq, Item (cmpres, rest) ->
|
| Eq, Item (cmpres, rest) ->
|
||||||
let cmpres = Script_int.compare cmpres Script_int.zero in
|
let cmpres = Script_int.compare cmpres Script_int.zero in
|
||||||
@ -708,7 +754,7 @@ let rec interp
|
|||||||
logged_return (Item (None, rest), ctxt)
|
logged_return (Item (None, rest), ctxt)
|
||||||
| Some expr ->
|
| Some expr ->
|
||||||
Lwt.return (Gas.consume ctxt (Script.deserialized_cost expr)) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt (Script.deserialized_cost expr)) >>=? fun ctxt ->
|
||||||
parse_data ctxt t (Micheline.root expr) >>= function
|
parse_data ctxt ~legacy:false t (Micheline.root expr) >>= function
|
||||||
| Ok (value, ctxt) ->
|
| Ok (value, ctxt) ->
|
||||||
logged_return (Item (Some value, rest), ctxt)
|
logged_return (Item (Some value, rest), ctxt)
|
||||||
| Error _ignored ->
|
| Error _ignored ->
|
||||||
@ -717,39 +763,57 @@ let rec interp
|
|||||||
else
|
else
|
||||||
logged_return (Item (None, rest), ctxt)
|
logged_return (Item (None, rest), ctxt)
|
||||||
(* protocol *)
|
(* protocol *)
|
||||||
| Address, Item ((_, contract), rest) ->
|
| Address, Item ((_, address), rest) ->
|
||||||
Lwt.return (Gas.consume ctxt Interp_costs.address) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt Interp_costs.address) >>=? fun ctxt ->
|
||||||
logged_return (Item (contract, rest), ctxt)
|
logged_return (Item (address, rest), ctxt)
|
||||||
| Contract t, Item (contract, rest) ->
|
| Contract (t, entrypoint), Item (contract, rest) ->
|
||||||
Lwt.return (Gas.consume ctxt Interp_costs.contract) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt Interp_costs.contract) >>=? fun ctxt ->
|
||||||
Script_ir_translator.parse_contract_for_script ctxt loc t contract >>=? fun (ctxt, maybe_contract) ->
|
begin match contract, entrypoint with
|
||||||
|
| (contract, "default"), entrypoint | (contract, entrypoint), "default" ->
|
||||||
|
Script_ir_translator.parse_contract_for_script
|
||||||
|
~legacy:false ctxt loc t contract ~entrypoint >>=? fun (ctxt, maybe_contract) ->
|
||||||
logged_return (Item (maybe_contract, rest), ctxt)
|
logged_return (Item (maybe_contract, rest), ctxt)
|
||||||
|
| _ -> logged_return (Item (None, rest), ctxt)
|
||||||
|
end
|
||||||
| Transfer_tokens,
|
| Transfer_tokens,
|
||||||
Item (p, Item (amount, Item ((tp, destination), rest))) ->
|
Item (p, Item (amount, Item ((tp, (destination, entrypoint)), rest))) ->
|
||||||
Lwt.return (Gas.consume ctxt Interp_costs.transfer) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt Interp_costs.transfer) >>=? fun ctxt ->
|
||||||
|
collect_big_maps ctxt tp p >>=? fun (to_duplicate, ctxt) ->
|
||||||
|
let to_update = no_big_map_id in
|
||||||
|
extract_big_map_diff ctxt Optimized tp p
|
||||||
|
~to_duplicate ~to_update ~temporary:true >>=? fun (p, big_map_diff, ctxt) ->
|
||||||
unparse_data ctxt Optimized tp p >>=? fun (p, ctxt) ->
|
unparse_data ctxt Optimized tp p >>=? fun (p, ctxt) ->
|
||||||
let operation =
|
let operation =
|
||||||
Transaction
|
Transaction
|
||||||
{ amount ; destination ;
|
{ amount ; destination ; entrypoint ;
|
||||||
parameters = Some (Script.lazy_expr (Micheline.strip_locations p)) } in
|
parameters = Script.lazy_expr (Micheline.strip_locations p) } in
|
||||||
Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) ->
|
Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) ->
|
||||||
logged_return (Item (Internal_operation { source = self ; operation ; nonce }, rest), ctxt)
|
logged_return (Item ((Internal_operation { source = step_constants.self ; operation ; nonce }, big_map_diff), rest), ctxt)
|
||||||
| Create_account,
|
| Create_account,
|
||||||
Item (manager, Item (delegate, Item (delegatable, Item (credit, rest)))) ->
|
Item (manager, Item (delegate, Item (_delegatable, Item (credit, rest)))) ->
|
||||||
Lwt.return (Gas.consume ctxt Interp_costs.create_account) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt Interp_costs.create_account) >>=? fun ctxt ->
|
||||||
Contract.fresh_contract_from_current_nonce ctxt >>=? fun (ctxt, contract) ->
|
Contract.fresh_contract_from_current_nonce ctxt >>=? fun (ctxt, contract) ->
|
||||||
|
(* store in optimized binary representation - as unparsed with [Optimized]. *)
|
||||||
|
let manager_bytes =
|
||||||
|
Data_encoding.Binary.to_bytes_exn Signature.Public_key_hash.encoding manager in
|
||||||
|
let storage =
|
||||||
|
Script_repr.lazy_expr @@ Micheline.strip_locations @@
|
||||||
|
Micheline.Bytes (0, manager_bytes) in
|
||||||
|
let script =
|
||||||
|
{ code = Legacy_support.manager_script_code ;
|
||||||
|
storage ;
|
||||||
|
} in
|
||||||
let operation =
|
let operation =
|
||||||
Origination
|
Origination
|
||||||
{ credit ; manager ; delegate ; preorigination = Some contract ;
|
{ credit ; delegate ; preorigination = Some contract ; script } in
|
||||||
delegatable ; script = None ; spendable = true } in
|
|
||||||
Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) ->
|
Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) ->
|
||||||
logged_return (Item (Internal_operation { source = self ; operation ; nonce },
|
logged_return (Item ((Internal_operation { source = step_constants.self ; operation ; nonce }, None),
|
||||||
Item (contract, rest)), ctxt)
|
Item ((contract, "default"), rest)), ctxt)
|
||||||
| Implicit_account, Item (key, rest) ->
|
| Implicit_account, Item (key, rest) ->
|
||||||
Lwt.return (Gas.consume ctxt Interp_costs.implicit_account) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt Interp_costs.implicit_account) >>=? fun ctxt ->
|
||||||
let contract = Contract.implicit_contract key in
|
let contract = Contract.implicit_contract key in
|
||||||
logged_return (Item ((Unit_t None, contract), rest), ctxt)
|
logged_return (Item ((Unit_t None, (contract, "default")), rest), ctxt)
|
||||||
| Create_contract (storage_type, param_type, Lam (_, code)),
|
| Create_contract (storage_type, param_type, Lam (_, code), root_name),
|
||||||
Item (manager, Item
|
Item (manager, Item
|
||||||
(delegate, Item
|
(delegate, Item
|
||||||
(spendable, Item
|
(spendable, Item
|
||||||
@ -758,56 +822,104 @@ let rec interp
|
|||||||
(init, rest)))))) ->
|
(init, rest)))))) ->
|
||||||
Lwt.return (Gas.consume ctxt Interp_costs.create_contract) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt Interp_costs.create_contract) >>=? fun ctxt ->
|
||||||
unparse_ty ctxt param_type >>=? fun (unparsed_param_type, ctxt) ->
|
unparse_ty ctxt param_type >>=? fun (unparsed_param_type, ctxt) ->
|
||||||
|
let unparsed_param_type =
|
||||||
|
Script_ir_translator.add_field_annot (Option.map ~f:(fun n -> `Field_annot n) root_name) None unparsed_param_type in
|
||||||
|
unparse_ty ctxt storage_type >>=? fun (unparsed_storage_type, ctxt) ->
|
||||||
|
let code =
|
||||||
|
Script.lazy_expr @@
|
||||||
|
Micheline.strip_locations
|
||||||
|
(Seq (0, [ Prim (0, K_parameter, [ unparsed_param_type ], []) ;
|
||||||
|
Prim (0, K_storage, [ unparsed_storage_type ], []) ;
|
||||||
|
Prim (0, K_code, [ code ], []) ])) in
|
||||||
|
collect_big_maps ctxt storage_type init >>=? fun (to_duplicate, ctxt) ->
|
||||||
|
let to_update = no_big_map_id in
|
||||||
|
extract_big_map_diff ctxt Optimized storage_type init
|
||||||
|
~to_duplicate ~to_update ~temporary:true >>=? fun (init, big_map_diff, ctxt) ->
|
||||||
|
unparse_data ctxt Optimized storage_type init >>=? fun (storage, ctxt) ->
|
||||||
|
let storage = Script.lazy_expr @@ Micheline.strip_locations storage in
|
||||||
|
begin
|
||||||
|
if spendable then
|
||||||
|
Legacy_support.add_do ~manager_pkh:manager
|
||||||
|
~script_code:code ~script_storage:storage
|
||||||
|
else if delegatable then
|
||||||
|
Legacy_support.add_set_delegate ~manager_pkh:manager
|
||||||
|
~script_code:code ~script_storage:storage
|
||||||
|
else if Legacy_support.has_default_entrypoint code then
|
||||||
|
Legacy_support.add_root_entrypoint code >>=? fun code ->
|
||||||
|
return (code, storage)
|
||||||
|
else return (code, storage)
|
||||||
|
end >>=? fun (code, storage) ->
|
||||||
|
Contract.fresh_contract_from_current_nonce ctxt >>=? fun (ctxt, contract) ->
|
||||||
|
let operation =
|
||||||
|
Origination
|
||||||
|
{ credit ; delegate ; preorigination = Some contract ;
|
||||||
|
script = { code ; storage } } in
|
||||||
|
Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) ->
|
||||||
|
logged_return
|
||||||
|
(Item ((Internal_operation { source = step_constants.self ; operation ; nonce }, big_map_diff),
|
||||||
|
Item ((contract, "default"), rest)), ctxt)
|
||||||
|
| Create_contract_2 (storage_type, param_type, Lam (_, code), root_name),
|
||||||
|
(* Removed the instruction's arguments manager, spendable and delegatable *)
|
||||||
|
Item (delegate, Item
|
||||||
|
(credit, Item
|
||||||
|
(init, rest))) ->
|
||||||
|
Lwt.return (Gas.consume ctxt Interp_costs.create_contract) >>=? fun ctxt ->
|
||||||
|
unparse_ty ctxt param_type >>=? fun (unparsed_param_type, ctxt) ->
|
||||||
|
let unparsed_param_type =
|
||||||
|
Script_ir_translator.add_field_annot (Option.map ~f:(fun n -> `Field_annot n) root_name) None unparsed_param_type in
|
||||||
unparse_ty ctxt storage_type >>=? fun (unparsed_storage_type, ctxt) ->
|
unparse_ty ctxt storage_type >>=? fun (unparsed_storage_type, ctxt) ->
|
||||||
let code =
|
let code =
|
||||||
Micheline.strip_locations
|
Micheline.strip_locations
|
||||||
(Seq (0, [ Prim (0, K_parameter, [ unparsed_param_type ], []) ;
|
(Seq (0, [ Prim (0, K_parameter, [ unparsed_param_type ], []) ;
|
||||||
Prim (0, K_storage, [ unparsed_storage_type ], []) ;
|
Prim (0, K_storage, [ unparsed_storage_type ], []) ;
|
||||||
Prim (0, K_code, [ Micheline.root code ], []) ])) in
|
Prim (0, K_code, [ code ], []) ])) in
|
||||||
|
collect_big_maps ctxt storage_type init >>=? fun (to_duplicate, ctxt) ->
|
||||||
|
let to_update = no_big_map_id in
|
||||||
|
extract_big_map_diff ctxt Optimized storage_type init
|
||||||
|
~to_duplicate ~to_update ~temporary:true >>=? fun (init, big_map_diff, ctxt) ->
|
||||||
unparse_data ctxt Optimized storage_type init >>=? fun (storage, ctxt) ->
|
unparse_data ctxt Optimized storage_type init >>=? fun (storage, ctxt) ->
|
||||||
let storage = Micheline.strip_locations storage in
|
let storage = Micheline.strip_locations storage in
|
||||||
Contract.fresh_contract_from_current_nonce ctxt >>=? fun (ctxt, contract) ->
|
Contract.fresh_contract_from_current_nonce ctxt >>=? fun (ctxt, contract) ->
|
||||||
let operation =
|
let operation =
|
||||||
Origination
|
Origination
|
||||||
{ credit ; manager ; delegate ; preorigination = Some contract ;
|
{ credit ; delegate ; preorigination = Some contract ;
|
||||||
delegatable ; spendable ;
|
script = { code = Script.lazy_expr code ;
|
||||||
script = Some { code = Script.lazy_expr code ;
|
|
||||||
storage = Script.lazy_expr storage } } in
|
storage = Script.lazy_expr storage } } in
|
||||||
Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) ->
|
Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) ->
|
||||||
logged_return
|
logged_return
|
||||||
(Item (Internal_operation { source = self ; operation ; nonce },
|
(Item ((Internal_operation { source = step_constants.self ; operation ; nonce }, big_map_diff),
|
||||||
Item (contract, rest)), ctxt)
|
Item ((contract, "default"), rest)), ctxt)
|
||||||
| Set_delegate,
|
| Set_delegate,
|
||||||
Item (delegate, rest) ->
|
Item (delegate, rest) ->
|
||||||
Lwt.return (Gas.consume ctxt Interp_costs.create_account) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt Interp_costs.create_account) >>=? fun ctxt ->
|
||||||
let operation = Delegation delegate in
|
let operation = Delegation delegate in
|
||||||
Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) ->
|
Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) ->
|
||||||
logged_return (Item (Internal_operation { source = self ; operation ; nonce }, rest), ctxt)
|
logged_return (Item ((Internal_operation { source = step_constants.self ; operation ; nonce }, None), rest), ctxt)
|
||||||
| Balance, rest ->
|
| Balance, rest ->
|
||||||
Lwt.return (Gas.consume ctxt Interp_costs.balance) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt Interp_costs.balance) >>=? fun ctxt ->
|
||||||
Contract.get_balance ctxt self >>=? fun balance ->
|
Contract.get_balance ctxt step_constants.self >>=? fun balance ->
|
||||||
logged_return (Item (balance, rest), ctxt)
|
logged_return (Item (balance, rest), ctxt)
|
||||||
| Now, rest ->
|
| Now, rest ->
|
||||||
Lwt.return (Gas.consume ctxt Interp_costs.now) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt Interp_costs.now) >>=? fun ctxt ->
|
||||||
let now = Script_timestamp.now ctxt in
|
let now = Script_timestamp.now ctxt in
|
||||||
logged_return (Item (now, rest), ctxt)
|
logged_return (Item (now, rest), ctxt)
|
||||||
| Check_signature, Item (key, Item (signature, Item (message, rest))) ->
|
| Check_signature, Item (key, Item (signature, Item (message, rest))) ->
|
||||||
Lwt.return (Gas.consume ctxt Interp_costs.check_signature) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt (Interp_costs.check_signature key message)) >>=? fun ctxt ->
|
||||||
let res = Signature.check key signature message in
|
let res = Signature.check key signature message in
|
||||||
logged_return (Item (res, rest), ctxt)
|
logged_return (Item (res, rest), ctxt)
|
||||||
| Hash_key, Item (key, rest) ->
|
| Hash_key, Item (key, rest) ->
|
||||||
Lwt.return (Gas.consume ctxt Interp_costs.hash_key) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt Interp_costs.hash_key) >>=? fun ctxt ->
|
||||||
logged_return (Item (Signature.Public_key.hash key, rest), ctxt)
|
logged_return (Item (Signature.Public_key.hash key, rest), ctxt)
|
||||||
| Blake2b, Item (bytes, rest) ->
|
| Blake2b, Item (bytes, rest) ->
|
||||||
Lwt.return (Gas.consume ctxt (Interp_costs.hash bytes 32)) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt (Interp_costs.hash_blake2b bytes)) >>=? fun ctxt ->
|
||||||
let hash = Raw_hashes.blake2b bytes in
|
let hash = Raw_hashes.blake2b bytes in
|
||||||
logged_return (Item (hash, rest), ctxt)
|
logged_return (Item (hash, rest), ctxt)
|
||||||
| Sha256, Item (bytes, rest) ->
|
| Sha256, Item (bytes, rest) ->
|
||||||
Lwt.return (Gas.consume ctxt (Interp_costs.hash bytes 32)) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt (Interp_costs.hash_sha256 bytes)) >>=? fun ctxt ->
|
||||||
let hash = Raw_hashes.sha256 bytes in
|
let hash = Raw_hashes.sha256 bytes in
|
||||||
logged_return (Item (hash, rest), ctxt)
|
logged_return (Item (hash, rest), ctxt)
|
||||||
| Sha512, Item (bytes, rest) ->
|
| Sha512, Item (bytes, rest) ->
|
||||||
Lwt.return (Gas.consume ctxt (Interp_costs.hash bytes 64)) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt (Interp_costs.hash_sha512 bytes)) >>=? fun ctxt ->
|
||||||
let hash = Raw_hashes.sha512 bytes in
|
let hash = Raw_hashes.sha512 bytes in
|
||||||
logged_return (Item (hash, rest), ctxt)
|
logged_return (Item (hash, rest), ctxt)
|
||||||
| Steps_to_quota, rest ->
|
| Steps_to_quota, rest ->
|
||||||
@ -818,16 +930,45 @@ let rec interp
|
|||||||
logged_return (Item (Script_int.(abs (of_zint steps)), rest), ctxt)
|
logged_return (Item (Script_int.(abs (of_zint steps)), rest), ctxt)
|
||||||
| Source, rest ->
|
| Source, rest ->
|
||||||
Lwt.return (Gas.consume ctxt Interp_costs.source) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt Interp_costs.source) >>=? fun ctxt ->
|
||||||
logged_return (Item (payer, rest), ctxt)
|
logged_return (Item ((step_constants.payer, "default"), rest), ctxt)
|
||||||
| Sender, rest ->
|
| Sender, rest ->
|
||||||
Lwt.return (Gas.consume ctxt Interp_costs.source) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt Interp_costs.source) >>=? fun ctxt ->
|
||||||
logged_return (Item (source, rest), ctxt)
|
logged_return (Item ((step_constants.source, "default"), rest), ctxt)
|
||||||
| Self t, rest ->
|
| Self (t, entrypoint), rest ->
|
||||||
Lwt.return (Gas.consume ctxt Interp_costs.self) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt Interp_costs.self) >>=? fun ctxt ->
|
||||||
logged_return (Item ((t,self), rest), ctxt)
|
logged_return (Item ((t, (step_constants.self, entrypoint)), rest), ctxt)
|
||||||
| Amount, rest ->
|
| Amount, rest ->
|
||||||
Lwt.return (Gas.consume ctxt Interp_costs.amount) >>=? fun ctxt ->
|
Lwt.return (Gas.consume ctxt Interp_costs.amount) >>=? fun ctxt ->
|
||||||
logged_return (Item (amount, rest), ctxt) in
|
logged_return (Item (step_constants.amount, rest), ctxt)
|
||||||
|
| Dig (n, n'), stack ->
|
||||||
|
Lwt.return (Gas.consume ctxt (Interp_costs.stack_n_op n)) >>=? fun ctxt ->
|
||||||
|
interp_stack_prefix_preserving_operation (fun (Item (v, rest)) -> return (rest, v)) n' stack
|
||||||
|
>>=? fun (aft, x) -> logged_return (Item (x, aft), ctxt)
|
||||||
|
| Dug (n, n'), Item (v, rest) ->
|
||||||
|
Lwt.return (Gas.consume ctxt (Interp_costs.stack_n_op n)) >>=? fun ctxt ->
|
||||||
|
interp_stack_prefix_preserving_operation (fun stk -> return (Item (v, stk), ())) n' rest
|
||||||
|
>>=? fun (aft, ()) -> logged_return (aft, ctxt)
|
||||||
|
| Dipn (n, n', b), stack ->
|
||||||
|
Lwt.return (Gas.consume ctxt (Interp_costs.stack_n_op n)) >>=? fun ctxt ->
|
||||||
|
interp_stack_prefix_preserving_operation (fun stk ->
|
||||||
|
step ?log ctxt step_constants b stk >>=? fun (res, ctxt') ->
|
||||||
|
return (res, ctxt')) n' stack
|
||||||
|
>>=? fun (aft, ctxt') -> logged_return (aft, ctxt')
|
||||||
|
| Dropn (n, n'), stack ->
|
||||||
|
Lwt.return (Gas.consume ctxt (Interp_costs.stack_n_op n)) >>=? fun ctxt ->
|
||||||
|
interp_stack_prefix_preserving_operation (fun stk -> return (stk, stk)) n' stack
|
||||||
|
>>=? fun (_, rest) -> logged_return (rest, ctxt)
|
||||||
|
| ChainId, rest ->
|
||||||
|
Lwt.return (Gas.consume ctxt Interp_costs.chain_id) >>=? fun ctxt ->
|
||||||
|
logged_return (Item (step_constants.chain_id, rest), ctxt)
|
||||||
|
|
||||||
|
and interp
|
||||||
|
: type p r.
|
||||||
|
(?log: execution_trace ref ->
|
||||||
|
context ->
|
||||||
|
step_constants -> (p, r) lambda -> p ->
|
||||||
|
(r * context) tzresult Lwt.t)
|
||||||
|
= fun ?log ctxt step_constants (Lam (code, _)) arg ->
|
||||||
let stack = (Item (arg, Empty)) in
|
let stack = (Item (arg, Empty)) in
|
||||||
begin match log with
|
begin match log with
|
||||||
| None -> return_unit
|
| None -> return_unit
|
||||||
@ -837,28 +978,40 @@ let rec interp
|
|||||||
log := (code.loc, Gas.level ctxt, stack) :: !log ;
|
log := (code.loc, Gas.level ctxt, stack) :: !log ;
|
||||||
return_unit
|
return_unit
|
||||||
end >>=? fun () ->
|
end >>=? fun () ->
|
||||||
step ctxt code stack >>=? fun (Item (ret, Empty), ctxt) ->
|
step ?log ctxt step_constants code stack >>=? fun (Item (ret, Empty), ctxt) ->
|
||||||
return (ret, ctxt)
|
return (ret, ctxt)
|
||||||
|
|
||||||
(* ---- contract handling ---------------------------------------------------*)
|
(* ---- contract handling ---------------------------------------------------*)
|
||||||
|
|
||||||
and execute ?log ctxt mode ~source ~payer ~self script amount arg :
|
and execute ?log ctxt mode step_constants ~entrypoint unparsed_script arg :
|
||||||
(Script.expr * packed_internal_operation list * context *
|
(Script.expr * packed_internal_operation list * context * Contract.big_map_diff option) tzresult Lwt.t =
|
||||||
Script_typed_ir.ex_big_map option) tzresult Lwt.t =
|
parse_script ctxt unparsed_script ~legacy:true
|
||||||
parse_script ctxt script
|
>>=? fun (Ex_script { code ; arg_type ; storage ; storage_type ; root_name }, ctxt) ->
|
||||||
>>=? fun ((Ex_script { code ; arg_type ; storage ; storage_type }), ctxt) ->
|
|
||||||
trace
|
trace
|
||||||
(Bad_contract_parameter self)
|
(Bad_contract_parameter step_constants.self)
|
||||||
(parse_data ctxt arg_type arg) >>=? fun (arg, ctxt) ->
|
(Lwt.return (find_entrypoint arg_type ~root_name entrypoint)) >>=? fun (box, _) ->
|
||||||
Script.force_decode ctxt script.code >>=? fun (script_code, ctxt) ->
|
|
||||||
trace
|
trace
|
||||||
(Runtime_contract_error (self, script_code))
|
(Bad_contract_parameter step_constants.self)
|
||||||
(interp ?log ctxt ~source ~payer ~self amount code (arg, storage))
|
(parse_data ctxt ~legacy:false arg_type (box arg)) >>=? fun (arg, ctxt) ->
|
||||||
>>=? fun ((ops, sto), ctxt) ->
|
Script.force_decode ctxt unparsed_script.code >>=? fun (script_code, ctxt) ->
|
||||||
|
Script_ir_translator.collect_big_maps ctxt arg_type arg >>=? fun (to_duplicate, ctxt) ->
|
||||||
|
Script_ir_translator.collect_big_maps ctxt storage_type storage >>=? fun (to_update, ctxt) ->
|
||||||
|
trace
|
||||||
|
(Runtime_contract_error (step_constants.self, script_code))
|
||||||
|
(interp ?log ctxt step_constants code (arg, storage))
|
||||||
|
>>=? fun ((ops, storage), ctxt) ->
|
||||||
|
Script_ir_translator.extract_big_map_diff ctxt mode
|
||||||
|
~temporary:false ~to_duplicate ~to_update storage_type storage
|
||||||
|
>>=? fun (storage, big_map_diff, ctxt) ->
|
||||||
trace Cannot_serialize_storage
|
trace Cannot_serialize_storage
|
||||||
(unparse_data ctxt mode storage_type sto) >>=? fun (storage, ctxt) ->
|
(unparse_data ctxt mode storage_type storage) >>=? fun (storage, ctxt) ->
|
||||||
return (Micheline.strip_locations storage, ops, ctxt,
|
let ops, op_diffs = List.split ops in
|
||||||
Script_ir_translator.extract_big_map storage_type sto)
|
let big_map_diff = match
|
||||||
|
List.flatten (List.map (Option.unopt ~default:[]) (op_diffs @ [ big_map_diff ]))
|
||||||
|
with
|
||||||
|
| [] -> None
|
||||||
|
| diff -> Some diff in
|
||||||
|
return (Micheline.strip_locations storage, ops, ctxt, big_map_diff)
|
||||||
|
|
||||||
type execution_result =
|
type execution_result =
|
||||||
{ ctxt : context ;
|
{ ctxt : context ;
|
||||||
@ -866,26 +1019,14 @@ type execution_result =
|
|||||||
big_map_diff : Contract.big_map_diff option ;
|
big_map_diff : Contract.big_map_diff option ;
|
||||||
operations : packed_internal_operation list }
|
operations : packed_internal_operation list }
|
||||||
|
|
||||||
let trace ctxt mode ~source ~payer ~self:(self, script) ~parameter ~amount =
|
let trace ctxt mode step_constants ~script ~entrypoint ~parameter =
|
||||||
let log = ref [] in
|
let log = ref [] in
|
||||||
execute ~log ctxt mode ~source ~payer ~self script amount (Micheline.root parameter)
|
execute ~log ctxt mode step_constants ~entrypoint script (Micheline.root parameter)
|
||||||
>>=? fun (storage, operations, ctxt, big_map) ->
|
>>=? fun (storage, operations, ctxt, big_map_diff) ->
|
||||||
begin match big_map with
|
|
||||||
| None -> return (None, ctxt)
|
|
||||||
| Some big_map ->
|
|
||||||
Script_ir_translator.diff_of_big_map ctxt mode big_map >>=? fun (big_map_diff, ctxt) ->
|
|
||||||
return (Some big_map_diff, ctxt)
|
|
||||||
end >>=? fun (big_map_diff, ctxt) ->
|
|
||||||
let trace = List.rev !log in
|
let trace = List.rev !log in
|
||||||
return ({ ctxt ; storage ; big_map_diff ; operations }, trace)
|
return ({ ctxt ; storage ; big_map_diff ; operations }, trace)
|
||||||
|
|
||||||
let execute ctxt mode ~source ~payer ~self:(self, script) ~parameter ~amount =
|
let execute ctxt mode step_constants ~script ~entrypoint ~parameter =
|
||||||
execute ctxt mode ~source ~payer ~self script amount (Micheline.root parameter)
|
execute ctxt mode step_constants ~entrypoint script (Micheline.root parameter)
|
||||||
>>=? fun (storage, operations, ctxt, big_map) ->
|
>>=? fun (storage, operations, ctxt, big_map_diff) ->
|
||||||
begin match big_map with
|
|
||||||
| None -> return (None, ctxt)
|
|
||||||
| Some big_map ->
|
|
||||||
Script_ir_translator.diff_of_big_map ctxt mode big_map >>=? fun (big_map_diff, ctxt) ->
|
|
||||||
return (Some big_map_diff, ctxt)
|
|
||||||
end >>=? fun (big_map_diff, ctxt) ->
|
|
||||||
return { ctxt ; storage ; big_map_diff ; operations }
|
return { ctxt ; storage ; big_map_diff ; operations }
|
||||||
|
@ -42,26 +42,38 @@ type execution_result =
|
|||||||
big_map_diff : Contract.big_map_diff option ;
|
big_map_diff : Contract.big_map_diff option ;
|
||||||
operations : packed_internal_operation list }
|
operations : packed_internal_operation list }
|
||||||
|
|
||||||
|
type step_constants =
|
||||||
|
{ source : Contract.t ;
|
||||||
|
payer : Contract.t ;
|
||||||
|
self : Contract.t ;
|
||||||
|
amount : Tez.t ;
|
||||||
|
chain_id : Chain_id.t }
|
||||||
|
|
||||||
type 'tys stack =
|
type 'tys stack =
|
||||||
| Item : 'ty * 'rest stack -> ('ty * 'rest) stack
|
| Item : 'ty * 'rest stack -> ('ty * 'rest) stack
|
||||||
| Empty : Script_typed_ir.end_of_stack stack
|
| Empty : Script_typed_ir.end_of_stack stack
|
||||||
|
|
||||||
|
val step:
|
||||||
|
?log: execution_trace ref ->
|
||||||
|
context -> step_constants ->
|
||||||
|
('bef, 'aft) Script_typed_ir.descr ->
|
||||||
|
'bef stack ->
|
||||||
|
('aft stack * context) tzresult Lwt.t
|
||||||
|
|
||||||
val execute:
|
val execute:
|
||||||
Alpha_context.t ->
|
Alpha_context.t ->
|
||||||
Script_ir_translator.unparsing_mode ->
|
Script_ir_translator.unparsing_mode ->
|
||||||
source: Contract.t ->
|
step_constants ->
|
||||||
payer: Contract.t ->
|
script: Script.t ->
|
||||||
self: (Contract.t * Script.t) ->
|
entrypoint: string ->
|
||||||
parameter: Script.expr ->
|
parameter: Script.expr ->
|
||||||
amount: Tez.t ->
|
|
||||||
execution_result tzresult Lwt.t
|
execution_result tzresult Lwt.t
|
||||||
|
|
||||||
val trace:
|
val trace:
|
||||||
Alpha_context.t ->
|
Alpha_context.t ->
|
||||||
Script_ir_translator.unparsing_mode ->
|
Script_ir_translator.unparsing_mode ->
|
||||||
source: Contract.t ->
|
step_constants ->
|
||||||
payer: Contract.t ->
|
script: Script.t ->
|
||||||
self: (Contract.t * Script.t) ->
|
entrypoint: string ->
|
||||||
parameter: Script.expr ->
|
parameter: Script.expr ->
|
||||||
amount: Tez.t ->
|
|
||||||
(execution_result * execution_trace) tzresult Lwt.t
|
(execution_result * execution_trace) tzresult Lwt.t
|
||||||
|
@ -101,26 +101,26 @@ let gen_access_annot
|
|||||||
Some (`Var_annot (String.concat "." [v; f]))
|
Some (`Var_annot (String.concat "." [v; f]))
|
||||||
|
|
||||||
let merge_type_annot
|
let merge_type_annot
|
||||||
: type_annot option -> type_annot option -> type_annot option tzresult
|
: legacy: bool -> type_annot option -> type_annot option -> type_annot option tzresult
|
||||||
= fun annot1 annot2 ->
|
= fun ~legacy annot1 annot2 ->
|
||||||
match annot1, annot2 with
|
match annot1, annot2 with
|
||||||
| None, None
|
| None, None
|
||||||
| Some _, None
|
| Some _, None
|
||||||
| None, Some _ -> ok None
|
| None, Some _ -> ok None
|
||||||
| Some `Type_annot a1, Some `Type_annot a2 ->
|
| Some `Type_annot a1, Some `Type_annot a2 ->
|
||||||
if String.equal a1 a2
|
if legacy || String.equal a1 a2
|
||||||
then ok annot1
|
then ok annot1
|
||||||
else error (Inconsistent_annotations (":" ^ a1, ":" ^ a2))
|
else error (Inconsistent_annotations (":" ^ a1, ":" ^ a2))
|
||||||
|
|
||||||
let merge_field_annot
|
let merge_field_annot
|
||||||
: field_annot option -> field_annot option -> field_annot option tzresult
|
: legacy: bool -> field_annot option -> field_annot option -> field_annot option tzresult
|
||||||
= fun annot1 annot2 ->
|
= fun ~legacy annot1 annot2 ->
|
||||||
match annot1, annot2 with
|
match annot1, annot2 with
|
||||||
| None, None
|
| None, None
|
||||||
| Some _, None
|
| Some _, None
|
||||||
| None, Some _ -> ok None
|
| None, Some _ -> ok None
|
||||||
| Some `Field_annot a1, Some `Field_annot a2 ->
|
| Some `Field_annot a1, Some `Field_annot a2 ->
|
||||||
if String.equal a1 a2
|
if legacy || String.equal a1 a2
|
||||||
then ok annot1
|
then ok annot1
|
||||||
else error (Inconsistent_annotations ("%" ^ a1, "%" ^ a2))
|
else error (Inconsistent_annotations ("%" ^ a1, "%" ^ a2))
|
||||||
|
|
||||||
@ -257,26 +257,6 @@ let parse_composed_type_annot
|
|||||||
get_two_annot loc fields >|? fun (f1, f2) ->
|
get_two_annot loc fields >|? fun (f1, f2) ->
|
||||||
(t, f1, f2)
|
(t, f1, f2)
|
||||||
|
|
||||||
let check_const_type_annot
|
|
||||||
: int -> string list -> type_annot option -> field_annot option list -> unit tzresult Lwt.t
|
|
||||||
= fun loc annot expected_name expected_fields ->
|
|
||||||
Lwt.return
|
|
||||||
(parse_composed_type_annot loc annot >>? fun (ty_name, field1, field2) ->
|
|
||||||
merge_type_annot expected_name ty_name >>? fun _ ->
|
|
||||||
match expected_fields, field1, field2 with
|
|
||||||
| [], Some _, _ | [], _, Some _ | [_], Some _, Some _ ->
|
|
||||||
(* Too many annotations *)
|
|
||||||
error (Unexpected_annotation loc)
|
|
||||||
| _ :: _ :: _ :: _, _, _ | [_], None, Some _ ->
|
|
||||||
error (Unexpected_annotation loc)
|
|
||||||
| [], None, None -> ok ()
|
|
||||||
| [ f1; f2 ], _, _ ->
|
|
||||||
merge_field_annot f1 field1 >>? fun _ ->
|
|
||||||
merge_field_annot f2 field2 >|? fun _ -> ()
|
|
||||||
| [ f1 ], _, None ->
|
|
||||||
merge_field_annot f1 field1 >|? fun _ -> ()
|
|
||||||
)
|
|
||||||
|
|
||||||
let parse_field_annot
|
let parse_field_annot
|
||||||
: int -> string list -> field_annot option tzresult
|
: int -> string list -> field_annot option tzresult
|
||||||
= fun loc annot ->
|
= fun loc annot ->
|
||||||
@ -290,12 +270,18 @@ let extract_field_annot
|
|||||||
: Script.node -> (Script.node * field_annot option) tzresult
|
: Script.node -> (Script.node * field_annot option) tzresult
|
||||||
= function
|
= function
|
||||||
| Prim (loc, prim, args, annot) ->
|
| Prim (loc, prim, args, annot) ->
|
||||||
let field_annots, annot = List.partition (fun s ->
|
let rec extract_first acc = function
|
||||||
Compare.Int.(String.length s > 0) &&
|
| [] -> None, annot
|
||||||
Compare.Char.(s.[0] = '%')
|
| s :: rest ->
|
||||||
) annot in
|
if Compare.Int.(String.length s > 0) &&
|
||||||
parse_field_annot loc field_annots >|? fun field_annot ->
|
Compare.Char.(s.[0] = '%') then
|
||||||
Prim (loc, prim, args, annot), field_annot
|
Some s, List.rev_append acc rest
|
||||||
|
else extract_first (s :: acc) rest in
|
||||||
|
let field_annot, annot = extract_first [] annot in
|
||||||
|
let field_annot = match field_annot with
|
||||||
|
| None -> None
|
||||||
|
| Some field_annot -> Some (`Field_annot (String.sub field_annot 1 (String.length field_annot - 1))) in
|
||||||
|
ok (Prim (loc, prim, args, annot), field_annot)
|
||||||
| expr -> ok (expr, None)
|
| expr -> ok (expr, None)
|
||||||
|
|
||||||
let check_correct_field
|
let check_correct_field
|
||||||
@ -402,6 +388,19 @@ let parse_destr_annot
|
|||||||
| None -> value_annot in
|
| None -> value_annot in
|
||||||
(v, f)
|
(v, f)
|
||||||
|
|
||||||
|
let parse_entrypoint_annot
|
||||||
|
: int -> ?default:var_annot option -> string list -> (var_annot option * field_annot option) tzresult
|
||||||
|
= fun loc ?default annot ->
|
||||||
|
parse_annots loc annot >>?
|
||||||
|
classify_annot loc >>? fun (vars, types, fields) ->
|
||||||
|
error_unexpected_annot loc types >>? fun () ->
|
||||||
|
get_one_annot loc fields >>? fun f ->
|
||||||
|
get_one_annot loc vars >|? function
|
||||||
|
| Some _ as a -> (a, f)
|
||||||
|
| None -> match default with
|
||||||
|
| Some a -> (a, f)
|
||||||
|
| None -> (None, f)
|
||||||
|
|
||||||
let parse_var_type_annot
|
let parse_var_type_annot
|
||||||
: int -> string list -> (var_annot option * type_annot option) tzresult
|
: int -> string list -> (var_annot option * type_annot option) tzresult
|
||||||
= fun loc annot ->
|
= fun loc annot ->
|
||||||
|
@ -72,28 +72,28 @@ val var_to_field_annot : var_annot option -> field_annot option
|
|||||||
(** Replace an annotation by its default value if it is [None] *)
|
(** Replace an annotation by its default value if it is [None] *)
|
||||||
val default_annot : default:'a option -> 'a option -> 'a option
|
val default_annot : default:'a option -> 'a option -> 'a option
|
||||||
|
|
||||||
(** Generate annotation for field accesses, of the form @var.field1.field2 *)
|
(** Generate annotation for field accesses, of the form [var.field1.field2] *)
|
||||||
val gen_access_annot :
|
val gen_access_annot :
|
||||||
var_annot option ->
|
var_annot option ->
|
||||||
?default:field_annot option -> field_annot option -> var_annot option
|
?default:field_annot option -> field_annot option -> var_annot option
|
||||||
|
|
||||||
(** Merge type annotations.
|
(** Merge type annotations.
|
||||||
@returns an error {!Inconsistent_type_annotations} if they are both present
|
@return an error {!Inconsistent_type_annotations} if they are both present
|
||||||
and different *)
|
and different, unless [legacy] *)
|
||||||
val merge_type_annot :
|
val merge_type_annot :
|
||||||
type_annot option -> type_annot option -> type_annot option tzresult
|
legacy: bool -> type_annot option -> type_annot option -> type_annot option tzresult
|
||||||
|
|
||||||
(** Merge field annotations.
|
(** Merge field annotations.
|
||||||
@returns an error {!Inconsistent_type_annotations} if they are both present
|
@return an error {!Inconsistent_type_annotations} if they are both present
|
||||||
and different *)
|
and different, unless [legacy] *)
|
||||||
val merge_field_annot :
|
val merge_field_annot :
|
||||||
field_annot option -> field_annot option -> field_annot option tzresult
|
legacy: bool -> field_annot option -> field_annot option -> field_annot option tzresult
|
||||||
|
|
||||||
(** Merge variable annotations, does not fail ([None] if different). *)
|
(** Merge variable annotations, does not fail ([None] if different). *)
|
||||||
val merge_var_annot :
|
val merge_var_annot :
|
||||||
var_annot option -> var_annot option -> var_annot option
|
var_annot option -> var_annot option -> var_annot option
|
||||||
|
|
||||||
(** @returns an error {!Unexpected_annotation} in the monad the list is not empty. *)
|
(** @return an error {!Unexpected_annotation} in the monad the list is not empty. *)
|
||||||
val error_unexpected_annot : int -> 'a list -> unit tzresult
|
val error_unexpected_annot : int -> 'a list -> unit tzresult
|
||||||
|
|
||||||
(** Same as {!error_unexpected_annot} in Lwt. *)
|
(** Same as {!error_unexpected_annot} in Lwt. *)
|
||||||
@ -117,11 +117,6 @@ val parse_composed_type_annot :
|
|||||||
int -> string list ->
|
int -> string list ->
|
||||||
(type_annot option * field_annot option * field_annot option) tzresult
|
(type_annot option * field_annot option * field_annot option) tzresult
|
||||||
|
|
||||||
(** Check that type annotations on constants are consistent *)
|
|
||||||
val check_const_type_annot :
|
|
||||||
int -> string list -> type_annot option -> field_annot option list ->
|
|
||||||
unit tzresult Lwt.t
|
|
||||||
|
|
||||||
(** Extract and remove a field annotation from a node *)
|
(** Extract and remove a field annotation from a node *)
|
||||||
val extract_field_annot :
|
val extract_field_annot :
|
||||||
Script.node -> (Script.node * field_annot option) tzresult
|
Script.node -> (Script.node * field_annot option) tzresult
|
||||||
@ -157,5 +152,11 @@ val parse_destr_annot :
|
|||||||
value_annot:var_annot option ->
|
value_annot:var_annot option ->
|
||||||
(var_annot option * field_annot option) tzresult
|
(var_annot option * field_annot option) tzresult
|
||||||
|
|
||||||
|
val parse_entrypoint_annot :
|
||||||
|
int ->
|
||||||
|
?default:var_annot option ->
|
||||||
|
string list ->
|
||||||
|
(var_annot option * field_annot option) tzresult
|
||||||
|
|
||||||
val parse_var_type_annot :
|
val parse_var_type_annot :
|
||||||
int -> string list -> (var_annot option * type_annot option) tzresult
|
int -> string list -> (var_annot option * type_annot option) tzresult
|
||||||
|
File diff suppressed because it is too large
Load Diff
@ -32,11 +32,17 @@ type ex_comparable_ty = Ex_comparable_ty : 'a Script_typed_ir.comparable_ty -> e
|
|||||||
type ex_ty = Ex_ty : 'a Script_typed_ir.ty -> ex_ty
|
type ex_ty = Ex_ty : 'a Script_typed_ir.ty -> ex_ty
|
||||||
type ex_stack_ty = Ex_stack_ty : 'a Script_typed_ir.stack_ty -> ex_stack_ty
|
type ex_stack_ty = Ex_stack_ty : 'a Script_typed_ir.stack_ty -> ex_stack_ty
|
||||||
type ex_script = Ex_script : ('a, 'b) Script_typed_ir.script -> ex_script
|
type ex_script = Ex_script : ('a, 'b) Script_typed_ir.script -> ex_script
|
||||||
|
|
||||||
type tc_context =
|
type tc_context =
|
||||||
| Lambda : tc_context
|
| Lambda : tc_context
|
||||||
| Dip : 'a Script_typed_ir.stack_ty * tc_context -> tc_context
|
| Dip : 'a Script_typed_ir.stack_ty * tc_context -> tc_context
|
||||||
| Toplevel : { storage_type : 'sto Script_typed_ir.ty ; param_type : 'param Script_typed_ir.ty } -> tc_context
|
| Toplevel : { storage_type : 'sto Script_typed_ir.ty ;
|
||||||
|
param_type : 'param Script_typed_ir.ty ;
|
||||||
|
root_name : string option ;
|
||||||
|
legacy_create_contract_literal : bool } -> tc_context
|
||||||
|
type 'bef judgement =
|
||||||
|
| Typed : ('bef, 'aft) Script_typed_ir.descr -> 'bef judgement
|
||||||
|
| Failed :
|
||||||
|
{ descr : 'aft. 'aft Script_typed_ir.stack_ty -> ('bef, 'aft) Script_typed_ir.descr } -> 'bef judgement
|
||||||
|
|
||||||
type unparsing_mode = Optimized | Readable
|
type unparsing_mode = Optimized | Readable
|
||||||
|
|
||||||
@ -64,21 +70,20 @@ val map_get : 'key -> ('key, 'value) Script_typed_ir.map -> 'value option
|
|||||||
val map_key_ty : ('a, 'b) Script_typed_ir.map -> 'a Script_typed_ir.comparable_ty
|
val map_key_ty : ('a, 'b) Script_typed_ir.map -> 'a Script_typed_ir.comparable_ty
|
||||||
val map_size : ('a, 'b) Script_typed_ir.map -> Script_int.n Script_int.num
|
val map_size : ('a, 'b) Script_typed_ir.map -> Script_int.n Script_int.num
|
||||||
|
|
||||||
|
val empty_big_map : 'a Script_typed_ir.comparable_ty -> 'b Script_typed_ir.ty -> ('a, 'b) Script_typed_ir.big_map
|
||||||
val big_map_mem :
|
val big_map_mem :
|
||||||
context -> Contract.t -> 'key ->
|
context -> 'key ->
|
||||||
('key, 'value) Script_typed_ir.big_map ->
|
('key, 'value) Script_typed_ir.big_map ->
|
||||||
(bool * context) tzresult Lwt.t
|
(bool * context) tzresult Lwt.t
|
||||||
val big_map_get :
|
val big_map_get :
|
||||||
context ->
|
context -> 'key ->
|
||||||
Contract.t -> 'key ->
|
|
||||||
('key, 'value) Script_typed_ir.big_map ->
|
('key, 'value) Script_typed_ir.big_map ->
|
||||||
('value option * context) tzresult Lwt.t
|
('value option * context) tzresult Lwt.t
|
||||||
val big_map_update :
|
val big_map_update :
|
||||||
'key -> 'value option -> ('key, 'value) Script_typed_ir.big_map ->
|
'key -> 'value option -> ('key, 'value) Script_typed_ir.big_map ->
|
||||||
('key, 'value) Script_typed_ir.big_map
|
('key, 'value) Script_typed_ir.big_map
|
||||||
|
|
||||||
val ty_of_comparable_ty :
|
val has_big_map : 't Script_typed_ir.ty -> bool
|
||||||
'a Script_typed_ir.comparable_ty -> 'a Script_typed_ir.ty
|
|
||||||
|
|
||||||
|
|
||||||
val ty_eq :
|
val ty_eq :
|
||||||
@ -86,25 +91,41 @@ val ty_eq :
|
|||||||
'ta Script_typed_ir.ty -> 'tb Script_typed_ir.ty ->
|
'ta Script_typed_ir.ty -> 'tb Script_typed_ir.ty ->
|
||||||
(('ta Script_typed_ir.ty, 'tb Script_typed_ir.ty) eq * context) tzresult
|
(('ta Script_typed_ir.ty, 'tb Script_typed_ir.ty) eq * context) tzresult
|
||||||
|
|
||||||
|
val compare_comparable : 'a Script_typed_ir.comparable_ty -> 'a -> 'a -> int
|
||||||
|
|
||||||
|
val ty_of_comparable_ty : ('a, 's) Script_typed_ir.comparable_struct -> 'a Script_typed_ir.ty
|
||||||
|
|
||||||
val parse_data :
|
val parse_data :
|
||||||
?type_logger: type_logger ->
|
?type_logger: type_logger ->
|
||||||
context ->
|
context -> legacy: bool ->
|
||||||
'a Script_typed_ir.ty -> Script.node -> ('a * context) tzresult Lwt.t
|
'a Script_typed_ir.ty -> Script.node -> ('a * context) tzresult Lwt.t
|
||||||
val unparse_data :
|
val unparse_data :
|
||||||
context -> unparsing_mode -> 'a Script_typed_ir.ty -> 'a ->
|
context -> unparsing_mode -> 'a Script_typed_ir.ty -> 'a ->
|
||||||
(Script.node * context) tzresult Lwt.t
|
(Script.node * context) tzresult Lwt.t
|
||||||
|
|
||||||
|
val parse_instr :
|
||||||
|
?type_logger: type_logger ->
|
||||||
|
tc_context -> context -> legacy: bool ->
|
||||||
|
Script.node -> 'bef Script_typed_ir.stack_ty -> ('bef judgement * context) tzresult Lwt.t
|
||||||
|
|
||||||
val parse_ty :
|
val parse_ty :
|
||||||
context ->
|
context -> legacy: bool ->
|
||||||
allow_big_map: bool ->
|
allow_big_map: bool ->
|
||||||
allow_operation: bool ->
|
allow_operation: bool ->
|
||||||
|
allow_contract: bool ->
|
||||||
Script.node -> (ex_ty * context) tzresult
|
Script.node -> (ex_ty * context) tzresult
|
||||||
|
|
||||||
|
val parse_packable_ty :
|
||||||
|
context -> legacy: bool -> Script.node -> (ex_ty * context) tzresult
|
||||||
|
|
||||||
val unparse_ty :
|
val unparse_ty :
|
||||||
context -> 'a Script_typed_ir.ty -> (Script.node * context) tzresult Lwt.t
|
context -> 'a Script_typed_ir.ty -> (Script.node * context) tzresult Lwt.t
|
||||||
|
|
||||||
val parse_toplevel :
|
val parse_toplevel :
|
||||||
Script.expr -> (Script.node * Script.node * Script.node) tzresult
|
legacy: bool -> Script.expr -> (Script.node * Script.node * Script.node * string option) tzresult
|
||||||
|
|
||||||
|
val add_field_annot :
|
||||||
|
[ `Field_annot of string ] option -> [ `Var_annot of string ] option -> Script.node -> Script.node
|
||||||
|
|
||||||
val typecheck_code :
|
val typecheck_code :
|
||||||
context -> Script.expr -> (type_map * context) tzresult Lwt.t
|
context -> Script.expr -> (type_map * context) tzresult Lwt.t
|
||||||
@ -113,18 +134,9 @@ val typecheck_data :
|
|||||||
?type_logger: type_logger ->
|
?type_logger: type_logger ->
|
||||||
context -> Script.expr * Script.expr -> context tzresult Lwt.t
|
context -> Script.expr * Script.expr -> context tzresult Lwt.t
|
||||||
|
|
||||||
type 'bef judgement =
|
|
||||||
| Typed : ('bef, 'aft) Script_typed_ir.descr -> 'bef judgement
|
|
||||||
| Failed : { descr : 'aft. 'aft Script_typed_ir.stack_ty -> ('bef, 'aft) Script_typed_ir.descr } -> 'bef judgement
|
|
||||||
|
|
||||||
val parse_instr :
|
|
||||||
?type_logger: type_logger ->
|
|
||||||
tc_context -> context ->
|
|
||||||
Script.node -> 'bef Script_typed_ir.stack_ty -> ('bef judgement * context) tzresult Lwt.t
|
|
||||||
|
|
||||||
val parse_script :
|
val parse_script :
|
||||||
?type_logger: type_logger ->
|
?type_logger: type_logger ->
|
||||||
context -> Script.t -> (ex_script * context) tzresult Lwt.t
|
context -> legacy: bool -> Script.t -> (ex_script * context) tzresult Lwt.t
|
||||||
|
|
||||||
(* Gas accounting may not be perfect in this function, as it is only called by RPCs. *)
|
(* Gas accounting may not be perfect in this function, as it is only called by RPCs. *)
|
||||||
val unparse_script :
|
val unparse_script :
|
||||||
@ -132,23 +144,44 @@ val unparse_script :
|
|||||||
('a, 'b) Script_typed_ir.script -> (Script.t * context) tzresult Lwt.t
|
('a, 'b) Script_typed_ir.script -> (Script.t * context) tzresult Lwt.t
|
||||||
|
|
||||||
val parse_contract :
|
val parse_contract :
|
||||||
context -> Script.location -> 'a Script_typed_ir.ty -> Contract.t ->
|
legacy: bool -> context -> Script.location -> 'a Script_typed_ir.ty -> Contract.t ->
|
||||||
|
entrypoint: string ->
|
||||||
(context * 'a Script_typed_ir.typed_contract) tzresult Lwt.t
|
(context * 'a Script_typed_ir.typed_contract) tzresult Lwt.t
|
||||||
|
|
||||||
val parse_contract_for_script :
|
val parse_contract_for_script :
|
||||||
context -> Script.location -> 'a Script_typed_ir.ty -> Contract.t ->
|
legacy: bool -> context -> Script.location -> 'a Script_typed_ir.ty -> Contract.t ->
|
||||||
|
entrypoint: string ->
|
||||||
(context * 'a Script_typed_ir.typed_contract option) tzresult Lwt.t
|
(context * 'a Script_typed_ir.typed_contract option) tzresult Lwt.t
|
||||||
|
|
||||||
|
val find_entrypoint :
|
||||||
|
't Script_typed_ir.ty -> root_name: string option -> string -> ((Script.node -> Script.node) * ex_ty) tzresult
|
||||||
|
|
||||||
|
module Entrypoints_map : S.MAP with type key = string
|
||||||
|
|
||||||
|
val list_entrypoints :
|
||||||
|
't Script_typed_ir.ty ->
|
||||||
|
context ->
|
||||||
|
root_name: string option ->
|
||||||
|
(Michelson_v1_primitives.prim list list *
|
||||||
|
(Michelson_v1_primitives.prim list * Script.node) Entrypoints_map.t)
|
||||||
|
tzresult
|
||||||
|
|
||||||
val pack_data : context -> 'a Script_typed_ir.ty -> 'a -> (MBytes.t * context) tzresult Lwt.t
|
val pack_data : context -> 'a Script_typed_ir.ty -> 'a -> (MBytes.t * context) tzresult Lwt.t
|
||||||
val hash_data : context -> 'a Script_typed_ir.ty -> 'a -> (Script_expr_hash.t * context) tzresult Lwt.t
|
val hash_data : context -> 'a Script_typed_ir.ty -> 'a -> (Script_expr_hash.t * context) tzresult Lwt.t
|
||||||
|
|
||||||
val extract_big_map :
|
type big_map_ids
|
||||||
'a Script_typed_ir.ty -> 'a -> Script_typed_ir.ex_big_map option
|
|
||||||
|
|
||||||
val diff_of_big_map :
|
val no_big_map_id : big_map_ids
|
||||||
context -> unparsing_mode -> Script_typed_ir.ex_big_map ->
|
|
||||||
(Contract.big_map_diff * context) tzresult Lwt.t
|
|
||||||
|
|
||||||
val big_map_initialization :
|
val collect_big_maps :
|
||||||
context -> unparsing_mode -> ex_script ->
|
context -> 'a Script_typed_ir.ty -> 'a -> (big_map_ids * context) tzresult Lwt.t
|
||||||
(Contract.big_map_diff option * context) tzresult Lwt.t
|
|
||||||
|
val list_of_big_map_ids : big_map_ids -> Z.t list
|
||||||
|
|
||||||
|
val extract_big_map_diff :
|
||||||
|
context -> unparsing_mode ->
|
||||||
|
temporary: bool ->
|
||||||
|
to_duplicate: big_map_ids ->
|
||||||
|
to_update: big_map_ids ->
|
||||||
|
'a Script_typed_ir.ty -> 'a ->
|
||||||
|
('a * Contract.big_map_diff option * context) tzresult Lwt.t
|
||||||
|
@ -62,7 +62,7 @@ let lazy_expr expr =
|
|||||||
|
|
||||||
type t = {
|
type t = {
|
||||||
code : lazy_expr ;
|
code : lazy_expr ;
|
||||||
storage : lazy_expr
|
storage : lazy_expr ;
|
||||||
}
|
}
|
||||||
|
|
||||||
let encoding =
|
let encoding =
|
||||||
@ -195,3 +195,25 @@ let minimal_deserialize_cost lexpr =
|
|||||||
~fun_bytes:(fun b -> serialized_cost b)
|
~fun_bytes:(fun b -> serialized_cost b)
|
||||||
~fun_combine:(fun c_free _ -> c_free)
|
~fun_combine:(fun c_free _ -> c_free)
|
||||||
lexpr
|
lexpr
|
||||||
|
|
||||||
|
let unit =
|
||||||
|
Micheline.strip_locations (Prim (0, Michelson_v1_primitives.D_Unit, [], []))
|
||||||
|
|
||||||
|
let unit_parameter =
|
||||||
|
lazy_expr unit
|
||||||
|
|
||||||
|
let is_unit_parameter =
|
||||||
|
let unit_bytes = Data_encoding.force_bytes unit_parameter in
|
||||||
|
Data_encoding.apply_lazy
|
||||||
|
~fun_value:(fun v -> match Micheline.root v with Prim (_, Michelson_v1_primitives.D_Unit, [], []) -> true | _ -> false)
|
||||||
|
~fun_bytes:(fun b -> MBytes.(=) b unit_bytes)
|
||||||
|
~fun_combine:(fun res _ -> res)
|
||||||
|
|
||||||
|
let rec strip_annotations node =
|
||||||
|
let open Micheline in
|
||||||
|
match node with
|
||||||
|
| Int (_, _) | String (_, _) | Bytes (_, _) as leaf -> leaf
|
||||||
|
| Prim (loc, name, args, _) ->
|
||||||
|
Prim (loc, name, List.map strip_annotations args, [])
|
||||||
|
| Seq (loc, args) ->
|
||||||
|
Seq (loc, List.map strip_annotations args)
|
||||||
|
@ -69,3 +69,9 @@ val force_decode : lazy_expr -> (expr * Gas_limit_repr.cost) tzresult
|
|||||||
val force_bytes : lazy_expr -> (MBytes.t * Gas_limit_repr.cost) tzresult
|
val force_bytes : lazy_expr -> (MBytes.t * Gas_limit_repr.cost) tzresult
|
||||||
|
|
||||||
val minimal_deserialize_cost : lazy_expr -> Gas_limit_repr.cost
|
val minimal_deserialize_cost : lazy_expr -> Gas_limit_repr.cost
|
||||||
|
|
||||||
|
val unit_parameter : lazy_expr
|
||||||
|
|
||||||
|
val is_unit_parameter : lazy_expr -> bool
|
||||||
|
|
||||||
|
val strip_annotations : node -> node
|
||||||
|
@ -44,6 +44,11 @@ type error += Missing_field of prim
|
|||||||
type error += Duplicate_field of Script.location * prim
|
type error += Duplicate_field of Script.location * prim
|
||||||
type error += Unexpected_big_map of Script.location
|
type error += Unexpected_big_map of Script.location
|
||||||
type error += Unexpected_operation of Script.location
|
type error += Unexpected_operation of Script.location
|
||||||
|
type error += Unexpected_contract of Script.location
|
||||||
|
type error += No_such_entrypoint of string
|
||||||
|
type error += Duplicate_entrypoint of string
|
||||||
|
type error += Unreachable_entrypoint of prim list
|
||||||
|
type error += Entrypoint_name_too_long of string
|
||||||
|
|
||||||
(* Instruction typing errors *)
|
(* Instruction typing errors *)
|
||||||
type error += Fail_not_in_tail_position of Script.location
|
type error += Fail_not_in_tail_position of Script.location
|
||||||
@ -67,7 +72,9 @@ type error += Type_too_large : Script.location * int * int -> error
|
|||||||
|
|
||||||
(* Value typing errors *)
|
(* Value typing errors *)
|
||||||
type error += Invalid_constant : Script.location * Script.expr * Script.expr -> error
|
type error += Invalid_constant : Script.location * Script.expr * Script.expr -> error
|
||||||
|
type error += Invalid_syntactic_constant : Script.location * Script.expr * string -> error
|
||||||
type error += Invalid_contract of Script.location * Contract.t
|
type error += Invalid_contract of Script.location * Contract.t
|
||||||
|
type error += Invalid_big_map of Script.location * Big_map.id
|
||||||
type error += Comparable_type_expected : Script.location * Script.expr -> error
|
type error += Comparable_type_expected : Script.location * Script.expr -> error
|
||||||
type error += Inconsistent_types : Script.expr * Script.expr -> error
|
type error += Inconsistent_types : Script.expr * Script.expr -> error
|
||||||
type error += Unordered_map_keys of Script.location * Script.expr
|
type error += Unordered_map_keys of Script.location * Script.expr
|
||||||
@ -82,3 +89,6 @@ type error += Ill_typed_contract : Script.expr * type_map -> error
|
|||||||
|
|
||||||
(* Gas related errors *)
|
(* Gas related errors *)
|
||||||
type error += Cannot_serialize_error
|
type error += Cannot_serialize_error
|
||||||
|
|
||||||
|
(* Deprecation errors *)
|
||||||
|
type error += Deprecated_instruction of prim
|
||||||
|
@ -170,8 +170,9 @@ let () =
|
|||||||
~id:"michelson_v1.unexpected_bigmap"
|
~id:"michelson_v1.unexpected_bigmap"
|
||||||
~title: "Big map in unauthorized position (type error)"
|
~title: "Big map in unauthorized position (type error)"
|
||||||
~description:
|
~description:
|
||||||
"When parsing script, a big_map type was found somewhere else \
|
"When parsing script, a big_map type was found in a position \
|
||||||
than in the left component of the toplevel storage pair."
|
where it could end up stored inside a big_map, which is \
|
||||||
|
forbidden for now."
|
||||||
(obj1
|
(obj1
|
||||||
(req "loc" location_encoding))
|
(req "loc" location_encoding))
|
||||||
(function Unexpected_big_map loc -> Some loc | _ -> None)
|
(function Unexpected_big_map loc -> Some loc | _ -> None)
|
||||||
@ -180,14 +181,70 @@ let () =
|
|||||||
register_error_kind
|
register_error_kind
|
||||||
`Permanent
|
`Permanent
|
||||||
~id:"michelson_v1.unexpected_operation"
|
~id:"michelson_v1.unexpected_operation"
|
||||||
~title: "Big map in unauthorized position (type error)"
|
~title: "Operation in unauthorized position (type error)"
|
||||||
~description:
|
~description:
|
||||||
"When parsing script, a operation type was found \
|
"When parsing script, an operation type was found \
|
||||||
in the storage or parameter field."
|
in the storage or parameter field."
|
||||||
(obj1
|
(obj1
|
||||||
(req "loc" location_encoding))
|
(req "loc" location_encoding))
|
||||||
(function Unexpected_operation loc -> Some loc | _ -> None)
|
(function Unexpected_operation loc -> Some loc | _ -> None)
|
||||||
(fun loc -> Unexpected_operation loc) ;
|
(fun loc -> Unexpected_operation loc) ;
|
||||||
|
(* No such entrypoint *)
|
||||||
|
register_error_kind
|
||||||
|
`Permanent
|
||||||
|
~id:"michelson_v1.no_such_entrypoint"
|
||||||
|
~title: "No such entrypoint (type error)"
|
||||||
|
~description:
|
||||||
|
"An entrypoint was not found when calling a contract."
|
||||||
|
(obj1
|
||||||
|
(req "entrypoint" string))
|
||||||
|
(function No_such_entrypoint entrypoint -> Some entrypoint | _ -> None)
|
||||||
|
(fun entrypoint -> No_such_entrypoint entrypoint) ;
|
||||||
|
(* Unreachable entrypoint *)
|
||||||
|
register_error_kind
|
||||||
|
`Permanent
|
||||||
|
~id:"michelson_v1.unreachable_entrypoint"
|
||||||
|
~title: "Unreachable entrypoint (type error)"
|
||||||
|
~description:
|
||||||
|
"An entrypoint in the contract is not reachable."
|
||||||
|
(obj1
|
||||||
|
(req "path" (list prim_encoding)))
|
||||||
|
(function Unreachable_entrypoint path -> Some path | _ -> None)
|
||||||
|
(fun path -> Unreachable_entrypoint path) ;
|
||||||
|
(* Duplicate entrypoint *)
|
||||||
|
register_error_kind
|
||||||
|
`Permanent
|
||||||
|
~id:"michelson_v1.duplicate_entrypoint"
|
||||||
|
~title: "Duplicate entrypoint (type error)"
|
||||||
|
~description:
|
||||||
|
"Two entrypoints have the same name."
|
||||||
|
(obj1
|
||||||
|
(req "path" string))
|
||||||
|
(function Duplicate_entrypoint entrypoint -> Some entrypoint | _ -> None)
|
||||||
|
(fun entrypoint -> Duplicate_entrypoint entrypoint) ;
|
||||||
|
(* Entrypoint name too long *)
|
||||||
|
register_error_kind
|
||||||
|
`Permanent
|
||||||
|
~id:"michelson_v1.entrypoint_name_too_long"
|
||||||
|
~title: "Entrypoint name too long (type error)"
|
||||||
|
~description:
|
||||||
|
"An entrypoint name exceeds the maximum length of 31 characters."
|
||||||
|
(obj1
|
||||||
|
(req "name" string))
|
||||||
|
(function Entrypoint_name_too_long entrypoint -> Some entrypoint | _ -> None)
|
||||||
|
(fun entrypoint -> Entrypoint_name_too_long entrypoint) ;
|
||||||
|
(* Unexpected contract *)
|
||||||
|
register_error_kind
|
||||||
|
`Permanent
|
||||||
|
~id:"michelson_v1.unexpected_contract"
|
||||||
|
~title: "Contract in unauthorized position (type error)"
|
||||||
|
~description:
|
||||||
|
"When parsing script, a contract type was found \
|
||||||
|
in the storage or parameter field."
|
||||||
|
(obj1
|
||||||
|
(req "loc" location_encoding))
|
||||||
|
(function Unexpected_contract loc -> Some loc | _ -> None)
|
||||||
|
(fun loc -> Unexpected_contract loc) ;
|
||||||
(* -- Value typing errors ---------------------- *)
|
(* -- Value typing errors ---------------------- *)
|
||||||
(* Unordered map keys *)
|
(* Unordered map keys *)
|
||||||
register_error_kind
|
register_error_kind
|
||||||
@ -454,6 +511,22 @@ let () =
|
|||||||
| _ -> None)
|
| _ -> None)
|
||||||
(fun (loc, (ty, expr)) ->
|
(fun (loc, (ty, expr)) ->
|
||||||
Invalid_constant (loc, expr, ty)) ;
|
Invalid_constant (loc, expr, ty)) ;
|
||||||
|
(* Invalid syntactic constant *)
|
||||||
|
register_error_kind
|
||||||
|
`Permanent
|
||||||
|
~id:"invalidSyntacticConstantError"
|
||||||
|
~title: "Invalid constant (parse error)"
|
||||||
|
~description:
|
||||||
|
"A compile-time constant was invalid for its expected form."
|
||||||
|
(located (obj2
|
||||||
|
(req "expectedForm" Script.expr_encoding)
|
||||||
|
(req "wrongExpression" Script.expr_encoding)))
|
||||||
|
(function
|
||||||
|
| Invalid_constant (loc, expr, ty) ->
|
||||||
|
Some (loc, (ty, expr))
|
||||||
|
| _ -> None)
|
||||||
|
(fun (loc, (ty, expr)) ->
|
||||||
|
Invalid_constant (loc, expr, ty)) ;
|
||||||
(* Invalid contract *)
|
(* Invalid contract *)
|
||||||
register_error_kind
|
register_error_kind
|
||||||
`Permanent
|
`Permanent
|
||||||
@ -469,6 +542,21 @@ let () =
|
|||||||
| _ -> None)
|
| _ -> None)
|
||||||
(fun (loc, c) ->
|
(fun (loc, c) ->
|
||||||
Invalid_contract (loc, c)) ;
|
Invalid_contract (loc, c)) ;
|
||||||
|
(* Invalid big_map *)
|
||||||
|
register_error_kind
|
||||||
|
`Permanent
|
||||||
|
~id:"michelson_v1.invalid_big_map"
|
||||||
|
~title: "Invalid big_map"
|
||||||
|
~description:
|
||||||
|
"A script or data expression references a big_map that does not \
|
||||||
|
exist or assumes a wrong type for an existing big_map."
|
||||||
|
(located (obj1 (req "big_map" z)))
|
||||||
|
(function
|
||||||
|
| Invalid_big_map (loc, c) ->
|
||||||
|
Some (loc, c)
|
||||||
|
| _ -> None)
|
||||||
|
(fun (loc, c) ->
|
||||||
|
Invalid_big_map (loc, c)) ;
|
||||||
(* Comparable type expected *)
|
(* Comparable type expected *)
|
||||||
register_error_kind
|
register_error_kind
|
||||||
`Permanent
|
`Permanent
|
||||||
@ -619,4 +707,14 @@ let () =
|
|||||||
the provided gas"
|
the provided gas"
|
||||||
Data_encoding.empty
|
Data_encoding.empty
|
||||||
(function Cannot_serialize_error -> Some () | _ -> None)
|
(function Cannot_serialize_error -> Some () | _ -> None)
|
||||||
(fun () -> Cannot_serialize_error)
|
(fun () -> Cannot_serialize_error) ;
|
||||||
|
(* Deprecated instruction *)
|
||||||
|
register_error_kind
|
||||||
|
`Permanent
|
||||||
|
~id:"michelson_v1.deprecated_instruction"
|
||||||
|
~title:"Script is using a deprecated instruction"
|
||||||
|
~description:
|
||||||
|
"A deprecated instruction usage is disallowed in newly created contracts"
|
||||||
|
(obj1 (req "prim" prim_encoding))
|
||||||
|
(function Deprecated_instruction prim -> Some prim | _ -> None)
|
||||||
|
(fun prim -> Deprecated_instruction prim) ;
|
||||||
|
@ -34,20 +34,35 @@ type field_annot = [ `Field_annot of string ]
|
|||||||
|
|
||||||
type annot = [ var_annot | type_annot | field_annot ]
|
type annot = [ var_annot | type_annot | field_annot ]
|
||||||
|
|
||||||
type 'ty comparable_ty =
|
type address = Contract.t * string
|
||||||
| Int_key : type_annot option -> (z num) comparable_ty
|
|
||||||
| Nat_key : type_annot option -> (n num) comparable_ty
|
|
||||||
| String_key : type_annot option -> string comparable_ty
|
|
||||||
| Bytes_key : type_annot option -> MBytes.t comparable_ty
|
|
||||||
| Mutez_key : type_annot option -> Tez.t comparable_ty
|
|
||||||
| Bool_key : type_annot option -> bool comparable_ty
|
|
||||||
| Key_hash_key : type_annot option -> public_key_hash comparable_ty
|
|
||||||
| Timestamp_key : type_annot option -> Script_timestamp.t comparable_ty
|
|
||||||
| Address_key : type_annot option -> Contract.t comparable_ty
|
|
||||||
|
|
||||||
|
type ('a, 'b) pair = 'a * 'b
|
||||||
|
|
||||||
|
type ('a, 'b) union = L of 'a | R of 'b
|
||||||
|
|
||||||
|
type comb = Comb
|
||||||
|
type leaf = Leaf
|
||||||
|
|
||||||
|
type (_, _) comparable_struct =
|
||||||
|
| Int_key : type_annot option -> (z num, _) comparable_struct
|
||||||
|
| Nat_key : type_annot option -> (n num, _) comparable_struct
|
||||||
|
| String_key : type_annot option -> (string, _) comparable_struct
|
||||||
|
| Bytes_key : type_annot option -> (MBytes.t, _) comparable_struct
|
||||||
|
| Mutez_key : type_annot option -> (Tez.t, _) comparable_struct
|
||||||
|
| Bool_key : type_annot option -> (bool, _) comparable_struct
|
||||||
|
| Key_hash_key : type_annot option -> (public_key_hash, _) comparable_struct
|
||||||
|
| Timestamp_key : type_annot option -> (Script_timestamp.t, _) comparable_struct
|
||||||
|
| Address_key : type_annot option -> (address, _) comparable_struct
|
||||||
|
| Pair_key :
|
||||||
|
(('a, leaf) comparable_struct * field_annot option) *
|
||||||
|
(('b, _) comparable_struct * field_annot option) *
|
||||||
|
type_annot option -> (('a, 'b) pair, comb) comparable_struct
|
||||||
|
|
||||||
|
type 'a comparable_ty = ('a, comb) comparable_struct
|
||||||
|
|
||||||
module type Boxed_set = sig
|
module type Boxed_set = sig
|
||||||
type elt
|
type elt
|
||||||
|
val elt_ty : elt comparable_ty
|
||||||
module OPS : S.SET with type elt = elt
|
module OPS : S.SET with type elt = elt
|
||||||
val boxed : OPS.t
|
val boxed : OPS.t
|
||||||
val size : int
|
val size : int
|
||||||
@ -65,23 +80,21 @@ end
|
|||||||
|
|
||||||
type ('key, 'value) map = (module Boxed_map with type key = 'key and type value = 'value)
|
type ('key, 'value) map = (module Boxed_map with type key = 'key and type value = 'value)
|
||||||
|
|
||||||
|
type operation = packed_internal_operation * Contract.big_map_diff option
|
||||||
|
|
||||||
type ('arg, 'storage) script =
|
type ('arg, 'storage) script =
|
||||||
{ code : (('arg, 'storage) pair, (packed_internal_operation list, 'storage) pair) lambda ;
|
{ code : (('arg, 'storage) pair, (operation list, 'storage) pair) lambda ;
|
||||||
arg_type : 'arg ty ;
|
arg_type : 'arg ty ;
|
||||||
storage : 'storage ;
|
storage : 'storage ;
|
||||||
storage_type : 'storage ty }
|
storage_type : 'storage ty ;
|
||||||
|
root_name : string option }
|
||||||
and ('a, 'b) pair = 'a * 'b
|
|
||||||
|
|
||||||
and ('a, 'b) union = L of 'a | R of 'b
|
|
||||||
|
|
||||||
and end_of_stack = unit
|
and end_of_stack = unit
|
||||||
|
|
||||||
and ('arg, 'ret) lambda =
|
and ('arg, 'ret) lambda =
|
||||||
Lam of ('arg * end_of_stack, 'ret * end_of_stack) descr * Script.expr
|
Lam : ('arg * end_of_stack, 'ret * end_of_stack) descr * Script.node -> ('arg, 'ret) lambda
|
||||||
|
|
||||||
and 'arg typed_contract =
|
and 'arg typed_contract = 'arg ty * address
|
||||||
'arg ty * Contract.t
|
|
||||||
|
|
||||||
and 'ty ty =
|
and 'ty ty =
|
||||||
| Unit_t : type_annot option -> unit ty
|
| Unit_t : type_annot option -> unit ty
|
||||||
@ -94,39 +107,48 @@ and 'ty ty =
|
|||||||
| Key_hash_t : type_annot option -> public_key_hash ty
|
| Key_hash_t : type_annot option -> public_key_hash ty
|
||||||
| Key_t : type_annot option -> public_key ty
|
| Key_t : type_annot option -> public_key ty
|
||||||
| Timestamp_t : type_annot option -> Script_timestamp.t ty
|
| Timestamp_t : type_annot option -> Script_timestamp.t ty
|
||||||
| Address_t : type_annot option -> Contract.t ty
|
| Address_t : type_annot option -> address ty
|
||||||
| Bool_t : type_annot option -> bool ty
|
| Bool_t : type_annot option -> bool ty
|
||||||
| Pair_t :
|
| Pair_t :
|
||||||
('a ty * field_annot option * var_annot option) *
|
('a ty * field_annot option * var_annot option) *
|
||||||
('b ty * field_annot option * var_annot option) *
|
('b ty * field_annot option * var_annot option) *
|
||||||
type_annot option -> ('a, 'b) pair ty
|
type_annot option *
|
||||||
| Union_t : ('a ty * field_annot option) * ('b ty * field_annot option) * type_annot option -> ('a, 'b) union ty
|
bool -> ('a, 'b) pair ty
|
||||||
|
| Union_t :
|
||||||
|
('a ty * field_annot option) *
|
||||||
|
('b ty * field_annot option) *
|
||||||
|
type_annot option *
|
||||||
|
bool -> ('a, 'b) union ty
|
||||||
| Lambda_t : 'arg ty * 'ret ty * type_annot option -> ('arg, 'ret) lambda ty
|
| Lambda_t : 'arg ty * 'ret ty * type_annot option -> ('arg, 'ret) lambda ty
|
||||||
| Option_t : ('v ty * field_annot option) * field_annot option * type_annot option -> 'v option ty
|
| Option_t : 'v ty * type_annot option * bool -> 'v option ty
|
||||||
| List_t : 'v ty * type_annot option -> 'v list ty
|
| List_t : 'v ty * type_annot option * bool -> 'v list ty
|
||||||
| Set_t : 'v comparable_ty * type_annot option -> 'v set ty
|
| Set_t : 'v comparable_ty * type_annot option -> 'v set ty
|
||||||
| Map_t : 'k comparable_ty * 'v ty * type_annot option -> ('k, 'v) map ty
|
| Map_t : 'k comparable_ty * 'v ty * type_annot option * bool -> ('k, 'v) map ty
|
||||||
| Big_map_t : 'k comparable_ty * 'v ty * type_annot option -> ('k, 'v) big_map ty
|
| Big_map_t : 'k comparable_ty * 'v ty * type_annot option -> ('k, 'v) big_map ty
|
||||||
| Contract_t : 'arg ty * type_annot option -> 'arg typed_contract ty
|
| Contract_t : 'arg ty * type_annot option -> 'arg typed_contract ty
|
||||||
| Operation_t : type_annot option -> packed_internal_operation ty
|
| Operation_t : type_annot option -> operation ty
|
||||||
|
| Chain_id_t : type_annot option -> Chain_id.t ty
|
||||||
|
|
||||||
and 'ty stack_ty =
|
and 'ty stack_ty =
|
||||||
| Item_t : 'ty ty * 'rest stack_ty * var_annot option -> ('ty * 'rest) stack_ty
|
| Item_t : 'ty ty * 'rest stack_ty * var_annot option -> ('ty * 'rest) stack_ty
|
||||||
| Empty_t : end_of_stack stack_ty
|
| Empty_t : end_of_stack stack_ty
|
||||||
|
|
||||||
and ('key, 'value) big_map = { diff : ('key, 'value option) map ;
|
and ('key, 'value) big_map = { id : Z.t option ;
|
||||||
|
diff : ('key, 'value option) map ;
|
||||||
key_type : 'key ty ;
|
key_type : 'key ty ;
|
||||||
value_type : 'value ty }
|
value_type : 'value ty }
|
||||||
|
|
||||||
(* ---- Instructions --------------------------------------------------------*)
|
(* ---- Instructions --------------------------------------------------------*)
|
||||||
|
|
||||||
(* The low-level, typed instructions, as a GADT whose parameters
|
(* The low-level, typed instructions, as a GADT whose parameters
|
||||||
encode the typing rules. The left parameter is the typed shape of
|
encode the typing rules.
|
||||||
the stack before the instruction, the right one the shape
|
|
||||||
after. Any program whose construction is accepted by OCaml's
|
The left parameter is the typed shape of the stack before the
|
||||||
type-checker is guaranteed to be type-safe. Overloadings of the
|
instruction, the right one the shape after. Any program whose
|
||||||
concrete syntax are already resolved in this representation, either
|
construction is accepted by OCaml's type-checker is guaranteed to
|
||||||
by using different constructors or type witness parameters. *)
|
be type-safe. Overloadings of the concrete syntax are already
|
||||||
|
resolved in this representation, either by using different
|
||||||
|
constructors or type witness parameters. *)
|
||||||
and ('bef, 'aft) instr =
|
and ('bef, 'aft) instr =
|
||||||
(* stack ops *)
|
(* stack ops *)
|
||||||
| Drop :
|
| Drop :
|
||||||
@ -195,6 +217,8 @@ and ('bef, 'aft) instr =
|
|||||||
('a * ('v option * (('a, 'v) map * 'rest)), ('a, 'v) map * 'rest) instr
|
('a * ('v option * (('a, 'v) map * 'rest)), ('a, 'v) map * 'rest) instr
|
||||||
| Map_size : (('a, 'b) map * 'rest, n num * 'rest) instr
|
| Map_size : (('a, 'b) map * 'rest, n num * 'rest) instr
|
||||||
(* big maps *)
|
(* big maps *)
|
||||||
|
| Empty_big_map : 'a comparable_ty * 'v ty ->
|
||||||
|
('rest, ('a, 'v) big_map * 'rest) instr
|
||||||
| Big_map_mem :
|
| Big_map_mem :
|
||||||
('a * (('a, 'v) big_map * 'rest), bool * 'rest) instr
|
('a * (('a, 'v) big_map * 'rest), bool * 'rest) instr
|
||||||
| Big_map_get :
|
| Big_map_get :
|
||||||
@ -232,10 +256,7 @@ and ('bef, 'aft) instr =
|
|||||||
| Diff_timestamps :
|
| Diff_timestamps :
|
||||||
(Script_timestamp.t * (Script_timestamp.t * 'rest),
|
(Script_timestamp.t * (Script_timestamp.t * 'rest),
|
||||||
z num * 'rest) instr
|
z num * 'rest) instr
|
||||||
(* currency operations *)
|
(* tez operations *)
|
||||||
(* TODO: we can either just have conversions to/from integers and
|
|
||||||
do all operations on integers, or we need more operations on
|
|
||||||
Tez. Also Sub_tez should return Tez.t option (if negative) and *)
|
|
||||||
| Add_tez :
|
| Add_tez :
|
||||||
(Tez.t * (Tez.t * 'rest), Tez.t * 'rest) instr
|
(Tez.t * (Tez.t * 'rest), Tez.t * 'rest) instr
|
||||||
| Sub_tez :
|
| Sub_tez :
|
||||||
@ -323,6 +344,8 @@ and ('bef, 'aft) instr =
|
|||||||
('top * 'bef, 'top * 'aft) instr
|
('top * 'bef, 'top * 'aft) instr
|
||||||
| Exec :
|
| Exec :
|
||||||
('arg * (('arg, 'ret) lambda * 'rest), 'ret * 'rest) instr
|
('arg * (('arg, 'ret) lambda * 'rest), 'ret * 'rest) instr
|
||||||
|
| Apply : 'arg ty ->
|
||||||
|
('arg * (('arg * 'remaining, 'ret) lambda * 'rest), ('remaining, 'ret) lambda * 'rest) instr
|
||||||
| Lambda : ('arg, 'ret) lambda ->
|
| Lambda : ('arg, 'ret) lambda ->
|
||||||
('rest, ('arg, 'ret) lambda * 'rest) instr
|
('rest, ('arg, 'ret) lambda * 'rest) instr
|
||||||
| Failwith :
|
| Failwith :
|
||||||
@ -345,24 +368,25 @@ and ('bef, 'aft) instr =
|
|||||||
(z num * 'rest, bool * 'rest) instr
|
(z num * 'rest, bool * 'rest) instr
|
||||||
| Ge :
|
| Ge :
|
||||||
(z num * 'rest, bool * 'rest) instr
|
(z num * 'rest, bool * 'rest) instr
|
||||||
|
|
||||||
(* protocol *)
|
(* protocol *)
|
||||||
| Address :
|
| Address :
|
||||||
(_ typed_contract * 'rest, Contract.t * 'rest) instr
|
(_ typed_contract * 'rest, address * 'rest) instr
|
||||||
| Contract : 'p ty ->
|
| Contract : 'p ty * string ->
|
||||||
(Contract.t * 'rest, 'p typed_contract option * 'rest) instr
|
(address * 'rest, 'p typed_contract option * 'rest) instr
|
||||||
| Transfer_tokens :
|
| Transfer_tokens :
|
||||||
('arg * (Tez.t * ('arg typed_contract * 'rest)), packed_internal_operation * 'rest) instr
|
('arg * (Tez.t * ('arg typed_contract * 'rest)), operation * 'rest) instr
|
||||||
| Create_account :
|
| Create_account :
|
||||||
(public_key_hash * (public_key_hash option * (bool * (Tez.t * 'rest))),
|
(public_key_hash * (public_key_hash option * (bool * (Tez.t * 'rest))),
|
||||||
packed_internal_operation * (Contract.t * 'rest)) instr
|
operation * (address * 'rest)) instr
|
||||||
| Implicit_account :
|
| Implicit_account :
|
||||||
(public_key_hash * 'rest, unit typed_contract * 'rest) instr
|
(public_key_hash * 'rest, unit typed_contract * 'rest) instr
|
||||||
| Create_contract : 'g ty * 'p ty * ('p * 'g, packed_internal_operation list * 'g) lambda ->
|
| Create_contract : 'g ty * 'p ty * ('p * 'g, operation list * 'g) lambda * string option ->
|
||||||
(public_key_hash * (public_key_hash option * (bool * (bool * (Tez.t * ('g * 'rest))))),
|
(public_key_hash * (public_key_hash option * (bool * (bool * (Tez.t * ('g * 'rest))))),
|
||||||
packed_internal_operation * (Contract.t * 'rest)) instr
|
operation * (address * 'rest)) instr
|
||||||
|
| Create_contract_2 : 'g ty * 'p ty * ('p * 'g, operation list * 'g) lambda * string option ->
|
||||||
|
(public_key_hash option * (Tez.t * ('g * 'rest)), operation * (address * 'rest)) instr
|
||||||
| Set_delegate :
|
| Set_delegate :
|
||||||
(public_key_hash option * 'rest, packed_internal_operation * 'rest) instr
|
(public_key_hash option * 'rest, operation * 'rest) instr
|
||||||
| Now :
|
| Now :
|
||||||
('rest, Script_timestamp.t * 'rest) instr
|
('rest, Script_timestamp.t * 'rest) instr
|
||||||
| Balance :
|
| Balance :
|
||||||
@ -384,13 +408,35 @@ and ('bef, 'aft) instr =
|
|||||||
| Steps_to_quota : (* TODO: check that it always returns a nat *)
|
| Steps_to_quota : (* TODO: check that it always returns a nat *)
|
||||||
('rest, n num * 'rest) instr
|
('rest, n num * 'rest) instr
|
||||||
| Source :
|
| Source :
|
||||||
('rest, Contract.t * 'rest) instr
|
('rest, address * 'rest) instr
|
||||||
| Sender :
|
| Sender :
|
||||||
('rest, Contract.t * 'rest) instr
|
('rest, address * 'rest) instr
|
||||||
| Self : 'p ty ->
|
| Self : 'p ty * string ->
|
||||||
('rest, 'p typed_contract * 'rest) instr
|
('rest, 'p typed_contract * 'rest) instr
|
||||||
| Amount :
|
| Amount :
|
||||||
('rest, Tez.t * 'rest) instr
|
('rest, Tez.t * 'rest) instr
|
||||||
|
| Dig : int * ('x * 'rest, 'rest, 'bef, 'aft) stack_prefix_preservation_witness ->
|
||||||
|
('bef, 'x * 'aft) instr
|
||||||
|
| Dug : int * ('rest, 'x * 'rest, 'bef, 'aft) stack_prefix_preservation_witness ->
|
||||||
|
('x * 'bef, 'aft) instr
|
||||||
|
| Dipn : int * ('fbef, 'faft, 'bef, 'aft) stack_prefix_preservation_witness * ('fbef, 'faft) descr ->
|
||||||
|
('bef, 'aft) instr
|
||||||
|
| Dropn : int * ('rest, 'rest, 'bef, _) stack_prefix_preservation_witness ->
|
||||||
|
('bef, 'rest) instr
|
||||||
|
| ChainId :
|
||||||
|
('rest, Chain_id.t * 'rest) instr
|
||||||
|
|
||||||
|
(* Type witness for operations that work deep in the stack ignoring
|
||||||
|
(and preserving) a prefix.
|
||||||
|
|
||||||
|
The two right parameters are the shape of the stack with the (same)
|
||||||
|
prefix before and after the transformation. The two left
|
||||||
|
parameters are the shape of the stack without the prefix before and
|
||||||
|
after. The inductive definition makes it so by construction. *)
|
||||||
|
and ('bef, 'aft, 'bef_suffix, 'aft_suffix) stack_prefix_preservation_witness =
|
||||||
|
| Prefix : ('fbef, 'faft, 'bef, 'aft) stack_prefix_preservation_witness
|
||||||
|
-> ('fbef, 'faft, 'x * 'bef, 'x * 'aft) stack_prefix_preservation_witness
|
||||||
|
| Rest : ('bef, 'aft, 'bef, 'aft) stack_prefix_preservation_witness
|
||||||
|
|
||||||
and ('bef, 'aft) descr =
|
and ('bef, 'aft) descr =
|
||||||
{ loc : Script.location ;
|
{ loc : Script.location ;
|
||||||
|
@ -33,7 +33,7 @@
|
|||||||
seed such that the generated sequence is a given one. *)
|
seed such that the generated sequence is a given one. *)
|
||||||
|
|
||||||
|
|
||||||
(** {2 Random Generation} ****************************************************)
|
(** {2 Random Generation} *)
|
||||||
|
|
||||||
(** The state of the random number generator *)
|
(** The state of the random number generator *)
|
||||||
type t
|
type t
|
||||||
@ -56,7 +56,7 @@ val take : sequence -> MBytes.t * sequence
|
|||||||
(** Generates the next random value as a bounded [int32] *)
|
(** Generates the next random value as a bounded [int32] *)
|
||||||
val take_int32 : sequence -> int32 -> int32 * sequence
|
val take_int32 : sequence -> int32 -> int32 * sequence
|
||||||
|
|
||||||
(** {2 Predefined seeds} *****************************************************)
|
(** {2 Predefined seeds} *)
|
||||||
|
|
||||||
val empty : seed
|
val empty : seed
|
||||||
|
|
||||||
@ -68,7 +68,7 @@ val deterministic_seed : seed -> seed
|
|||||||
concatenated with a constant. *)
|
concatenated with a constant. *)
|
||||||
val initial_seeds : int -> seed list
|
val initial_seeds : int -> seed list
|
||||||
|
|
||||||
(** {2 Entropy} **************************************************************)
|
(** {2 Entropy} *)
|
||||||
|
|
||||||
(** A nonce for adding entropy to the generator *)
|
(** A nonce for adding entropy to the generator *)
|
||||||
type nonce
|
type nonce
|
||||||
@ -88,12 +88,12 @@ val check_hash : nonce -> Nonce_hash.t -> bool
|
|||||||
(** For using nonce hashes as keys in the hierarchical database *)
|
(** For using nonce hashes as keys in the hierarchical database *)
|
||||||
val nonce_hash_key_part : Nonce_hash.t -> string list -> string list
|
val nonce_hash_key_part : Nonce_hash.t -> string list -> string list
|
||||||
|
|
||||||
(** {2 Predefined nonce} *****************************************************)
|
(** {2 Predefined nonce} *)
|
||||||
|
|
||||||
val initial_nonce_0 : nonce
|
val initial_nonce_0 : nonce
|
||||||
val initial_nonce_hash_0 : Nonce_hash.t
|
val initial_nonce_hash_0 : Nonce_hash.t
|
||||||
|
|
||||||
(** {2 Serializers} **********************************************************)
|
(** {2 Serializers} *)
|
||||||
|
|
||||||
val nonce_encoding : nonce Data_encoding.t
|
val nonce_encoding : nonce Data_encoding.t
|
||||||
val seed_encoding : seed Data_encoding.t
|
val seed_encoding : seed Data_encoding.t
|
||||||
|
@ -35,7 +35,11 @@ let rpc_init ({ block_hash ; block_header ; context } : Updater.rpc_context) =
|
|||||||
let level = block_header.level in
|
let level = block_header.level in
|
||||||
let timestamp = block_header.timestamp in
|
let timestamp = block_header.timestamp in
|
||||||
let fitness = block_header.fitness in
|
let fitness = block_header.fitness in
|
||||||
Alpha_context.prepare ~level ~timestamp ~fitness context >>=? fun context ->
|
Alpha_context.prepare
|
||||||
|
~level
|
||||||
|
~predecessor_timestamp:timestamp
|
||||||
|
~timestamp
|
||||||
|
~fitness context >>=? fun context ->
|
||||||
return { block_hash ; block_header ; context }
|
return { block_hash ; block_header ; context }
|
||||||
|
|
||||||
let rpc_services = ref (RPC_directory.empty : Updater.rpc_context RPC_directory.t)
|
let rpc_services = ref (RPC_directory.empty : Updater.rpc_context RPC_directory.t)
|
||||||
|
264
vendors/ligo-utils/tezos-protocol-alpha/storage.ml
vendored
264
vendors/ligo-utils/tezos-protocol-alpha/storage.ml
vendored
@ -36,7 +36,7 @@ module Int32 = struct
|
|||||||
end
|
end
|
||||||
|
|
||||||
module Z = struct
|
module Z = struct
|
||||||
type t = Z.t
|
include Z
|
||||||
let encoding = Data_encoding.z
|
let encoding = Data_encoding.z
|
||||||
end
|
end
|
||||||
|
|
||||||
@ -66,8 +66,15 @@ module Make_index(H : Storage_description.INDEX)
|
|||||||
}
|
}
|
||||||
end
|
end
|
||||||
|
|
||||||
|
module Block_priority =
|
||||||
|
Make_single_data_storage(Registered)
|
||||||
|
(Raw_context)
|
||||||
|
(struct let name = ["block_priority"] end)
|
||||||
|
(Int)
|
||||||
|
|
||||||
|
(* Only for migration from 004 *)
|
||||||
module Last_block_priority =
|
module Last_block_priority =
|
||||||
Make_single_data_storage
|
Make_single_data_storage(Ghost)
|
||||||
(Raw_context)
|
(Raw_context)
|
||||||
(struct let name = ["last_block_priority"] end)
|
(struct let name = ["last_block_priority"] end)
|
||||||
(Int)
|
(Int)
|
||||||
@ -77,17 +84,17 @@ module Last_block_priority =
|
|||||||
module Contract = struct
|
module Contract = struct
|
||||||
|
|
||||||
module Raw_context =
|
module Raw_context =
|
||||||
Make_subcontext(Raw_context)(struct let name = ["contracts"] end)
|
Make_subcontext(Registered)(Raw_context)(struct let name = ["contracts"] end)
|
||||||
|
|
||||||
module Global_counter =
|
module Global_counter =
|
||||||
Make_single_data_storage
|
Make_single_data_storage(Registered)
|
||||||
(Raw_context)
|
(Raw_context)
|
||||||
(struct let name = ["global_counter"] end)
|
(struct let name = ["global_counter"] end)
|
||||||
(Z)
|
(Z)
|
||||||
|
|
||||||
module Indexed_context =
|
module Indexed_context =
|
||||||
Make_indexed_subcontext
|
Make_indexed_subcontext
|
||||||
(Make_subcontext(Raw_context)(struct let name = ["index"] end))
|
(Make_subcontext(Registered)(Raw_context)(struct let name = ["index"] end))
|
||||||
(Make_index(Contract_repr.Index))
|
(Make_index(Contract_repr.Index))
|
||||||
|
|
||||||
let fold = Indexed_context.fold_keys
|
let fold = Indexed_context.fold_keys
|
||||||
@ -100,7 +107,7 @@ module Contract = struct
|
|||||||
|
|
||||||
module Frozen_balance_index =
|
module Frozen_balance_index =
|
||||||
Make_indexed_subcontext
|
Make_indexed_subcontext
|
||||||
(Make_subcontext
|
(Make_subcontext(Registered)
|
||||||
(Indexed_context.Raw_context)
|
(Indexed_context.Raw_context)
|
||||||
(struct let name = ["frozen_balance"] end))
|
(struct let name = ["frozen_balance"] end))
|
||||||
(Make_index(Cycle_repr.Index))
|
(Make_index(Cycle_repr.Index))
|
||||||
@ -125,12 +132,12 @@ module Contract = struct
|
|||||||
(struct let name = ["manager"] end)
|
(struct let name = ["manager"] end)
|
||||||
(Manager_repr)
|
(Manager_repr)
|
||||||
|
|
||||||
module Spendable =
|
module Spendable_004 =
|
||||||
Indexed_context.Make_set
|
Indexed_context.Make_set(Ghost)
|
||||||
(struct let name = ["spendable"] end)
|
(struct let name = ["spendable"] end)
|
||||||
|
|
||||||
module Delegatable =
|
module Delegatable_004 =
|
||||||
Indexed_context.Make_set
|
Indexed_context.Make_set(Ghost)
|
||||||
(struct let name = ["delegatable"] end)
|
(struct let name = ["delegatable"] end)
|
||||||
|
|
||||||
module Delegate =
|
module Delegate =
|
||||||
@ -139,7 +146,7 @@ module Contract = struct
|
|||||||
(Signature.Public_key_hash)
|
(Signature.Public_key_hash)
|
||||||
|
|
||||||
module Inactive_delegate =
|
module Inactive_delegate =
|
||||||
Indexed_context.Make_set
|
Indexed_context.Make_set(Registered)
|
||||||
(struct let name = ["inactive_delegate"] end)
|
(struct let name = ["inactive_delegate"] end)
|
||||||
|
|
||||||
module Delegate_desactivation =
|
module Delegate_desactivation =
|
||||||
@ -149,9 +156,17 @@ module Contract = struct
|
|||||||
|
|
||||||
module Delegated =
|
module Delegated =
|
||||||
Make_data_set_storage
|
Make_data_set_storage
|
||||||
(Make_subcontext
|
(Make_subcontext(Registered)
|
||||||
(Indexed_context.Raw_context)
|
(Indexed_context.Raw_context)
|
||||||
(struct let name = ["delegated"] end))
|
(struct let name = ["delegated"] end))
|
||||||
|
(Make_index(Contract_repr.Index))
|
||||||
|
|
||||||
|
(** Only for migration from proto_004 *)
|
||||||
|
module Delegated_004 =
|
||||||
|
Make_data_set_storage
|
||||||
|
(Make_subcontext(Ghost)
|
||||||
|
(Indexed_context.Raw_context)
|
||||||
|
(struct let name = ["delegated_004"] end))
|
||||||
(Make_index(Contract_hash))
|
(Make_index(Contract_hash))
|
||||||
|
|
||||||
module Counter =
|
module Counter =
|
||||||
@ -219,6 +234,14 @@ module Contract = struct
|
|||||||
let init_set ctxt contract value =
|
let init_set ctxt contract value =
|
||||||
consume_serialize_gas ctxt value >>=? fun ctxt ->
|
consume_serialize_gas ctxt value >>=? fun ctxt ->
|
||||||
I.init_set ctxt contract value
|
I.init_set ctxt contract value
|
||||||
|
|
||||||
|
(** Only for used for 005 migration to avoid gas cost. *)
|
||||||
|
let init_free ctxt contract value =
|
||||||
|
I.init_free ctxt contract value
|
||||||
|
|
||||||
|
(** Only for used for 005 migration to avoid gas cost. *)
|
||||||
|
let set_free ctxt contract value =
|
||||||
|
I.set_free ctxt contract value
|
||||||
end
|
end
|
||||||
|
|
||||||
module Code =
|
module Code =
|
||||||
@ -229,15 +252,146 @@ module Contract = struct
|
|||||||
Make_carbonated_map_expr
|
Make_carbonated_map_expr
|
||||||
(struct let name = ["storage"] end)
|
(struct let name = ["storage"] end)
|
||||||
|
|
||||||
type bigmap_key = Raw_context.t * Contract_repr.t
|
module Paid_storage_space =
|
||||||
|
Indexed_context.Make_map
|
||||||
|
(struct let name = ["paid_bytes"] end)
|
||||||
|
(Z)
|
||||||
|
|
||||||
|
module Used_storage_space =
|
||||||
|
Indexed_context.Make_map
|
||||||
|
(struct let name = ["used_bytes"] end)
|
||||||
|
(Z)
|
||||||
|
|
||||||
|
module Roll_list =
|
||||||
|
Indexed_context.Make_map
|
||||||
|
(struct let name = ["roll_list"] end)
|
||||||
|
(Roll_repr)
|
||||||
|
|
||||||
|
module Change =
|
||||||
|
Indexed_context.Make_map
|
||||||
|
(struct let name = ["change"] end)
|
||||||
|
(Tez_repr)
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
(** Big maps handling *)
|
||||||
|
|
||||||
|
module Big_map = struct
|
||||||
|
module Raw_context =
|
||||||
|
Make_subcontext(Registered)(Raw_context)(struct let name = ["big_maps"] end)
|
||||||
|
|
||||||
|
module Next = struct
|
||||||
|
include
|
||||||
|
Make_single_data_storage(Registered)
|
||||||
|
(Raw_context)
|
||||||
|
(struct let name = ["next"] end)
|
||||||
|
(Z)
|
||||||
|
let incr ctxt =
|
||||||
|
get ctxt >>=? fun i ->
|
||||||
|
set ctxt (Z.succ i) >>=? fun ctxt ->
|
||||||
|
return (ctxt, i)
|
||||||
|
let init ctxt = init ctxt Z.zero
|
||||||
|
end
|
||||||
|
|
||||||
|
module Index = struct
|
||||||
|
type t = Z.t
|
||||||
|
|
||||||
|
let rpc_arg =
|
||||||
|
let construct = Z.to_string in
|
||||||
|
let destruct hash =
|
||||||
|
match Z.of_string hash with
|
||||||
|
| exception _ -> Error "Cannot parse big map id"
|
||||||
|
| id -> Ok id in
|
||||||
|
RPC_arg.make
|
||||||
|
~descr: "A big map identifier"
|
||||||
|
~name: "big_map_id"
|
||||||
|
~construct
|
||||||
|
~destruct
|
||||||
|
()
|
||||||
|
|
||||||
|
let encoding =
|
||||||
|
Data_encoding.def "big_map_id"
|
||||||
|
~title:"Big map identifier"
|
||||||
|
~description: "A big map identifier"
|
||||||
|
Z.encoding
|
||||||
|
let compare = Compare.Z.compare
|
||||||
|
|
||||||
|
let path_length = 7
|
||||||
|
|
||||||
|
let to_path c l =
|
||||||
|
let raw_key = Data_encoding.Binary.to_bytes_exn encoding c in
|
||||||
|
let `Hex index_key = MBytes.to_hex (Raw_hashes.blake2b raw_key) in
|
||||||
|
String.sub index_key 0 2 ::
|
||||||
|
String.sub index_key 2 2 ::
|
||||||
|
String.sub index_key 4 2 ::
|
||||||
|
String.sub index_key 6 2 ::
|
||||||
|
String.sub index_key 8 2 ::
|
||||||
|
String.sub index_key 10 2 ::
|
||||||
|
Z.to_string c ::
|
||||||
|
l
|
||||||
|
|
||||||
|
let of_path = function
|
||||||
|
| [] | [_] | [_;_] | [_;_;_] | [_;_;_;_] | [_;_;_;_;_] | [_;_;_;_;_;_]
|
||||||
|
| _::_::_::_::_::_::_::_::_ ->
|
||||||
|
None
|
||||||
|
| [ index1 ; index2 ; index3 ; index4 ; index5 ; index6 ; key ] ->
|
||||||
|
let c = Z.of_string key in
|
||||||
|
let raw_key = Data_encoding.Binary.to_bytes_exn encoding c in
|
||||||
|
let `Hex index_key = MBytes.to_hex (Raw_hashes.blake2b raw_key) in
|
||||||
|
assert Compare.String.(String.sub index_key 0 2 = index1) ;
|
||||||
|
assert Compare.String.(String.sub index_key 2 2 = index2) ;
|
||||||
|
assert Compare.String.(String.sub index_key 4 2 = index3) ;
|
||||||
|
assert Compare.String.(String.sub index_key 6 2 = index4) ;
|
||||||
|
assert Compare.String.(String.sub index_key 8 2 = index5) ;
|
||||||
|
assert Compare.String.(String.sub index_key 10 2 = index6) ;
|
||||||
|
Some c
|
||||||
|
end
|
||||||
|
|
||||||
|
module Indexed_context =
|
||||||
|
Make_indexed_subcontext
|
||||||
|
(Make_subcontext(Registered)(Raw_context)(struct let name = ["index"] end))
|
||||||
|
(Make_index(Index))
|
||||||
|
|
||||||
|
let rpc_arg = Index.rpc_arg
|
||||||
|
|
||||||
|
let fold = Indexed_context.fold_keys
|
||||||
|
let list = Indexed_context.keys
|
||||||
|
|
||||||
|
let remove_rec ctxt n =
|
||||||
|
Indexed_context.remove_rec ctxt n
|
||||||
|
|
||||||
|
let copy ctxt ~from ~to_ =
|
||||||
|
Indexed_context.copy ctxt ~from ~to_
|
||||||
|
|
||||||
|
type key = Raw_context.t * Z.t
|
||||||
|
|
||||||
|
module Total_bytes =
|
||||||
|
Indexed_context.Make_map
|
||||||
|
(struct let name = ["total_bytes"] end)
|
||||||
|
(Z)
|
||||||
|
|
||||||
|
module Key_type =
|
||||||
|
Indexed_context.Make_map
|
||||||
|
(struct let name = ["key_type"] end)
|
||||||
|
(struct
|
||||||
|
type t = Script_repr.expr
|
||||||
|
let encoding = Script_repr.expr_encoding
|
||||||
|
end)
|
||||||
|
|
||||||
|
module Value_type =
|
||||||
|
Indexed_context.Make_map
|
||||||
|
(struct let name = ["value_type"] end)
|
||||||
|
(struct
|
||||||
|
type t = Script_repr.expr
|
||||||
|
let encoding = Script_repr.expr_encoding
|
||||||
|
end)
|
||||||
|
|
||||||
|
module Contents = struct
|
||||||
|
|
||||||
(* Consume gas for serilization and deserialization of expr in this
|
|
||||||
module *)
|
|
||||||
module Big_map = struct
|
|
||||||
module I = Storage_functors.Make_indexed_carbonated_data_storage
|
module I = Storage_functors.Make_indexed_carbonated_data_storage
|
||||||
(Make_subcontext
|
(Make_subcontext(Registered)
|
||||||
(Indexed_context.Raw_context)
|
(Indexed_context.Raw_context)
|
||||||
(struct let name = ["big_map"] end))
|
(struct let name = ["contents"] end))
|
||||||
(Make_index(Script_expr_hash))
|
(Make_index(Script_expr_hash))
|
||||||
(struct
|
(struct
|
||||||
type t = Script_repr.expr
|
type t = Script_repr.expr
|
||||||
@ -274,41 +428,21 @@ module Contract = struct
|
|||||||
(ctxt, value_opt)
|
(ctxt, value_opt)
|
||||||
end
|
end
|
||||||
|
|
||||||
module Paid_storage_space =
|
|
||||||
Indexed_context.Make_map
|
|
||||||
(struct let name = ["paid_bytes"] end)
|
|
||||||
(Z)
|
|
||||||
|
|
||||||
module Used_storage_space =
|
|
||||||
Indexed_context.Make_map
|
|
||||||
(struct let name = ["used_bytes"] end)
|
|
||||||
(Z)
|
|
||||||
|
|
||||||
module Roll_list =
|
|
||||||
Indexed_context.Make_map
|
|
||||||
(struct let name = ["roll_list"] end)
|
|
||||||
(Roll_repr)
|
|
||||||
|
|
||||||
module Change =
|
|
||||||
Indexed_context.Make_map
|
|
||||||
(struct let name = ["change"] end)
|
|
||||||
(Tez_repr)
|
|
||||||
|
|
||||||
end
|
end
|
||||||
|
|
||||||
module Delegates =
|
module Delegates =
|
||||||
Make_data_set_storage
|
Make_data_set_storage
|
||||||
(Make_subcontext(Raw_context)(struct let name = ["delegates"] end))
|
(Make_subcontext(Registered)(Raw_context)(struct let name = ["delegates"] end))
|
||||||
(Make_index(Signature.Public_key_hash))
|
(Make_index(Signature.Public_key_hash))
|
||||||
|
|
||||||
module Active_delegates_with_rolls =
|
module Active_delegates_with_rolls =
|
||||||
Make_data_set_storage
|
Make_data_set_storage
|
||||||
(Make_subcontext(Raw_context)(struct let name = ["active_delegates_with_rolls"] end))
|
(Make_subcontext(Registered)(Raw_context)(struct let name = ["active_delegates_with_rolls"] end))
|
||||||
(Make_index(Signature.Public_key_hash))
|
(Make_index(Signature.Public_key_hash))
|
||||||
|
|
||||||
module Delegates_with_frozen_balance_index =
|
module Delegates_with_frozen_balance_index =
|
||||||
Make_indexed_subcontext
|
Make_indexed_subcontext
|
||||||
(Make_subcontext(Raw_context)
|
(Make_subcontext(Registered)(Raw_context)
|
||||||
(struct let name = ["delegates_with_frozen_balance"] end))
|
(struct let name = ["delegates_with_frozen_balance"] end))
|
||||||
(Make_index(Cycle_repr.Index))
|
(Make_index(Cycle_repr.Index))
|
||||||
|
|
||||||
@ -323,12 +457,12 @@ module Cycle = struct
|
|||||||
|
|
||||||
module Indexed_context =
|
module Indexed_context =
|
||||||
Make_indexed_subcontext
|
Make_indexed_subcontext
|
||||||
(Make_subcontext(Raw_context)(struct let name = ["cycle"] end))
|
(Make_subcontext(Registered)(Raw_context)(struct let name = ["cycle"] end))
|
||||||
(Make_index(Cycle_repr.Index))
|
(Make_index(Cycle_repr.Index))
|
||||||
|
|
||||||
module Last_roll =
|
module Last_roll =
|
||||||
Make_indexed_data_storage
|
Make_indexed_data_storage
|
||||||
(Make_subcontext
|
(Make_subcontext(Registered)
|
||||||
(Indexed_context.Raw_context)
|
(Indexed_context.Raw_context)
|
||||||
(struct let name = ["last_roll"] end))
|
(struct let name = ["last_roll"] end))
|
||||||
(Int_index)
|
(Int_index)
|
||||||
@ -377,7 +511,7 @@ module Cycle = struct
|
|||||||
|
|
||||||
module Nonce =
|
module Nonce =
|
||||||
Make_indexed_data_storage
|
Make_indexed_data_storage
|
||||||
(Make_subcontext
|
(Make_subcontext(Registered)
|
||||||
(Indexed_context.Raw_context)
|
(Indexed_context.Raw_context)
|
||||||
(struct let name = ["nonces"] end))
|
(struct let name = ["nonces"] end))
|
||||||
(Make_index(Raw_level_repr.Index))
|
(Make_index(Raw_level_repr.Index))
|
||||||
@ -399,21 +533,21 @@ end
|
|||||||
module Roll = struct
|
module Roll = struct
|
||||||
|
|
||||||
module Raw_context =
|
module Raw_context =
|
||||||
Make_subcontext(Raw_context)(struct let name = ["rolls"] end)
|
Make_subcontext(Registered)(Raw_context)(struct let name = ["rolls"] end)
|
||||||
|
|
||||||
module Indexed_context =
|
module Indexed_context =
|
||||||
Make_indexed_subcontext
|
Make_indexed_subcontext
|
||||||
(Make_subcontext(Raw_context)(struct let name = ["index"] end))
|
(Make_subcontext(Registered)(Raw_context)(struct let name = ["index"] end))
|
||||||
(Make_index(Roll_repr.Index))
|
(Make_index(Roll_repr.Index))
|
||||||
|
|
||||||
module Next =
|
module Next =
|
||||||
Make_single_data_storage
|
Make_single_data_storage(Registered)
|
||||||
(Raw_context)
|
(Raw_context)
|
||||||
(struct let name = ["next"] end)
|
(struct let name = ["next"] end)
|
||||||
(Roll_repr)
|
(Roll_repr)
|
||||||
|
|
||||||
module Limbo =
|
module Limbo =
|
||||||
Make_single_data_storage
|
Make_single_data_storage(Registered)
|
||||||
(Raw_context)
|
(Raw_context)
|
||||||
(struct let name = ["limbo"] end)
|
(struct let name = ["limbo"] end)
|
||||||
(Roll_repr)
|
(Roll_repr)
|
||||||
@ -469,7 +603,7 @@ module Roll = struct
|
|||||||
|
|
||||||
module Owner =
|
module Owner =
|
||||||
Make_indexed_data_snapshotable_storage
|
Make_indexed_data_snapshotable_storage
|
||||||
(Make_subcontext(Raw_context)(struct let name = ["owner"] end))
|
(Make_subcontext(Registered)(Raw_context)(struct let name = ["owner"] end))
|
||||||
(Snapshoted_owner_index)
|
(Snapshoted_owner_index)
|
||||||
(Make_index(Roll_repr.Index))
|
(Make_index(Roll_repr.Index))
|
||||||
(Signature.Public_key)
|
(Signature.Public_key)
|
||||||
@ -486,10 +620,10 @@ end
|
|||||||
module Vote = struct
|
module Vote = struct
|
||||||
|
|
||||||
module Raw_context =
|
module Raw_context =
|
||||||
Make_subcontext(Raw_context)(struct let name = ["votes"] end)
|
Make_subcontext(Registered)(Raw_context)(struct let name = ["votes"] end)
|
||||||
|
|
||||||
module Current_period_kind =
|
module Current_period_kind =
|
||||||
Make_single_data_storage
|
Make_single_data_storage(Registered)
|
||||||
(Raw_context)
|
(Raw_context)
|
||||||
(struct let name = ["current_period_kind"] end)
|
(struct let name = ["current_period_kind"] end)
|
||||||
(struct
|
(struct
|
||||||
@ -497,45 +631,51 @@ module Vote = struct
|
|||||||
let encoding = Voting_period_repr.kind_encoding
|
let encoding = Voting_period_repr.kind_encoding
|
||||||
end)
|
end)
|
||||||
|
|
||||||
module Current_quorum =
|
module Current_quorum_004 =
|
||||||
Make_single_data_storage
|
Make_single_data_storage(Ghost)
|
||||||
(Raw_context)
|
(Raw_context)
|
||||||
(struct let name = ["current_quorum"] end)
|
(struct let name = ["current_quorum"] end)
|
||||||
(Int32)
|
(Int32)
|
||||||
|
|
||||||
|
module Participation_ema =
|
||||||
|
Make_single_data_storage(Registered)
|
||||||
|
(Raw_context)
|
||||||
|
(struct let name = ["participation_ema"] end)
|
||||||
|
(Int32)
|
||||||
|
|
||||||
module Current_proposal =
|
module Current_proposal =
|
||||||
Make_single_data_storage
|
Make_single_data_storage(Registered)
|
||||||
(Raw_context)
|
(Raw_context)
|
||||||
(struct let name = ["current_proposal"] end)
|
(struct let name = ["current_proposal"] end)
|
||||||
(Protocol_hash)
|
(Protocol_hash)
|
||||||
|
|
||||||
module Listings_size =
|
module Listings_size =
|
||||||
Make_single_data_storage
|
Make_single_data_storage(Registered)
|
||||||
(Raw_context)
|
(Raw_context)
|
||||||
(struct let name = ["listings_size"] end)
|
(struct let name = ["listings_size"] end)
|
||||||
(Int32)
|
(Int32)
|
||||||
|
|
||||||
module Listings =
|
module Listings =
|
||||||
Make_indexed_data_storage
|
Make_indexed_data_storage
|
||||||
(Make_subcontext(Raw_context)(struct let name = ["listings"] end))
|
(Make_subcontext(Registered)(Raw_context)(struct let name = ["listings"] end))
|
||||||
(Make_index(Signature.Public_key_hash))
|
(Make_index(Signature.Public_key_hash))
|
||||||
(Int32)
|
(Int32)
|
||||||
|
|
||||||
module Proposals =
|
module Proposals =
|
||||||
Make_data_set_storage
|
Make_data_set_storage
|
||||||
(Make_subcontext(Raw_context)(struct let name = ["proposals"] end))
|
(Make_subcontext(Registered)(Raw_context)(struct let name = ["proposals"] end))
|
||||||
(Pair(Make_index(Protocol_hash))(Make_index(Signature.Public_key_hash)))
|
(Pair(Make_index(Protocol_hash))(Make_index(Signature.Public_key_hash)))
|
||||||
|
|
||||||
module Proposals_count =
|
module Proposals_count =
|
||||||
Make_indexed_data_storage
|
Make_indexed_data_storage
|
||||||
(Make_subcontext(Raw_context)
|
(Make_subcontext(Registered)(Raw_context)
|
||||||
(struct let name = ["proposals_count"] end))
|
(struct let name = ["proposals_count"] end))
|
||||||
(Make_index(Signature.Public_key_hash))
|
(Make_index(Signature.Public_key_hash))
|
||||||
(Int)
|
(Int)
|
||||||
|
|
||||||
module Ballots =
|
module Ballots =
|
||||||
Make_indexed_data_storage
|
Make_indexed_data_storage
|
||||||
(Make_subcontext(Raw_context)(struct let name = ["ballots"] end))
|
(Make_subcontext(Registered)(Raw_context)(struct let name = ["ballots"] end))
|
||||||
(Make_index(Signature.Public_key_hash))
|
(Make_index(Signature.Public_key_hash))
|
||||||
(struct
|
(struct
|
||||||
type t = Vote_repr.ballot
|
type t = Vote_repr.ballot
|
||||||
@ -580,7 +720,7 @@ end
|
|||||||
|
|
||||||
module Commitments =
|
module Commitments =
|
||||||
Make_indexed_data_storage
|
Make_indexed_data_storage
|
||||||
(Make_subcontext(Raw_context)(struct let name = ["commitments"] end))
|
(Make_subcontext(Registered)(Raw_context)(struct let name = ["commitments"] end))
|
||||||
(Make_index(Blinded_public_key_hash.Index))
|
(Make_index(Blinded_public_key_hash.Index))
|
||||||
(Tez_repr)
|
(Tez_repr)
|
||||||
|
|
||||||
@ -590,7 +730,7 @@ module Ramp_up = struct
|
|||||||
|
|
||||||
module Rewards =
|
module Rewards =
|
||||||
Make_indexed_data_storage
|
Make_indexed_data_storage
|
||||||
(Make_subcontext(Raw_context)(struct let name = ["ramp_up"; "rewards"] end))
|
(Make_subcontext(Registered)(Raw_context)(struct let name = ["ramp_up"; "rewards"] end))
|
||||||
(Make_index(Cycle_repr.Index))
|
(Make_index(Cycle_repr.Index))
|
||||||
(struct
|
(struct
|
||||||
type t = Tez_repr.t * Tez_repr.t
|
type t = Tez_repr.t * Tez_repr.t
|
||||||
@ -599,7 +739,7 @@ module Ramp_up = struct
|
|||||||
|
|
||||||
module Security_deposits =
|
module Security_deposits =
|
||||||
Make_indexed_data_storage
|
Make_indexed_data_storage
|
||||||
(Make_subcontext(Raw_context)(struct let name = ["ramp_up"; "deposits"] end))
|
(Make_subcontext(Registered)(Raw_context)(struct let name = ["ramp_up"; "deposits"] end))
|
||||||
(Make_index(Cycle_repr.Index))
|
(Make_index(Cycle_repr.Index))
|
||||||
(struct
|
(struct
|
||||||
type t = Tez_repr.t * Tez_repr.t
|
type t = Tez_repr.t * Tez_repr.t
|
||||||
|
@ -36,12 +36,17 @@
|
|||||||
|
|
||||||
open Storage_sigs
|
open Storage_sigs
|
||||||
|
|
||||||
module Last_block_priority : sig
|
module Block_priority : sig
|
||||||
val get : Raw_context.t -> int tzresult Lwt.t
|
val get : Raw_context.t -> int tzresult Lwt.t
|
||||||
val set : Raw_context.t -> int -> Raw_context.t tzresult Lwt.t
|
val set : Raw_context.t -> int -> Raw_context.t tzresult Lwt.t
|
||||||
val init : Raw_context.t -> int -> Raw_context.t tzresult Lwt.t
|
val init : Raw_context.t -> int -> Raw_context.t tzresult Lwt.t
|
||||||
end
|
end
|
||||||
|
|
||||||
|
(* Only for migration from 004 *)
|
||||||
|
module Last_block_priority : sig
|
||||||
|
val delete : Raw_context.t -> Raw_context.t tzresult Lwt.t
|
||||||
|
end
|
||||||
|
|
||||||
module Roll : sig
|
module Roll : sig
|
||||||
|
|
||||||
(** Storage from this submodule must only be accessed through the
|
(** Storage from this submodule must only be accessed through the
|
||||||
@ -152,7 +157,13 @@ module Contract : sig
|
|||||||
and type value = Signature.Public_key_hash.t
|
and type value = Signature.Public_key_hash.t
|
||||||
and type t := Raw_context.t
|
and type t := Raw_context.t
|
||||||
|
|
||||||
|
(** All contracts (implicit and originated) that are delegated, if any *)
|
||||||
module Delegated : Data_set_storage
|
module Delegated : Data_set_storage
|
||||||
|
with type elt = Contract_repr.t
|
||||||
|
and type t = Raw_context.t * Contract_repr.t
|
||||||
|
|
||||||
|
(** Only for migration from proto_004 *)
|
||||||
|
module Delegated_004 : Data_set_storage
|
||||||
with type elt = Contract_hash.t
|
with type elt = Contract_hash.t
|
||||||
and type t = Raw_context.t * Contract_repr.t
|
and type t = Raw_context.t * Contract_repr.t
|
||||||
|
|
||||||
@ -166,11 +177,11 @@ module Contract : sig
|
|||||||
and type value = Cycle_repr.t
|
and type value = Cycle_repr.t
|
||||||
and type t := Raw_context.t
|
and type t := Raw_context.t
|
||||||
|
|
||||||
module Spendable : Data_set_storage
|
module Spendable_004 : Data_set_storage
|
||||||
with type elt = Contract_repr.t
|
with type elt = Contract_repr.t
|
||||||
and type t := Raw_context.t
|
and type t := Raw_context.t
|
||||||
|
|
||||||
module Delegatable : Data_set_storage
|
module Delegatable_004 : Data_set_storage
|
||||||
with type elt = Contract_repr.t
|
with type elt = Contract_repr.t
|
||||||
and type t := Raw_context.t
|
and type t := Raw_context.t
|
||||||
|
|
||||||
@ -179,16 +190,40 @@ module Contract : sig
|
|||||||
and type value = Z.t
|
and type value = Z.t
|
||||||
and type t := Raw_context.t
|
and type t := Raw_context.t
|
||||||
|
|
||||||
module Code : Non_iterable_indexed_carbonated_data_storage
|
module Code : sig
|
||||||
|
include Non_iterable_indexed_carbonated_data_storage
|
||||||
with type key = Contract_repr.t
|
with type key = Contract_repr.t
|
||||||
and type value = Script_repr.lazy_expr
|
and type value = Script_repr.lazy_expr
|
||||||
and type t := Raw_context.t
|
and type t := Raw_context.t
|
||||||
|
|
||||||
module Storage : Non_iterable_indexed_carbonated_data_storage
|
(** Only used for 005 migration to avoid gas cost.
|
||||||
|
Allocates a storage bucket at the given key and initializes it ;
|
||||||
|
returns a {!Storage_error Existing_key} if the bucket exists. *)
|
||||||
|
val init_free: Raw_context.t -> Contract_repr.t -> Script_repr.lazy_expr -> (Raw_context.t * int) tzresult Lwt.t
|
||||||
|
|
||||||
|
(** Only used for 005 migration to avoid gas cost.
|
||||||
|
Updates the content of a bucket ; returns A {!Storage_Error
|
||||||
|
Missing_key} if the value does not exists. *)
|
||||||
|
val set_free: Raw_context.t -> Contract_repr.t -> Script_repr.lazy_expr -> (Raw_context.t * int) tzresult Lwt.t
|
||||||
|
end
|
||||||
|
|
||||||
|
module Storage : sig
|
||||||
|
include Non_iterable_indexed_carbonated_data_storage
|
||||||
with type key = Contract_repr.t
|
with type key = Contract_repr.t
|
||||||
and type value = Script_repr.lazy_expr
|
and type value = Script_repr.lazy_expr
|
||||||
and type t := Raw_context.t
|
and type t := Raw_context.t
|
||||||
|
|
||||||
|
(** Only used for 005 migration to avoid gas cost.
|
||||||
|
Allocates a storage bucket at the given key and initializes it ;
|
||||||
|
returns a {!Storage_error Existing_key} if the bucket exists. *)
|
||||||
|
val init_free: Raw_context.t -> Contract_repr.t -> Script_repr.lazy_expr -> (Raw_context.t * int) tzresult Lwt.t
|
||||||
|
|
||||||
|
(** Only used for 005 migration to avoid gas cost.
|
||||||
|
Updates the content of a bucket ; returns A {!Storage_Error
|
||||||
|
Missing_key} if the value does not exists. *)
|
||||||
|
val set_free: Raw_context.t -> Contract_repr.t -> Script_repr.lazy_expr -> (Raw_context.t * int) tzresult Lwt.t
|
||||||
|
end
|
||||||
|
|
||||||
(** Current storage space in bytes.
|
(** Current storage space in bytes.
|
||||||
Includes code, global storage and big map elements. *)
|
Includes code, global storage and big map elements. *)
|
||||||
module Used_storage_space : Indexed_data_storage
|
module Used_storage_space : Indexed_data_storage
|
||||||
@ -202,12 +237,50 @@ module Contract : sig
|
|||||||
and type value = Z.t
|
and type value = Z.t
|
||||||
and type t := Raw_context.t
|
and type t := Raw_context.t
|
||||||
|
|
||||||
type bigmap_key = Raw_context.t * Contract_repr.t
|
end
|
||||||
|
|
||||||
module Big_map : Non_iterable_indexed_carbonated_data_storage
|
module Big_map : sig
|
||||||
|
|
||||||
|
module Next : sig
|
||||||
|
val incr : Raw_context.t -> (Raw_context.t * Z.t) tzresult Lwt.t
|
||||||
|
val init : Raw_context.t -> Raw_context.t tzresult Lwt.t
|
||||||
|
end
|
||||||
|
|
||||||
|
(** The domain of alive big maps *)
|
||||||
|
val fold :
|
||||||
|
Raw_context.t ->
|
||||||
|
init:'a -> f:(Z.t -> 'a -> 'a Lwt.t) -> 'a Lwt.t
|
||||||
|
val list : Raw_context.t -> Z.t list Lwt.t
|
||||||
|
|
||||||
|
val remove_rec : Raw_context.t -> Z.t -> Raw_context.t Lwt.t
|
||||||
|
|
||||||
|
val copy : Raw_context.t -> from:Z.t -> to_:Z.t -> Raw_context.t tzresult Lwt.t
|
||||||
|
|
||||||
|
type key = Raw_context.t * Z.t
|
||||||
|
|
||||||
|
val rpc_arg : Z.t RPC_arg.t
|
||||||
|
|
||||||
|
module Index : Storage_description.INDEX with type t = Z.t
|
||||||
|
|
||||||
|
module Contents : Non_iterable_indexed_carbonated_data_storage
|
||||||
with type key = Script_expr_hash.t
|
with type key = Script_expr_hash.t
|
||||||
and type value = Script_repr.expr
|
and type value = Script_repr.expr
|
||||||
and type t := bigmap_key
|
and type t := key
|
||||||
|
|
||||||
|
module Total_bytes : Indexed_data_storage
|
||||||
|
with type key = Z.t
|
||||||
|
and type value = Z.t
|
||||||
|
and type t := Raw_context.t
|
||||||
|
|
||||||
|
module Key_type : Indexed_data_storage
|
||||||
|
with type key = Z.t
|
||||||
|
and type value = Script_repr.expr
|
||||||
|
and type t := Raw_context.t
|
||||||
|
|
||||||
|
module Value_type : Indexed_data_storage
|
||||||
|
with type key = Z.t
|
||||||
|
and type value = Script_repr.expr
|
||||||
|
and type t := Raw_context.t
|
||||||
|
|
||||||
end
|
end
|
||||||
|
|
||||||
@ -234,8 +307,14 @@ module Vote : sig
|
|||||||
with type value = Voting_period_repr.kind
|
with type value = Voting_period_repr.kind
|
||||||
and type t := Raw_context.t
|
and type t := Raw_context.t
|
||||||
|
|
||||||
(** Expected quorum, in centile of percentage *)
|
(** Only for migration from 004.
|
||||||
module Current_quorum : Single_data_storage
|
Expected quorum, in centile of percentage *)
|
||||||
|
module Current_quorum_004 : Single_data_storage
|
||||||
|
with type value = int32
|
||||||
|
and type t := Raw_context.t
|
||||||
|
|
||||||
|
(** Participation exponential moving average, in centile of percentage *)
|
||||||
|
module Participation_ema : Single_data_storage
|
||||||
with type value = int32
|
with type value = int32
|
||||||
and type t := Raw_context.t
|
and type t := Raw_context.t
|
||||||
|
|
||||||
|
@ -285,7 +285,7 @@ let build_directory : type key. key t -> key RPC_directory.t =
|
|||||||
else if Compare.Int.(i = 0) then return_some []
|
else if Compare.Int.(i = 0) then return_some []
|
||||||
else
|
else
|
||||||
list k >>=? fun keys ->
|
list k >>=? fun keys ->
|
||||||
map_p
|
map_s
|
||||||
(fun key ->
|
(fun key ->
|
||||||
if Compare.Int.(i = 1) then
|
if Compare.Int.(i = 1) then
|
||||||
return (key, None)
|
return (key, None)
|
||||||
|
@ -25,10 +25,13 @@
|
|||||||
|
|
||||||
open Storage_sigs
|
open Storage_sigs
|
||||||
|
|
||||||
|
module Registered = struct let ghost = false end
|
||||||
|
module Ghost = struct let ghost = true end
|
||||||
|
|
||||||
module Make_encoder (V : VALUE) = struct
|
module Make_encoder (V : VALUE) = struct
|
||||||
let of_bytes ~key b =
|
let of_bytes ~key b =
|
||||||
match Data_encoding.Binary.of_bytes V.encoding b with
|
match Data_encoding.Binary.of_bytes V.encoding b with
|
||||||
| None -> Error [Raw_context.Storage_error (Corrupted_data key)]
|
| None -> error (Raw_context.Storage_error (Corrupted_data key))
|
||||||
| Some v -> Ok v
|
| Some v -> Ok v
|
||||||
let to_bytes v =
|
let to_bytes v =
|
||||||
match Data_encoding.Binary.to_bytes V.encoding v with
|
match Data_encoding.Binary.to_bytes V.encoding v with
|
||||||
@ -54,7 +57,7 @@ let map_key f = function
|
|||||||
| `Key k -> `Key (f k)
|
| `Key k -> `Key (f k)
|
||||||
| `Dir k -> `Dir (f k)
|
| `Dir k -> `Dir (f k)
|
||||||
|
|
||||||
module Make_subcontext (C : Raw_context.T) (N : NAME)
|
module Make_subcontext (R : REGISTER) (C : Raw_context.T) (N : NAME)
|
||||||
: Raw_context.T with type t = C.t = struct
|
: Raw_context.T with type t = C.t = struct
|
||||||
type t = C.t
|
type t = C.t
|
||||||
type context = t
|
type context = t
|
||||||
@ -84,10 +87,12 @@ module Make_subcontext (C : Raw_context.T) (N : NAME)
|
|||||||
let consume_gas = C.consume_gas
|
let consume_gas = C.consume_gas
|
||||||
let check_enough_gas = C.check_enough_gas
|
let check_enough_gas = C.check_enough_gas
|
||||||
let description =
|
let description =
|
||||||
Storage_description.register_named_subcontext C.description N.name
|
let description = if R.ghost then Storage_description.create ()
|
||||||
|
else C.description in
|
||||||
|
Storage_description.register_named_subcontext description N.name
|
||||||
end
|
end
|
||||||
|
|
||||||
module Make_single_data_storage (C : Raw_context.T) (N : NAME) (V : VALUE)
|
module Make_single_data_storage (R : REGISTER) (C : Raw_context.T) (N : NAME) (V : VALUE)
|
||||||
: Single_data_storage with type t = C.t
|
: Single_data_storage with type t = C.t
|
||||||
and type value = V.t = struct
|
and type value = V.t = struct
|
||||||
type t = C.t
|
type t = C.t
|
||||||
@ -129,9 +134,11 @@ module Make_single_data_storage (C : Raw_context.T) (N : NAME) (V : VALUE)
|
|||||||
|
|
||||||
let () =
|
let () =
|
||||||
let open Storage_description in
|
let open Storage_description in
|
||||||
|
let description = if R.ghost then Storage_description.create ()
|
||||||
|
else C.description in
|
||||||
register_value
|
register_value
|
||||||
~get:get_option
|
~get:get_option
|
||||||
(register_named_subcontext C.description N.name)
|
(register_named_subcontext description N.name)
|
||||||
V.encoding
|
V.encoding
|
||||||
|
|
||||||
end
|
end
|
||||||
@ -329,76 +336,76 @@ module Make_indexed_carbonated_data_storage
|
|||||||
type key = I.t
|
type key = I.t
|
||||||
type value = V.t
|
type value = V.t
|
||||||
include Make_encoder(V)
|
include Make_encoder(V)
|
||||||
let name i =
|
let data_key i =
|
||||||
I.to_path i [data_name]
|
I.to_path i [data_name]
|
||||||
let len_name i =
|
let len_key i =
|
||||||
I.to_path i [len_name]
|
I.to_path i [len_name]
|
||||||
let consume_mem_gas c =
|
let consume_mem_gas c =
|
||||||
Lwt.return (C.consume_gas c (Gas_limit_repr.read_bytes_cost Z.zero))
|
Lwt.return (C.consume_gas c (Gas_limit_repr.read_bytes_cost Z.zero))
|
||||||
let existing_size c i =
|
let existing_size c i =
|
||||||
C.get_option c (len_name i) >>= function
|
C.get_option c (len_key i) >>= function
|
||||||
| None -> return 0
|
| None -> return (0, false)
|
||||||
| Some len -> decode_len_value (len_name i) len
|
| Some len -> decode_len_value (len_key i) len >>=? fun len -> return (len, true)
|
||||||
let consume_read_gas get c i =
|
let consume_read_gas get c i =
|
||||||
get c (len_name i) >>=? fun len ->
|
get c (len_key i) >>=? fun len ->
|
||||||
decode_len_value (len_name i) len >>=? fun len ->
|
decode_len_value (len_key i) len >>=? fun len ->
|
||||||
Lwt.return (C.consume_gas c (Gas_limit_repr.read_bytes_cost (Z.of_int len)))
|
Lwt.return (C.consume_gas c (Gas_limit_repr.read_bytes_cost (Z.of_int len)))
|
||||||
let consume_serialize_write_gas set c i v =
|
let consume_serialize_write_gas set c i v =
|
||||||
let bytes = to_bytes v in
|
let bytes = to_bytes v in
|
||||||
let len = MBytes.length bytes in
|
let len = MBytes.length bytes in
|
||||||
Lwt.return (C.consume_gas c (Gas_limit_repr.alloc_mbytes_cost len)) >>=? fun c ->
|
Lwt.return (C.consume_gas c (Gas_limit_repr.alloc_mbytes_cost len)) >>=? fun c ->
|
||||||
Lwt.return (C.consume_gas c (Gas_limit_repr.write_bytes_cost (Z.of_int len))) >>=? fun c ->
|
Lwt.return (C.consume_gas c (Gas_limit_repr.write_bytes_cost (Z.of_int len))) >>=? fun c ->
|
||||||
set c (len_name i) (encode_len_value bytes) >>=? fun c ->
|
set c (len_key i) (encode_len_value bytes) >>=? fun c ->
|
||||||
return (c, bytes)
|
return (c, bytes)
|
||||||
let consume_remove_gas del c i =
|
let consume_remove_gas del c i =
|
||||||
Lwt.return (C.consume_gas c (Gas_limit_repr.write_bytes_cost Z.zero)) >>=? fun c ->
|
Lwt.return (C.consume_gas c (Gas_limit_repr.write_bytes_cost Z.zero)) >>=? fun c ->
|
||||||
del c (len_name i)
|
del c (len_key i)
|
||||||
let mem s i =
|
let mem s i =
|
||||||
consume_mem_gas s >>=? fun s ->
|
consume_mem_gas s >>=? fun s ->
|
||||||
C.mem s (name i) >>= fun exists ->
|
C.mem s (data_key i) >>= fun exists ->
|
||||||
return (C.project s, exists)
|
return (C.project s, exists)
|
||||||
let get s i =
|
let get s i =
|
||||||
consume_read_gas C.get s i >>=? fun s ->
|
consume_read_gas C.get s i >>=? fun s ->
|
||||||
C.get s (name i) >>=? fun b ->
|
C.get s (data_key i) >>=? fun b ->
|
||||||
let key = C.absolute_key s (name i) in
|
let key = C.absolute_key s (data_key i) in
|
||||||
Lwt.return (of_bytes ~key b) >>=? fun v ->
|
Lwt.return (of_bytes ~key b) >>=? fun v ->
|
||||||
return (C.project s, v)
|
return (C.project s, v)
|
||||||
let get_option s i =
|
let get_option s i =
|
||||||
consume_mem_gas s >>=? fun s ->
|
consume_mem_gas s >>=? fun s ->
|
||||||
C.mem s (name i) >>= fun exists ->
|
C.mem s (data_key i) >>= fun exists ->
|
||||||
if exists then
|
if exists then
|
||||||
get s i >>=? fun (s, v) ->
|
get s i >>=? fun (s, v) ->
|
||||||
return (s, Some v)
|
return (s, Some v)
|
||||||
else
|
else
|
||||||
return (C.project s, None)
|
return (C.project s, None)
|
||||||
let set s i v =
|
let set s i v =
|
||||||
existing_size s i >>=? fun prev_size ->
|
existing_size s i >>=? fun (prev_size, _) ->
|
||||||
consume_serialize_write_gas C.set s i v >>=? fun (s, bytes) ->
|
consume_serialize_write_gas C.set s i v >>=? fun (s, bytes) ->
|
||||||
C.set s (name i) bytes >>=? fun t ->
|
C.set s (data_key i) bytes >>=? fun t ->
|
||||||
let size_diff = MBytes.length bytes - prev_size in
|
let size_diff = MBytes.length bytes - prev_size in
|
||||||
return (C.project t, size_diff)
|
return (C.project t, size_diff)
|
||||||
let init s i v =
|
let init s i v =
|
||||||
consume_serialize_write_gas C.init s i v >>=? fun (s, bytes) ->
|
consume_serialize_write_gas C.init s i v >>=? fun (s, bytes) ->
|
||||||
C.init s (name i) bytes >>=? fun t ->
|
C.init s (data_key i) bytes >>=? fun t ->
|
||||||
let size = MBytes.length bytes in
|
let size = MBytes.length bytes in
|
||||||
return (C.project t, size)
|
return (C.project t, size)
|
||||||
let init_set s i v =
|
let init_set s i v =
|
||||||
let init_set s i v = C.init_set s i v >>= return in
|
let init_set s i v = C.init_set s i v >>= return in
|
||||||
existing_size s i >>=? fun prev_size ->
|
existing_size s i >>=? fun (prev_size, existed) ->
|
||||||
consume_serialize_write_gas init_set s i v >>=? fun (s, bytes) ->
|
consume_serialize_write_gas init_set s i v >>=? fun (s, bytes) ->
|
||||||
init_set s (name i) bytes >>=? fun t ->
|
init_set s (data_key i) bytes >>=? fun t ->
|
||||||
let size_diff = MBytes.length bytes - prev_size in
|
let size_diff = MBytes.length bytes - prev_size in
|
||||||
return (C.project t, size_diff)
|
return (C.project t, size_diff, existed)
|
||||||
let remove s i =
|
let remove s i =
|
||||||
let remove s i = C.remove s i >>= return in
|
let remove s i = C.remove s i >>= return in
|
||||||
existing_size s i >>=? fun prev_size ->
|
existing_size s i >>=? fun (prev_size, existed) ->
|
||||||
consume_remove_gas remove s i >>=? fun s ->
|
consume_remove_gas remove s i >>=? fun s ->
|
||||||
remove s (name i) >>=? fun t ->
|
remove s (data_key i) >>=? fun t ->
|
||||||
return (C.project t, prev_size)
|
return (C.project t, prev_size, existed)
|
||||||
let delete s i =
|
let delete s i =
|
||||||
existing_size s i >>=? fun prev_size ->
|
existing_size s i >>=? fun (prev_size, _) ->
|
||||||
consume_remove_gas C.delete s i >>=? fun s ->
|
consume_remove_gas C.delete s i >>=? fun s ->
|
||||||
C.delete s (name i) >>=? fun t ->
|
C.delete s (data_key i) >>=? fun t ->
|
||||||
return (C.project t, prev_size)
|
return (C.project t, prev_size)
|
||||||
let set_option s i v =
|
let set_option s i v =
|
||||||
match v with
|
match v with
|
||||||
@ -407,22 +414,29 @@ module Make_indexed_carbonated_data_storage
|
|||||||
|
|
||||||
let fold_keys_unaccounted s ~init ~f =
|
let fold_keys_unaccounted s ~init ~f =
|
||||||
let rec dig i path acc =
|
let rec dig i path acc =
|
||||||
if Compare.Int.(i <= 1) then
|
if Compare.Int.(i <= 0) then
|
||||||
C.fold s path ~init:acc ~f:begin fun k acc ->
|
C.fold s path ~init:acc ~f:begin fun k acc ->
|
||||||
match k with
|
match k with
|
||||||
| `Dir _ -> Lwt.return acc
|
| `Dir _ -> Lwt.return acc
|
||||||
| `Key file ->
|
| `Key file ->
|
||||||
match I.of_path file with
|
match List.rev file with
|
||||||
|
| last :: _ when Compare.String.(last = len_name) ->
|
||||||
|
Lwt.return acc
|
||||||
|
| last :: rest when Compare.String.(last = data_name) ->
|
||||||
|
let file = List.rev rest in
|
||||||
|
begin match I.of_path file with
|
||||||
| None -> assert false
|
| None -> assert false
|
||||||
| Some path -> f path acc
|
| Some path -> f path acc
|
||||||
end
|
end
|
||||||
|
| _ -> assert false
|
||||||
|
end
|
||||||
else
|
else
|
||||||
C.fold s path ~init:acc ~f:begin fun k acc ->
|
C.fold s path ~init:acc ~f:begin fun k acc ->
|
||||||
match k with
|
match k with
|
||||||
| `Dir k -> dig (i-1) k acc
|
| `Dir k -> dig (i-1) k acc
|
||||||
| `Key _ -> Lwt.return acc
|
| `Key _ -> Lwt.return acc
|
||||||
end in
|
end in
|
||||||
dig I.path_length [data_name] init
|
dig I.path_length [] init
|
||||||
|
|
||||||
let keys_unaccounted s =
|
let keys_unaccounted s =
|
||||||
fold_keys_unaccounted s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc))
|
fold_keys_unaccounted s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc))
|
||||||
@ -455,8 +469,8 @@ module Make_indexed_data_snapshotable_storage (C : Raw_context.T)
|
|||||||
let data_name = ["current"]
|
let data_name = ["current"]
|
||||||
let snapshot_name = ["snapshot"]
|
let snapshot_name = ["snapshot"]
|
||||||
|
|
||||||
module C_data = Make_subcontext(C)(struct let name = data_name end)
|
module C_data = Make_subcontext(Registered)(C)(struct let name = data_name end)
|
||||||
module C_snapshot = Make_subcontext(C)(struct let name = snapshot_name end)
|
module C_snapshot = Make_subcontext(Registered)(C)(struct let name = snapshot_name end)
|
||||||
|
|
||||||
include Make_indexed_data_storage(C_data)(I) (V)
|
include Make_indexed_data_storage(C_data)(I) (V)
|
||||||
module Snapshot = Make_indexed_data_storage(C_snapshot)(Pair(Snapshot_index)(I))(V)
|
module Snapshot = Make_indexed_data_storage(C_snapshot)(Pair(Snapshot_index)(I))(V)
|
||||||
@ -510,6 +524,12 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX)
|
|||||||
|
|
||||||
let list t k = C.fold t k ~init:[] ~f:(fun k acc -> Lwt.return (k :: acc))
|
let list t k = C.fold t k ~init:[] ~f:(fun k acc -> Lwt.return (k :: acc))
|
||||||
|
|
||||||
|
let remove_rec t k =
|
||||||
|
C.remove_rec t (I.to_path k [])
|
||||||
|
|
||||||
|
let copy t ~from ~to_ =
|
||||||
|
C.copy t ~from:(I.to_path from []) ~to_:(I.to_path to_ [])
|
||||||
|
|
||||||
let description =
|
let description =
|
||||||
Storage_description.register_indexed_subcontext
|
Storage_description.register_indexed_subcontext
|
||||||
~list:(fun c -> keys c >>= return)
|
~list:(fun c -> keys c >>= return)
|
||||||
@ -587,13 +607,13 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX)
|
|||||||
end
|
end
|
||||||
| [] ->
|
| [] ->
|
||||||
list t prefix >>= fun prefixes ->
|
list t prefix >>= fun prefixes ->
|
||||||
Lwt_list.map_p (function
|
Lwt_list.map_s (function
|
||||||
| `Key prefix | `Dir prefix -> loop (i+1) prefix []) prefixes
|
| `Key prefix | `Dir prefix -> loop (i+1) prefix []) prefixes
|
||||||
>|= List.flatten
|
>|= List.flatten
|
||||||
| [d] when Compare.Int.(i = I.path_length - 1) ->
|
| [d] when Compare.Int.(i = I.path_length - 1) ->
|
||||||
if Compare.Int.(i >= I.path_length) then invalid_arg "IO.resolve" ;
|
if Compare.Int.(i >= I.path_length) then invalid_arg "IO.resolve" ;
|
||||||
list t prefix >>= fun prefixes ->
|
list t prefix >>= fun prefixes ->
|
||||||
Lwt_list.map_p (function
|
Lwt_list.map_s (function
|
||||||
| `Key prefix | `Dir prefix ->
|
| `Key prefix | `Dir prefix ->
|
||||||
match Misc.remove_prefix ~prefix:d (List.hd (List.rev prefix)) with
|
match Misc.remove_prefix ~prefix:d (List.hd (List.rev prefix)) with
|
||||||
| None -> Lwt.return_nil
|
| None -> Lwt.return_nil
|
||||||
@ -602,7 +622,7 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX)
|
|||||||
>|= List.flatten
|
>|= List.flatten
|
||||||
| "" :: ds ->
|
| "" :: ds ->
|
||||||
list t prefix >>= fun prefixes ->
|
list t prefix >>= fun prefixes ->
|
||||||
Lwt_list.map_p (function
|
Lwt_list.map_s (function
|
||||||
| `Key prefix | `Dir prefix -> loop (i+1) prefix ds) prefixes
|
| `Key prefix | `Dir prefix -> loop (i+1) prefix ds) prefixes
|
||||||
>|= List.flatten
|
>|= List.flatten
|
||||||
| d :: ds ->
|
| d :: ds ->
|
||||||
@ -612,7 +632,7 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX)
|
|||||||
| false -> Lwt.return_nil in
|
| false -> Lwt.return_nil in
|
||||||
loop 0 [] prefix
|
loop 0 [] prefix
|
||||||
|
|
||||||
module Make_set (N : NAME) = struct
|
module Make_set (R : REGISTER) (N : NAME) = struct
|
||||||
type t = C.t
|
type t = C.t
|
||||||
type context = t
|
type context = t
|
||||||
type elt = I.t
|
type elt = I.t
|
||||||
@ -650,13 +670,15 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX)
|
|||||||
let () =
|
let () =
|
||||||
let open Storage_description in
|
let open Storage_description in
|
||||||
let unpack = unpack I.args in
|
let unpack = unpack I.args in
|
||||||
|
let description = if R.ghost then Storage_description.create ()
|
||||||
|
else Raw_context.description in
|
||||||
register_value
|
register_value
|
||||||
~get:(fun c ->
|
~get:(fun c ->
|
||||||
let (c, k) = unpack c in
|
let (c, k) = unpack c in
|
||||||
mem c k >>= function
|
mem c k >>= function
|
||||||
| true -> return_some true
|
| true -> return_some true
|
||||||
| false -> return_none)
|
| false -> return_none)
|
||||||
(register_named_subcontext Raw_context.description N.name)
|
(register_named_subcontext description N.name)
|
||||||
Data_encoding.bool
|
Data_encoding.bool
|
||||||
|
|
||||||
end
|
end
|
||||||
@ -755,8 +777,8 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX)
|
|||||||
Lwt.return (Raw_context.consume_gas c (Gas_limit_repr.read_bytes_cost Z.zero))
|
Lwt.return (Raw_context.consume_gas c (Gas_limit_repr.read_bytes_cost Z.zero))
|
||||||
let existing_size c =
|
let existing_size c =
|
||||||
Raw_context.get_option c len_name >>= function
|
Raw_context.get_option c len_name >>= function
|
||||||
| None -> return 0
|
| None -> return (0, false)
|
||||||
| Some len -> decode_len_value len_name len
|
| Some len -> decode_len_value len_name len >>=? fun len -> return (len, true)
|
||||||
let consume_read_gas get c =
|
let consume_read_gas get c =
|
||||||
get c (len_name) >>=? fun len ->
|
get c (len_name) >>=? fun len ->
|
||||||
decode_len_value len_name len >>=? fun len ->
|
decode_len_value len_name len >>=? fun len ->
|
||||||
@ -790,31 +812,46 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX)
|
|||||||
else
|
else
|
||||||
return (C.project s, None)
|
return (C.project s, None)
|
||||||
let set s i v =
|
let set s i v =
|
||||||
existing_size (pack s i) >>=? fun prev_size ->
|
existing_size (pack s i) >>=? fun (prev_size, _) ->
|
||||||
consume_write_gas Raw_context.set (pack s i) v >>=? fun (c, bytes) ->
|
consume_write_gas Raw_context.set (pack s i) v >>=? fun (c, bytes) ->
|
||||||
Raw_context.set c data_name bytes >>=? fun c ->
|
Raw_context.set c data_name bytes >>=? fun c ->
|
||||||
let size_diff = MBytes.length bytes - prev_size in
|
let size_diff = MBytes.length bytes - prev_size in
|
||||||
return (Raw_context.project c, size_diff)
|
return (Raw_context.project c, size_diff)
|
||||||
|
let set_free s i v =
|
||||||
|
let c = pack s i in
|
||||||
|
let bytes = to_bytes v in
|
||||||
|
existing_size c >>=? fun (prev_size, _) ->
|
||||||
|
Raw_context.set c len_name (encode_len_value bytes) >>=? fun c ->
|
||||||
|
Raw_context.set c data_name bytes >>=? fun c ->
|
||||||
|
let size_diff = MBytes.length bytes - prev_size in
|
||||||
|
return (Raw_context.project c, size_diff)
|
||||||
let init s i v =
|
let init s i v =
|
||||||
consume_write_gas Raw_context.init (pack s i) v >>=? fun (c, bytes) ->
|
consume_write_gas Raw_context.init (pack s i) v >>=? fun (c, bytes) ->
|
||||||
Raw_context.init c data_name bytes >>=? fun c ->
|
Raw_context.init c data_name bytes >>=? fun c ->
|
||||||
let size = MBytes.length bytes in
|
let size = MBytes.length bytes in
|
||||||
return (Raw_context.project c, size)
|
return (Raw_context.project c, size)
|
||||||
|
let init_free s i v =
|
||||||
|
let c = pack s i in
|
||||||
|
let bytes = to_bytes v in
|
||||||
|
let size = MBytes.length bytes in
|
||||||
|
Raw_context.init c len_name (encode_len_value bytes) >>=? fun c ->
|
||||||
|
Raw_context.init c data_name bytes >>=? fun c ->
|
||||||
|
return (Raw_context.project c, size)
|
||||||
let init_set s i v =
|
let init_set s i v =
|
||||||
let init_set c k v = Raw_context.init_set c k v >>= return in
|
let init_set c k v = Raw_context.init_set c k v >>= return in
|
||||||
existing_size (pack s i) >>=? fun prev_size ->
|
existing_size (pack s i) >>=? fun (prev_size, existed) ->
|
||||||
consume_write_gas init_set (pack s i) v >>=? fun (c, bytes) ->
|
consume_write_gas init_set (pack s i) v >>=? fun (c, bytes) ->
|
||||||
init_set c data_name bytes >>=? fun c ->
|
init_set c data_name bytes >>=? fun c ->
|
||||||
let size_diff = MBytes.length bytes - prev_size in
|
let size_diff = MBytes.length bytes - prev_size in
|
||||||
return (Raw_context.project c, size_diff)
|
return (Raw_context.project c, size_diff, existed)
|
||||||
let remove s i =
|
let remove s i =
|
||||||
let remove c k = Raw_context.remove c k >>= return in
|
let remove c k = Raw_context.remove c k >>= return in
|
||||||
existing_size (pack s i) >>=? fun prev_size ->
|
existing_size (pack s i) >>=? fun (prev_size, existed) ->
|
||||||
consume_remove_gas remove (pack s i) >>=? fun c ->
|
consume_remove_gas remove (pack s i) >>=? fun c ->
|
||||||
remove c data_name >>=? fun c ->
|
remove c data_name >>=? fun c ->
|
||||||
return (Raw_context.project c, prev_size)
|
return (Raw_context.project c, prev_size, existed)
|
||||||
let delete s i =
|
let delete s i =
|
||||||
existing_size (pack s i) >>=? fun prev_size ->
|
existing_size (pack s i) >>=? fun (prev_size, _) ->
|
||||||
consume_remove_gas Raw_context.delete (pack s i) >>=? fun c ->
|
consume_remove_gas Raw_context.delete (pack s i) >>=? fun c ->
|
||||||
Raw_context.delete c data_name >>=? fun c ->
|
Raw_context.delete c data_name >>=? fun c ->
|
||||||
return (Raw_context.project c, prev_size)
|
return (Raw_context.project c, prev_size)
|
||||||
|
@ -27,11 +27,14 @@
|
|||||||
|
|
||||||
open Storage_sigs
|
open Storage_sigs
|
||||||
|
|
||||||
module Make_subcontext (C : Raw_context.T) (N : NAME)
|
module Registered : REGISTER
|
||||||
|
module Ghost : REGISTER
|
||||||
|
|
||||||
|
module Make_subcontext (R : REGISTER) (C : Raw_context.T) (N : NAME)
|
||||||
: Raw_context.T with type t = C.t
|
: Raw_context.T with type t = C.t
|
||||||
|
|
||||||
module Make_single_data_storage
|
module Make_single_data_storage
|
||||||
(C : Raw_context.T) (N : NAME) (V : VALUE)
|
(R : REGISTER) (C : Raw_context.T) (N : NAME) (V : VALUE)
|
||||||
: Single_data_storage with type t = C.t
|
: Single_data_storage with type t = C.t
|
||||||
and type value = V.t
|
and type value = V.t
|
||||||
|
|
||||||
|
@ -23,7 +23,7 @@
|
|||||||
(* *)
|
(* *)
|
||||||
(*****************************************************************************)
|
(*****************************************************************************)
|
||||||
|
|
||||||
(** {1 Entity Accessor Signatures} ****************************************)
|
(** {1 Entity Accessor Signatures} *)
|
||||||
|
|
||||||
(** The generic signature of a single data accessor (a single value
|
(** The generic signature of a single data accessor (a single value
|
||||||
bound to a specific key in the hierarchical (key x value)
|
bound to a specific key in the hierarchical (key x value)
|
||||||
@ -118,16 +118,18 @@ module type Single_carbonated_data_storage = sig
|
|||||||
(** Allocates the data and initializes it with a value ; just
|
(** Allocates the data and initializes it with a value ; just
|
||||||
updates it if the bucket exists.
|
updates it if the bucket exists.
|
||||||
Consumes [Gas_repr.write_bytes_cost <size of the new value>].
|
Consumes [Gas_repr.write_bytes_cost <size of the new value>].
|
||||||
Returns the difference from the old (maybe 0) to the new size. *)
|
Returns the difference from the old (maybe 0) to the new size, and a boolean
|
||||||
val init_set: context -> value -> (Raw_context.t * int) tzresult Lwt.t
|
indicating if a value was already associated to this key. *)
|
||||||
|
val init_set: context -> value -> (Raw_context.t * int * bool) tzresult Lwt.t
|
||||||
|
|
||||||
(** When the value is [Some v], allocates the data and initializes
|
(** When the value is [Some v], allocates the data and initializes
|
||||||
it with [v] ; just updates it if the bucket exists. When the
|
it with [v] ; just updates it if the bucket exists. When the
|
||||||
valus is [None], delete the storage bucket when the value ; does
|
valus is [None], delete the storage bucket when the value ; does
|
||||||
nothing if the bucket does not exists.
|
nothing if the bucket does not exists.
|
||||||
Consumes the same gas cost as either {!remove} or {!init_set}.
|
Consumes the same gas cost as either {!remove} or {!init_set}.
|
||||||
Returns the difference from the old (maybe 0) to the new size. *)
|
Returns the difference from the old (maybe 0) to the new size, and a boolean
|
||||||
val set_option: context -> value option -> (Raw_context.t * int) tzresult Lwt.t
|
indicating if a value was already associated to this key. *)
|
||||||
|
val set_option: context -> value option -> (Raw_context.t * int * bool) tzresult Lwt.t
|
||||||
|
|
||||||
(** Delete the storage bucket ; returns a {!Storage_error
|
(** Delete the storage bucket ; returns a {!Storage_error
|
||||||
Missing_key} if the bucket does not exists.
|
Missing_key} if the bucket does not exists.
|
||||||
@ -138,8 +140,9 @@ module type Single_carbonated_data_storage = sig
|
|||||||
(** Removes the storage bucket and its contents ; does nothing if
|
(** Removes the storage bucket and its contents ; does nothing if
|
||||||
the bucket does not exists.
|
the bucket does not exists.
|
||||||
Consumes [Gas_repr.write_bytes_cost Z.zero].
|
Consumes [Gas_repr.write_bytes_cost Z.zero].
|
||||||
Returns the freed size. *)
|
Returns the freed size, and a boolean
|
||||||
val remove: context -> (Raw_context.t * int) tzresult Lwt.t
|
indicating if a value was already associated to this key. *)
|
||||||
|
val remove: context -> (Raw_context.t * int * bool) tzresult Lwt.t
|
||||||
|
|
||||||
end
|
end
|
||||||
|
|
||||||
@ -245,8 +248,9 @@ module type Non_iterable_indexed_carbonated_data_storage = sig
|
|||||||
with a value ; just updates it if the bucket exists.
|
with a value ; just updates it if the bucket exists.
|
||||||
Consumes serialization cost.
|
Consumes serialization cost.
|
||||||
Consumes [Gas_repr.write_bytes_cost <size of the new value>].
|
Consumes [Gas_repr.write_bytes_cost <size of the new value>].
|
||||||
Returns the difference from the old (maybe 0) to the new size. *)
|
Returns the difference from the old (maybe 0) to the new size, and a boolean
|
||||||
val init_set: context -> key -> value -> (Raw_context.t * int) tzresult Lwt.t
|
indicating if a value was already associated to this key. *)
|
||||||
|
val init_set: context -> key -> value -> (Raw_context.t * int * bool) tzresult Lwt.t
|
||||||
|
|
||||||
(** When the value is [Some v], allocates the data and initializes
|
(** When the value is [Some v], allocates the data and initializes
|
||||||
it with [v] ; just updates it if the bucket exists. When the
|
it with [v] ; just updates it if the bucket exists. When the
|
||||||
@ -254,8 +258,9 @@ module type Non_iterable_indexed_carbonated_data_storage = sig
|
|||||||
nothing if the bucket does not exists.
|
nothing if the bucket does not exists.
|
||||||
Consumes serialization cost.
|
Consumes serialization cost.
|
||||||
Consumes the same gas cost as either {!remove} or {!init_set}.
|
Consumes the same gas cost as either {!remove} or {!init_set}.
|
||||||
Returns the difference from the old (maybe 0) to the new size. *)
|
Returns the difference from the old (maybe 0) to the new size, and a boolean
|
||||||
val set_option: context -> key -> value option -> (Raw_context.t * int) tzresult Lwt.t
|
indicating if a value was already associated to this key. *)
|
||||||
|
val set_option: context -> key -> value option -> (Raw_context.t * int * bool) tzresult Lwt.t
|
||||||
|
|
||||||
(** Delete a storage bucket and its contents ; returns a
|
(** Delete a storage bucket and its contents ; returns a
|
||||||
{!Storage_error Missing_key} if the bucket does not exists.
|
{!Storage_error Missing_key} if the bucket does not exists.
|
||||||
@ -266,8 +271,9 @@ module type Non_iterable_indexed_carbonated_data_storage = sig
|
|||||||
(** Removes a storage bucket and its contents ; does nothing if the
|
(** Removes a storage bucket and its contents ; does nothing if the
|
||||||
bucket does not exists.
|
bucket does not exists.
|
||||||
Consumes [Gas_repr.write_bytes_cost Z.zero].
|
Consumes [Gas_repr.write_bytes_cost Z.zero].
|
||||||
Returns the freed size. *)
|
Returns the freed size, and a boolean
|
||||||
val remove: context -> key -> (Raw_context.t * int) tzresult Lwt.t
|
indicating if a value was already associated to this key. *)
|
||||||
|
val remove: context -> key -> (Raw_context.t * int * bool) tzresult Lwt.t
|
||||||
|
|
||||||
end
|
end
|
||||||
|
|
||||||
@ -358,6 +364,22 @@ module type VALUE = sig
|
|||||||
val encoding: t Data_encoding.t
|
val encoding: t Data_encoding.t
|
||||||
end
|
end
|
||||||
|
|
||||||
|
module type REGISTER = sig val ghost : bool end
|
||||||
|
|
||||||
|
module type Non_iterable_indexed_carbonated_data_storage_with_free = sig
|
||||||
|
include Non_iterable_indexed_carbonated_data_storage
|
||||||
|
|
||||||
|
(** Only used for 005 migration to avoid gas cost.
|
||||||
|
Allocates a storage bucket at the given key and initializes it ;
|
||||||
|
returns a {!Storage_error Existing_key} if the bucket exists. *)
|
||||||
|
val init_free: context -> key -> value -> (Raw_context.t * int) tzresult Lwt.t
|
||||||
|
|
||||||
|
(** Only used for 005 migration to avoid gas cost.
|
||||||
|
Updates the content of a bucket ; returns A {!Storage_Error
|
||||||
|
Missing_key} if the value does not exists. *)
|
||||||
|
val set_free: context -> key -> value -> (Raw_context.t * int) tzresult Lwt.t
|
||||||
|
end
|
||||||
|
|
||||||
module type Indexed_raw_context = sig
|
module type Indexed_raw_context = sig
|
||||||
|
|
||||||
type t
|
type t
|
||||||
@ -373,7 +395,12 @@ module type Indexed_raw_context = sig
|
|||||||
|
|
||||||
val resolve: context -> string list -> key list Lwt.t
|
val resolve: context -> string list -> key list Lwt.t
|
||||||
|
|
||||||
module Make_set (N : NAME)
|
val remove_rec: context -> key -> context Lwt.t
|
||||||
|
|
||||||
|
val copy: context -> from:key -> to_:key -> context tzresult Lwt.t
|
||||||
|
|
||||||
|
module Make_set (R : REGISTER) (N : NAME)
|
||||||
|
|
||||||
: Data_set_storage with type t = t
|
: Data_set_storage with type t = t
|
||||||
and type elt = key
|
and type elt = key
|
||||||
|
|
||||||
@ -383,7 +410,7 @@ module type Indexed_raw_context = sig
|
|||||||
and type value = V.t
|
and type value = V.t
|
||||||
|
|
||||||
module Make_carbonated_map (N : NAME) (V : VALUE)
|
module Make_carbonated_map (N : NAME) (V : VALUE)
|
||||||
: Non_iterable_indexed_carbonated_data_storage with type t = t
|
: Non_iterable_indexed_carbonated_data_storage_with_free with type t = t
|
||||||
and type key = key
|
and type key = key
|
||||||
and type value = V.t
|
and type value = V.t
|
||||||
|
|
||||||
|
371
vendors/ligo-utils/tezos-protocol-alpha/test/activation.ml
vendored
Normal file
371
vendors/ligo-utils/tezos-protocol-alpha/test/activation.ml
vendored
Normal file
@ -0,0 +1,371 @@
|
|||||||
|
(*****************************************************************************)
|
||||||
|
(* *)
|
||||||
|
(* Open Source License *)
|
||||||
|
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
|
||||||
|
(* *)
|
||||||
|
(* Permission is hereby granted, free of charge, to any person obtaining a *)
|
||||||
|
(* copy of this software and associated documentation files (the "Software"),*)
|
||||||
|
(* to deal in the Software without restriction, including without limitation *)
|
||||||
|
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
|
||||||
|
(* and/or sell copies of the Software, and to permit persons to whom the *)
|
||||||
|
(* Software is furnished to do so, subject to the following conditions: *)
|
||||||
|
(* *)
|
||||||
|
(* The above copyright notice and this permission notice shall be included *)
|
||||||
|
(* in all copies or substantial portions of the Software. *)
|
||||||
|
(* *)
|
||||||
|
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
|
||||||
|
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
|
||||||
|
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
|
||||||
|
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
|
||||||
|
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
|
||||||
|
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
|
||||||
|
(* DEALINGS IN THE SOFTWARE. *)
|
||||||
|
(* *)
|
||||||
|
(*****************************************************************************)
|
||||||
|
|
||||||
|
(** The activation operation creates an implicit contract from a
|
||||||
|
registered commitment present in the context. It is parametrized by
|
||||||
|
a public key hash (pkh) and a secret.
|
||||||
|
|
||||||
|
The commitments are composed of :
|
||||||
|
- a blinded pkh that can be revealed by the secret ;
|
||||||
|
- an amount.
|
||||||
|
|
||||||
|
The commitments and the secrets are generated from
|
||||||
|
/scripts/create_genesis/create_genenis.py and should be coherent.
|
||||||
|
*)
|
||||||
|
|
||||||
|
open Protocol
|
||||||
|
open Alpha_context
|
||||||
|
open Test_utils
|
||||||
|
open Test_tez
|
||||||
|
|
||||||
|
(* Generated commitments and secrets *)
|
||||||
|
|
||||||
|
(* Commitments are hard-coded in {Tezos_proto_alpha_parameters.Default_parameters} *)
|
||||||
|
|
||||||
|
(* let commitments =
|
||||||
|
* List.map (fun (bpkh, a) ->
|
||||||
|
* Commitment_repr.{
|
||||||
|
* blinded_public_key_hash=Blinded_public_key_hash.of_b58check_exn bpkh ;
|
||||||
|
* amount = Tez_repr.of_mutez_exn (Int64.of_string a)}
|
||||||
|
* )
|
||||||
|
* [ ( "btz1bRL4X5BWo2Fj4EsBdUwexXqgTf75uf1qa", "23932454669343" ) ;
|
||||||
|
* ( "btz1SxjV1syBgftgKy721czKi3arVkVwYUFSv", "72954577464032" ) ;
|
||||||
|
* ( "btz1LtoNCjiW23txBTenALaf5H6NKF1L3c1gw", "217487035428349" ) ;
|
||||||
|
* ( "btz1SUd3mMhEBcWudrn8u361MVAec4WYCcFoy", "4092742372031" ) ;
|
||||||
|
* ( "btz1MvBXf4orko1tsGmzkjLbpYSgnwUjEe81r", "17590039016550" ) ;
|
||||||
|
* ( "btz1LoDZ3zsjgG3k3cqTpUMc9bsXbchu9qMXT", "26322312350555" ) ;
|
||||||
|
* ( "btz1RMfq456hFV5AeDiZcQuZhoMv2dMpb9hpP", "244951387881443" ) ;
|
||||||
|
* ( "btz1Y9roTh4A7PsMBkp8AgdVFrqUDNaBE59y1", "80065050465525" ) ;
|
||||||
|
* ( "btz1Q1N2ePwhVw5ED3aaRVek6EBzYs1GDkSVD", "3569618927693" ) ;
|
||||||
|
* ( "btz1VFFVsVMYHd5WfaDTAt92BeQYGK8Ri4eLy", "9034781424478" ) ;
|
||||||
|
* ] *)
|
||||||
|
|
||||||
|
type secret_account = {
|
||||||
|
account : public_key_hash ;
|
||||||
|
activation_code : Blinded_public_key_hash.activation_code ;
|
||||||
|
amount : Tez.t ;
|
||||||
|
}
|
||||||
|
|
||||||
|
let secrets () =
|
||||||
|
(* Exported from proto_alpha client - TODO : remove when relocated to lib_crypto *)
|
||||||
|
let read_key mnemonic email password =
|
||||||
|
match Bip39.of_words mnemonic with
|
||||||
|
| None -> assert false
|
||||||
|
| Some t ->
|
||||||
|
(* TODO: unicode normalization (NFKD)... *)
|
||||||
|
let passphrase = MBytes.(concat "" [
|
||||||
|
of_string email ;
|
||||||
|
of_string password ;
|
||||||
|
]) in
|
||||||
|
let sk = Bip39.to_seed ~passphrase t in
|
||||||
|
let sk = MBytes.sub sk 0 32 in
|
||||||
|
let sk : Signature.Secret_key.t =
|
||||||
|
Ed25519 (Data_encoding.Binary.of_bytes_exn Ed25519.Secret_key.encoding sk) in
|
||||||
|
let pk = Signature.Secret_key.to_public_key sk in
|
||||||
|
let pkh = Signature.Public_key.hash pk in
|
||||||
|
(pkh, pk, sk)
|
||||||
|
in
|
||||||
|
List.map (fun (mnemonic, secret, amount, pkh, password, email) ->
|
||||||
|
let (pkh', pk, sk) = read_key mnemonic email password in
|
||||||
|
let pkh = Signature.Public_key_hash.of_b58check_exn pkh in
|
||||||
|
assert (Signature.Public_key_hash.equal pkh pkh');
|
||||||
|
let account = Account.{ pkh ; pk ; sk } in
|
||||||
|
Account.add_account account ;
|
||||||
|
{ account = account.pkh ;
|
||||||
|
activation_code = Blinded_public_key_hash.activation_code_of_hex secret ;
|
||||||
|
amount = Option.unopt_exn (Invalid_argument "tez conversion")
|
||||||
|
(Tez.of_mutez (Int64.of_string amount))
|
||||||
|
})
|
||||||
|
[
|
||||||
|
(["envelope"; "hospital"; "mind"; "sunset"; "cancel"; "muscle"; "leisure";
|
||||||
|
"thumb"; "wine"; "market"; "exit"; "lucky"; "style"; "picnic"; "success"],
|
||||||
|
"0f39ed0b656509c2ecec4771712d9cddefe2afac",
|
||||||
|
"23932454669343",
|
||||||
|
"tz1MawerETND6bqJqx8GV3YHUrvMBCDasRBF",
|
||||||
|
"z0eZHQQGKt",
|
||||||
|
"cjgfoqmk.wpxnvnup@tezos.example.org"
|
||||||
|
);
|
||||||
|
(["flag"; "quote"; "will"; "valley"; "mouse"; "chat"; "hold"; "prosper";
|
||||||
|
"silk"; "tent"; "cruel"; "cause"; "demise"; "bottom"; "practice"],
|
||||||
|
"41f98b15efc63fa893d61d7d6eee4a2ce9427ac4",
|
||||||
|
"72954577464032",
|
||||||
|
"tz1X4maqF9tC1Yn4jULjHRAyzjAtc25Z68TX",
|
||||||
|
"MHErskWPE6",
|
||||||
|
"oklmcktr.ztljnpzc@tezos.example.org"
|
||||||
|
);
|
||||||
|
(["library"; "away"; "inside"; "paper"; "wise"; "focus"; "sweet"; "expose";
|
||||||
|
"require"; "change"; "stove"; "planet"; "zone"; "reflect"; "finger"],
|
||||||
|
"411dfef031eeecc506de71c9df9f8e44297cf5ba",
|
||||||
|
"217487035428348",
|
||||||
|
"tz1SWBY7rWMutEuWS54Pt33MkzAS6eWkUuTc",
|
||||||
|
"0AO6BzQNfN",
|
||||||
|
"ctgnkvqm.kvtiybky@tezos.example.org"
|
||||||
|
);
|
||||||
|
(["cruel"; "fluid"; "damage"; "demand"; "mimic"; "above"; "village"; "alpha";
|
||||||
|
"vendor"; "staff"; "absent"; "uniform"; "fire"; "asthma"; "milk"],
|
||||||
|
"08d7d355bc3391d12d140780b39717d9f46fcf87",
|
||||||
|
"4092742372031",
|
||||||
|
"tz1amUjiZaevaxQy5wKn4SSRvVoERCip3nZS",
|
||||||
|
"9kbZ7fR6im",
|
||||||
|
"bnyxxzqr.tdszcvqb@tezos.example.org"
|
||||||
|
) ;
|
||||||
|
(["opera"; "divorce"; "easy"; "myself"; "idea"; "aim"; "dash"; "scout";
|
||||||
|
"case"; "resource"; "vote"; "humor"; "ticket"; "client"; "edge"],
|
||||||
|
"9b7cad042fba557618bdc4b62837c5f125b50e56",
|
||||||
|
"17590039016550",
|
||||||
|
"tz1Zaee3QBtD4ErY1SzqUvyYTrENrExu6yQM",
|
||||||
|
"suxT5H09yY",
|
||||||
|
"iilkhohu.otnyuvna@tezos.example.org"
|
||||||
|
) ;
|
||||||
|
(["token"; "similar"; "ginger"; "tongue"; "gun"; "sort"; "piano"; "month";
|
||||||
|
"hotel"; "vote"; "undo"; "success"; "hobby"; "shell"; "cart"],
|
||||||
|
"124c0ca217f11ffc6c7b76a743d867c8932e5afd",
|
||||||
|
"26322312350555",
|
||||||
|
"tz1geDUUhfXK1EMj7VQdRjug1MoFe6gHWnCU",
|
||||||
|
"4odVdLykaa",
|
||||||
|
"kwhlglvr.slriitzy@tezos.example.org"
|
||||||
|
) ;
|
||||||
|
(["shield"; "warrior"; "gorilla"; "birth"; "steak"; "neither"; "feel";
|
||||||
|
"only"; "liberty"; "float"; "oven"; "extend"; "pulse"; "suffer"; "vapor"],
|
||||||
|
"ac7a2125beea68caf5266a647f24dce9fea018a7",
|
||||||
|
"244951387881443",
|
||||||
|
"tz1h3nY7jcZciJgAwRhWcrEwqfVp7VQoffur",
|
||||||
|
"A6yeMqBFG8",
|
||||||
|
"lvrmlbyj.yczltcxn@tezos.example.org"
|
||||||
|
) ;
|
||||||
|
(["waste"; "open"; "scan"; "tip"; "subway"; "dance"; "rent"; "copper";
|
||||||
|
"garlic"; "laundry"; "defense"; "clerk"; "another"; "staff"; "liar"],
|
||||||
|
"2b3e94be133a960fa0ef87f6c0922c19f9d87ca2",
|
||||||
|
"80065050465525",
|
||||||
|
"tz1VzL4Xrb3fL3ckvqCWy6bdGMzU2w9eoRqs",
|
||||||
|
"oVZqpq60sk",
|
||||||
|
"rfodmrha.zzdndvyk@tezos.example.org"
|
||||||
|
) ;
|
||||||
|
(["fiber"; "next"; "property"; "cradle"; "silk"; "obey"; "gossip";
|
||||||
|
"push"; "key"; "second"; "across"; "minimum"; "nice"; "boil"; "age"],
|
||||||
|
"dac31640199f2babc157aadc0021cd71128ca9ea",
|
||||||
|
"3569618927693",
|
||||||
|
"tz1RUHg536oRKhPLFfttcB5gSWAhh4E9TWjX",
|
||||||
|
"FfytQTTVbu",
|
||||||
|
"owecikdy.gxnyttya@tezos.example.org"
|
||||||
|
) ;
|
||||||
|
(["print"; "labor"; "budget"; "speak"; "poem"; "diet"; "chunk"; "eternal";
|
||||||
|
"book"; "saddle"; "pioneer"; "ankle"; "happy"; "only"; "exclude"],
|
||||||
|
"bb841227f250a066eb8429e56937ad504d7b34dd",
|
||||||
|
"9034781424478",
|
||||||
|
"tz1M1LFbgctcPWxstrao9aLr2ECW1fV4pH5u",
|
||||||
|
"zknAl3lrX2",
|
||||||
|
"ettilrvh.zsrqrbud@tezos.example.org"
|
||||||
|
) ;
|
||||||
|
]
|
||||||
|
|
||||||
|
let activation_init () =
|
||||||
|
Context.init ~with_commitments:true 1 >>=? fun (b, cs) ->
|
||||||
|
secrets () |> fun ss ->
|
||||||
|
return (b, cs, ss)
|
||||||
|
|
||||||
|
let simple_init_with_commitments () =
|
||||||
|
activation_init () >>=? fun (blk, _contracts, _secrets) ->
|
||||||
|
Block.bake blk >>=? fun _ ->
|
||||||
|
return_unit
|
||||||
|
|
||||||
|
(** A single activation *)
|
||||||
|
let single_activation () =
|
||||||
|
activation_init () >>=? fun (blk, _contracts, secrets) ->
|
||||||
|
let { account ; activation_code ; amount=expected_amount ; _ } as _first_one = List.hd secrets in
|
||||||
|
|
||||||
|
(* Contract does not exist *)
|
||||||
|
Assert.balance_is ~loc:__LOC__ (B blk) (Contract.implicit_contract account) Tez.zero >>=? fun () ->
|
||||||
|
|
||||||
|
Op.activation (B blk) account activation_code >>=? fun operation ->
|
||||||
|
Block.bake ~operation blk >>=? fun blk ->
|
||||||
|
|
||||||
|
(* Contract does exist *)
|
||||||
|
Assert.balance_is ~loc:__LOC__ (B blk) (Contract.implicit_contract account) expected_amount
|
||||||
|
|
||||||
|
(** 10 activations, one per bake *)
|
||||||
|
let multi_activation_1 () =
|
||||||
|
activation_init () >>=? fun (blk, _contracts, secrets) ->
|
||||||
|
|
||||||
|
Error_monad.fold_left_s (fun blk { account ; activation_code ; amount = expected_amount ; _ } ->
|
||||||
|
Op.activation (B blk) account activation_code >>=? fun operation ->
|
||||||
|
Block.bake ~operation blk >>=? fun blk ->
|
||||||
|
|
||||||
|
Assert.balance_is ~loc:__LOC__ (B blk) (Contract.implicit_contract account) expected_amount >>=? fun () ->
|
||||||
|
|
||||||
|
return blk
|
||||||
|
) blk secrets >>=? fun _ ->
|
||||||
|
return_unit
|
||||||
|
|
||||||
|
(** All in one bake *)
|
||||||
|
let multi_activation_2 () =
|
||||||
|
activation_init () >>=? fun (blk, _contracts, secrets) ->
|
||||||
|
|
||||||
|
Error_monad.fold_left_s (fun ops { account ; activation_code ; _ } ->
|
||||||
|
Op.activation (B blk) account activation_code >>=? fun op ->
|
||||||
|
return (op::ops)
|
||||||
|
) [] secrets >>=? fun ops ->
|
||||||
|
|
||||||
|
Block.bake ~operations:ops blk >>=? fun blk ->
|
||||||
|
|
||||||
|
Error_monad.iter_s (fun { account ; amount = expected_amount ; _ } ->
|
||||||
|
(* Contract does exist *)
|
||||||
|
Assert.balance_is ~loc:__LOC__ (B blk) (Contract.implicit_contract account) expected_amount
|
||||||
|
) secrets
|
||||||
|
|
||||||
|
(** Transfer with activated account *)
|
||||||
|
let activation_and_transfer () =
|
||||||
|
activation_init () >>=? fun (blk, contracts, secrets) ->
|
||||||
|
let { account ; activation_code ; _ } as _first_one = List.hd secrets in
|
||||||
|
let bootstrap_contract = List.hd contracts in
|
||||||
|
let first_contract = Contract.implicit_contract account in
|
||||||
|
|
||||||
|
Op.activation (B blk) account activation_code >>=? fun operation ->
|
||||||
|
Block.bake ~operation blk >>=? fun blk ->
|
||||||
|
|
||||||
|
Context.Contract.balance (B blk) bootstrap_contract >>=? fun amount ->
|
||||||
|
Tez.(/?) amount 2L >>?= fun half_amount ->
|
||||||
|
Context.Contract.balance (B blk) first_contract >>=? fun activated_amount_before ->
|
||||||
|
|
||||||
|
Op.transaction (B blk) bootstrap_contract first_contract half_amount >>=? fun operation ->
|
||||||
|
Block.bake ~operation blk >>=? fun blk ->
|
||||||
|
|
||||||
|
Assert.balance_was_credited ~loc:__LOC__ (B blk) (Contract.implicit_contract account) activated_amount_before half_amount
|
||||||
|
|
||||||
|
(** Transfer to an unactivated account and then activating it *)
|
||||||
|
let transfer_to_unactivated_then_activate () =
|
||||||
|
activation_init () >>=? fun (blk, contracts, secrets) ->
|
||||||
|
let { account ; activation_code ; amount } as _first_one = List.hd secrets in
|
||||||
|
let bootstrap_contract = List.hd contracts in
|
||||||
|
let unactivated_commitment_contract = Contract.implicit_contract account in
|
||||||
|
|
||||||
|
Context.Contract.balance (B blk) bootstrap_contract >>=? fun b_amount ->
|
||||||
|
Tez.(/?) b_amount 2L >>?= fun b_half_amount ->
|
||||||
|
|
||||||
|
Incremental.begin_construction blk >>=? fun inc ->
|
||||||
|
Op.transaction (I inc) bootstrap_contract unactivated_commitment_contract b_half_amount >>=? fun op ->
|
||||||
|
Incremental.add_operation inc op >>=? fun inc ->
|
||||||
|
Op.activation (I inc) account activation_code >>=? fun op' ->
|
||||||
|
Incremental.add_operation inc op' >>=? fun inc ->
|
||||||
|
Incremental.finalize_block inc >>=? fun blk2 ->
|
||||||
|
|
||||||
|
Assert.balance_was_credited ~loc:__LOC__ (B blk2) (Contract.implicit_contract account) amount b_half_amount
|
||||||
|
|
||||||
|
(****************************************************************)
|
||||||
|
(* The following test scenarios are supposed to raise errors. *)
|
||||||
|
(****************************************************************)
|
||||||
|
|
||||||
|
(** Invalid pkh activation : expected to fail as the context does not
|
||||||
|
contain any commitment *)
|
||||||
|
let invalid_activation_with_no_commitments () =
|
||||||
|
Context.init 1 >>=? fun (blk, _) ->
|
||||||
|
let secrets = secrets () in
|
||||||
|
let { account ; activation_code ; _ } as _first_one = List.hd secrets in
|
||||||
|
|
||||||
|
Op.activation (B blk) account activation_code >>=? fun operation ->
|
||||||
|
Block.bake ~operation blk >>= fun res ->
|
||||||
|
|
||||||
|
Assert.proto_error ~loc:__LOC__ res begin function
|
||||||
|
| Apply.Invalid_activation _ -> true
|
||||||
|
| _ -> false
|
||||||
|
end
|
||||||
|
|
||||||
|
(** Wrong activation : wrong secret given in the operation *)
|
||||||
|
let invalid_activation_wrong_secret () =
|
||||||
|
activation_init () >>=? fun (blk, _, secrets) ->
|
||||||
|
let { account ; _ } as _first_one = List.nth secrets 0 in
|
||||||
|
let { activation_code ; _ } as _second_one = List.nth secrets 1 in
|
||||||
|
|
||||||
|
Op.activation (B blk) account activation_code >>=? fun operation ->
|
||||||
|
Block.bake ~operation blk >>= fun res ->
|
||||||
|
|
||||||
|
Assert.proto_error ~loc:__LOC__ res begin function
|
||||||
|
| Apply.Invalid_activation _ -> true
|
||||||
|
| _ -> false
|
||||||
|
end
|
||||||
|
|
||||||
|
(** Invalid pkh activation : expected to fail as the context does not
|
||||||
|
contain an associated commitment *)
|
||||||
|
let invalid_activation_inexistent_pkh () =
|
||||||
|
activation_init () >>=? fun (blk, _, secrets) ->
|
||||||
|
let { activation_code ; _ } as _first_one = List.hd secrets in
|
||||||
|
let inexistent_pkh = Signature.Public_key_hash.of_b58check_exn
|
||||||
|
"tz1PeQHGKPWSpNoozvxgqLN9TFsj6rDqNV3o" in
|
||||||
|
|
||||||
|
Op.activation (B blk) inexistent_pkh activation_code >>=? fun operation ->
|
||||||
|
Block.bake ~operation blk >>= fun res ->
|
||||||
|
|
||||||
|
Assert.proto_error ~loc:__LOC__ res begin function
|
||||||
|
| Apply.Invalid_activation _ -> true
|
||||||
|
| _ -> false
|
||||||
|
end
|
||||||
|
|
||||||
|
(** Invalid pkh activation : expected to fail as the commitment has
|
||||||
|
already been claimed *)
|
||||||
|
let invalid_double_activation () =
|
||||||
|
activation_init () >>=? fun (blk, _, secrets) ->
|
||||||
|
let { account ; activation_code ; _ } as _first_one = List.hd secrets in
|
||||||
|
Incremental.begin_construction blk >>=? fun inc ->
|
||||||
|
|
||||||
|
Op.activation (I inc) account activation_code >>=? fun op ->
|
||||||
|
Incremental.add_operation inc op >>=? fun inc ->
|
||||||
|
Op.activation (I inc) account activation_code >>=? fun op' ->
|
||||||
|
Incremental.add_operation inc op' >>= fun res ->
|
||||||
|
|
||||||
|
Assert.proto_error ~loc:__LOC__ res begin function
|
||||||
|
| Apply.Invalid_activation _ -> true
|
||||||
|
| _ -> false
|
||||||
|
end
|
||||||
|
|
||||||
|
(** Transfer from an unactivated commitment account *)
|
||||||
|
let invalid_transfer_from_unactived_account () =
|
||||||
|
activation_init () >>=? fun (blk, contracts, secrets) ->
|
||||||
|
let { account ; _ } as _first_one = List.hd secrets in
|
||||||
|
let bootstrap_contract = List.hd contracts in
|
||||||
|
let unactivated_commitment_contract = Contract.implicit_contract account in
|
||||||
|
|
||||||
|
(* No activation *)
|
||||||
|
|
||||||
|
Op.transaction (B blk) unactivated_commitment_contract bootstrap_contract Tez.one >>=? fun operation ->
|
||||||
|
Block.bake ~operation blk >>= fun res ->
|
||||||
|
|
||||||
|
Assert.proto_error ~loc:__LOC__ res begin function
|
||||||
|
| Contract_storage.Empty_implicit_contract pkh -> if pkh = account then true else false
|
||||||
|
| _ -> false
|
||||||
|
end
|
||||||
|
|
||||||
|
let tests = [
|
||||||
|
Test.tztest "init with commitments" `Quick simple_init_with_commitments ;
|
||||||
|
Test.tztest "single activation" `Quick single_activation ;
|
||||||
|
Test.tztest "multi-activation one-by-one" `Quick multi_activation_1 ;
|
||||||
|
Test.tztest "multi-activation all at a time" `Quick multi_activation_2 ;
|
||||||
|
Test.tztest "activation and transfer" `Quick activation_and_transfer ;
|
||||||
|
Test.tztest "transfer to unactivated account then activate" `Quick transfer_to_unactivated_then_activate ;
|
||||||
|
Test.tztest "invalid activation with no commitments" `Quick invalid_activation_with_no_commitments ;
|
||||||
|
Test.tztest "invalid activation with commitments" `Quick invalid_activation_inexistent_pkh ;
|
||||||
|
Test.tztest "invalid double activation" `Quick invalid_double_activation ;
|
||||||
|
Test.tztest "wrong activation code" `Quick invalid_activation_wrong_secret ;
|
||||||
|
Test.tztest "invalid transfer from unactivated account" `Quick invalid_transfer_from_unactived_account
|
||||||
|
]
|
98
vendors/ligo-utils/tezos-protocol-alpha/test/baking.ml
vendored
Normal file
98
vendors/ligo-utils/tezos-protocol-alpha/test/baking.ml
vendored
Normal file
@ -0,0 +1,98 @@
|
|||||||
|
(*****************************************************************************)
|
||||||
|
(* *)
|
||||||
|
(* Open Source License *)
|
||||||
|
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
|
||||||
|
(* *)
|
||||||
|
(* Permission is hereby granted, free of charge, to any person obtaining a *)
|
||||||
|
(* copy of this software and associated documentation files (the "Software"),*)
|
||||||
|
(* to deal in the Software without restriction, including without limitation *)
|
||||||
|
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
|
||||||
|
(* and/or sell copies of the Software, and to permit persons to whom the *)
|
||||||
|
(* Software is furnished to do so, subject to the following conditions: *)
|
||||||
|
(* *)
|
||||||
|
(* The above copyright notice and this permission notice shall be included *)
|
||||||
|
(* in all copies or substantial portions of the Software. *)
|
||||||
|
(* *)
|
||||||
|
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
|
||||||
|
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
|
||||||
|
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
|
||||||
|
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
|
||||||
|
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
|
||||||
|
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
|
||||||
|
(* DEALINGS IN THE SOFTWARE. *)
|
||||||
|
(* *)
|
||||||
|
(*****************************************************************************)
|
||||||
|
|
||||||
|
open Protocol
|
||||||
|
open Alpha_context
|
||||||
|
open Test_utils
|
||||||
|
|
||||||
|
(** Tests for [bake_n] and [bake_until_end_cycle]. *)
|
||||||
|
let test_cycle () =
|
||||||
|
Context.init 5 >>=? fun (b,_) ->
|
||||||
|
Context.get_constants (B b) >>=? fun csts ->
|
||||||
|
let blocks_per_cycle = csts.parametric.blocks_per_cycle in
|
||||||
|
|
||||||
|
let pp = fun fmt x -> Format.fprintf fmt "%ld" x in
|
||||||
|
|
||||||
|
(* Tests that [bake_until_cycle_end] returns a block at
|
||||||
|
level [blocks_per_cycle]. *)
|
||||||
|
Block.bake b >>=? fun b ->
|
||||||
|
Block.bake_until_cycle_end b >>=? fun b ->
|
||||||
|
Context.get_level (B b) >>=? fun curr_level ->
|
||||||
|
Assert.equal ~loc:__LOC__ Int32.equal "not the right level" pp
|
||||||
|
(Alpha_context.Raw_level.to_int32 curr_level)
|
||||||
|
blocks_per_cycle >>=? fun () ->
|
||||||
|
|
||||||
|
(* Tests that [bake_n n] bakes [n] blocks. *)
|
||||||
|
Context.get_level (B b) >>=? fun l ->
|
||||||
|
Block.bake_n 10 b >>=? fun b ->
|
||||||
|
Context.get_level (B b) >>=? fun curr_level ->
|
||||||
|
Assert.equal ~loc:__LOC__ Int32.equal "not the right level" pp
|
||||||
|
(Alpha_context.Raw_level.to_int32 curr_level)
|
||||||
|
(Int32.add (Alpha_context.Raw_level.to_int32 l) 10l)
|
||||||
|
|
||||||
|
|
||||||
|
(** Tests the formula introduced in Emmy+ for block reward:
|
||||||
|
(16/(p+1)) * (0.8 + 0.2 * e / 32)
|
||||||
|
where p is the block priority and
|
||||||
|
e is the number of included endorsements *)
|
||||||
|
let test_block_reward priority () =
|
||||||
|
begin match priority with
|
||||||
|
| 0 -> Test_tez.Tez.((of_int 128) /? Int64.of_int 10) >>?= fun min ->
|
||||||
|
return (Test_tez.Tez.of_int 16, min)
|
||||||
|
| 1 -> Test_tez.Tez.((of_int 64) /? Int64.of_int 10) >>?= fun min ->
|
||||||
|
return (Test_tez.Tez.of_int 8, min)
|
||||||
|
| 3 -> Test_tez.Tez.((of_int 32) /? Int64.of_int 10) >>?= fun min ->
|
||||||
|
return (Test_tez.Tez.of_int 4, min)
|
||||||
|
| _ -> fail (invalid_arg "prio should be 0, 1, or 3")
|
||||||
|
end >>=? fun (expected_reward_max_endo, expected_reward_min_endo) ->
|
||||||
|
let endorsers_per_block = 32 in
|
||||||
|
Context.init ~endorsers_per_block 32 >>=? fun (b, _) ->
|
||||||
|
|
||||||
|
Context.get_endorsers (B b) >>=? fun endorsers ->
|
||||||
|
fold_left_s (fun ops (endorser : Alpha_services.Delegate.Endorsing_rights.t) ->
|
||||||
|
let delegate = endorser.delegate in
|
||||||
|
Op.endorsement ~delegate (B b) () >>=? fun op ->
|
||||||
|
return (Operation.pack op :: ops)
|
||||||
|
) [] endorsers >>=? fun ops ->
|
||||||
|
Block.bake
|
||||||
|
~policy:(By_priority 0)
|
||||||
|
~operations:ops
|
||||||
|
b >>=? fun b ->
|
||||||
|
(* bake a block at priority 0 and 32 endorsements;
|
||||||
|
the reward is 16 tez *)
|
||||||
|
Context.get_baking_reward (B b) ~priority ~endorsing_power:32 >>=? fun baking_reward ->
|
||||||
|
Assert.equal_tez ~loc:__LOC__ baking_reward expected_reward_max_endo >>=? fun () ->
|
||||||
|
(* bake a block at priority 0 and 0 endorsements;
|
||||||
|
the reward is 12.8 tez *)
|
||||||
|
Context.get_baking_reward (B b) ~priority ~endorsing_power:0 >>=? fun baking_reward ->
|
||||||
|
Assert.equal_tez ~loc:__LOC__ baking_reward expected_reward_min_endo
|
||||||
|
|
||||||
|
|
||||||
|
let tests = [
|
||||||
|
Test.tztest "cycle" `Quick (test_cycle) ;
|
||||||
|
Test.tztest "block_reward for priority 0" `Quick (test_block_reward 0) ;
|
||||||
|
Test.tztest "block_reward for priority 1" `Quick (test_block_reward 1) ;
|
||||||
|
Test.tztest "block_reward for priority 3" `Quick (test_block_reward 3) ;
|
||||||
|
]
|
229
vendors/ligo-utils/tezos-protocol-alpha/test/combined_operations.ml
vendored
Normal file
229
vendors/ligo-utils/tezos-protocol-alpha/test/combined_operations.ml
vendored
Normal file
@ -0,0 +1,229 @@
|
|||||||
|
(*****************************************************************************)
|
||||||
|
(* *)
|
||||||
|
(* Open Source License *)
|
||||||
|
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
|
||||||
|
(* *)
|
||||||
|
(* Permission is hereby granted, free of charge, to any person obtaining a *)
|
||||||
|
(* copy of this software and associated documentation files (the "Software"),*)
|
||||||
|
(* to deal in the Software without restriction, including without limitation *)
|
||||||
|
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
|
||||||
|
(* and/or sell copies of the Software, and to permit persons to whom the *)
|
||||||
|
(* Software is furnished to do so, subject to the following conditions: *)
|
||||||
|
(* *)
|
||||||
|
(* The above copyright notice and this permission notice shall be included *)
|
||||||
|
(* in all copies or substantial portions of the Software. *)
|
||||||
|
(* *)
|
||||||
|
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
|
||||||
|
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
|
||||||
|
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
|
||||||
|
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
|
||||||
|
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
|
||||||
|
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
|
||||||
|
(* DEALINGS IN THE SOFTWARE. *)
|
||||||
|
(* *)
|
||||||
|
(*****************************************************************************)
|
||||||
|
|
||||||
|
(** Multiple operations can be grouped in one ensuring their
|
||||||
|
derministic application.
|
||||||
|
|
||||||
|
If an invalid operation is present in this group of operation, the
|
||||||
|
previous applied operations are backtracked leaving the context
|
||||||
|
unchanged and the following operations are skipped. Fees attributed
|
||||||
|
to the operations are collected by the baker nonetheless.
|
||||||
|
|
||||||
|
Only manager operations are allowed in multiple transactions.
|
||||||
|
They must all belong to the same manager as there is only one signature. *)
|
||||||
|
|
||||||
|
open Protocol
|
||||||
|
open Test_tez
|
||||||
|
open Test_utils
|
||||||
|
|
||||||
|
let ten_tez = Tez.of_int 10
|
||||||
|
|
||||||
|
(** Groups ten transactions between the same parties. *)
|
||||||
|
let multiple_transfers () =
|
||||||
|
Context.init 3 >>=? fun (blk, contracts) ->
|
||||||
|
let c1 = List.nth contracts 0 in
|
||||||
|
let c2 = List.nth contracts 1 in
|
||||||
|
let c3 = List.nth contracts 2 in
|
||||||
|
|
||||||
|
map_s (fun _ ->
|
||||||
|
Op.transaction (B blk) c1 c2 Tez.one
|
||||||
|
) (1--10) >>=? fun ops ->
|
||||||
|
|
||||||
|
Op.combine_operations ~source:c1 (B blk) ops >>=? fun operation ->
|
||||||
|
|
||||||
|
Context.Contract.balance (B blk) c1 >>=? fun c1_old_balance ->
|
||||||
|
Context.Contract.balance (B blk) c2 >>=? fun c2_old_balance ->
|
||||||
|
Context.Contract.pkh c3 >>=? fun baker_pkh ->
|
||||||
|
Block.bake ~policy:(By_account baker_pkh) ~operation blk >>=? fun blk ->
|
||||||
|
|
||||||
|
Assert.balance_was_debited ~loc:__LOC__
|
||||||
|
(B blk) c1 c1_old_balance (Tez.of_int 10) >>=? fun () ->
|
||||||
|
Assert.balance_was_credited ~loc:__LOC__
|
||||||
|
(B blk) c2 c2_old_balance (Tez.of_int 10) >>=? fun () ->
|
||||||
|
return_unit
|
||||||
|
|
||||||
|
|
||||||
|
(** Groups ten delegated originations. *)
|
||||||
|
let multiple_origination_and_delegation () =
|
||||||
|
Context.init 2 >>=? fun (blk, contracts) ->
|
||||||
|
let c1 = List.nth contracts 0 in
|
||||||
|
let c2 = List.nth contracts 1 in
|
||||||
|
let n = 10 in
|
||||||
|
Context.get_constants (B blk) >>=? fun { parametric = { origination_size ; cost_per_byte ; _ } ; _ } ->
|
||||||
|
Context.Contract.pkh c2 >>=? fun delegate_pkh ->
|
||||||
|
|
||||||
|
(* Deploy n smart contracts with dummy scripts from c1 *)
|
||||||
|
map_s (fun i ->
|
||||||
|
Op.origination ~delegate:delegate_pkh ~counter:(Z.of_int i) ~fee:Tez.zero ~script:Op.dummy_script
|
||||||
|
~credit:(Tez.of_int 10) (B blk) c1
|
||||||
|
) (1--n) >>=? fun originations ->
|
||||||
|
|
||||||
|
(* These computed originated contracts are not the ones really created *)
|
||||||
|
(* We will extract them from the tickets *)
|
||||||
|
let (originations_operations, _) = List.split originations in
|
||||||
|
|
||||||
|
Op.combine_operations ~source:c1 (B blk) originations_operations >>=? fun operation ->
|
||||||
|
|
||||||
|
Context.Contract.balance (B blk) c1 >>=? fun c1_old_balance ->
|
||||||
|
Incremental.begin_construction blk >>=? fun inc ->
|
||||||
|
Incremental.add_operation inc operation >>=? fun inc ->
|
||||||
|
|
||||||
|
(* To retrieve the originated contracts, it is easier to extract them
|
||||||
|
from the tickets. Else, we could (could we ?) hash each combined
|
||||||
|
operation individually. *)
|
||||||
|
let tickets = Incremental.rev_tickets inc in
|
||||||
|
let open Apply_results in
|
||||||
|
let tickets =
|
||||||
|
List.fold_left (fun acc -> function
|
||||||
|
| No_operation_metadata -> assert false
|
||||||
|
| Operation_metadata { contents } ->
|
||||||
|
to_list (Contents_result_list contents) @ acc
|
||||||
|
) [] tickets |> List.rev in
|
||||||
|
let new_contracts =
|
||||||
|
List.map (function
|
||||||
|
| Contents_result
|
||||||
|
(Manager_operation_result
|
||||||
|
{ operation_result =
|
||||||
|
Applied (Origination_result { originated_contracts = [ h ] ; _ })
|
||||||
|
; _ }) ->
|
||||||
|
h
|
||||||
|
| _ -> assert false
|
||||||
|
) tickets in
|
||||||
|
|
||||||
|
(* Previous balance - (Credit (n * 10tz) + Origination cost (n tz)) *)
|
||||||
|
Tez.(cost_per_byte *? Int64.of_int origination_size) >>?= fun origination_burn ->
|
||||||
|
Tez.(origination_burn *? (Int64.of_int n)) >>?= fun origination_total_cost ->
|
||||||
|
Lwt.return (
|
||||||
|
Tez.( *? ) Op.dummy_script_cost 10L >>?
|
||||||
|
Tez.( +? ) (Tez.of_int (10 * n)) >>?
|
||||||
|
Tez.( +? ) origination_total_cost ) >>=? fun total_cost ->
|
||||||
|
Assert.balance_was_debited ~loc:__LOC__
|
||||||
|
(I inc) c1 c1_old_balance total_cost >>=? fun () ->
|
||||||
|
|
||||||
|
iter_s (fun c ->
|
||||||
|
Assert.balance_is ~loc:__LOC__ (I inc) c (Tez.of_int 10)
|
||||||
|
) new_contracts >>=? fun () ->
|
||||||
|
|
||||||
|
return_unit
|
||||||
|
|
||||||
|
let expect_balance_too_low = function
|
||||||
|
| Environment.Ecoproto_error (Contract_storage.Balance_too_low _) :: _ ->
|
||||||
|
return_unit
|
||||||
|
| _ ->
|
||||||
|
failwith "Contract should not have a sufficient balance : operation expected to fail."
|
||||||
|
|
||||||
|
(** Groups three operations, the midlle one failing.
|
||||||
|
Checks that the receipt is consistent.
|
||||||
|
Variant without fees. *)
|
||||||
|
let failing_operation_in_the_middle () =
|
||||||
|
Context.init 2 >>=? fun (blk, contracts) ->
|
||||||
|
let c1 = List.nth contracts 0 in
|
||||||
|
let c2 = List.nth contracts 1 in
|
||||||
|
|
||||||
|
Op.transaction ~fee:Tez.zero (B blk) c1 c2 Tez.one >>=? fun op1 ->
|
||||||
|
Op.transaction ~fee:Tez.zero (B blk) c1 c2 Tez.max_tez >>=? fun op2 ->
|
||||||
|
Op.transaction ~fee:Tez.zero (B blk) c1 c2 Tez.one >>=? fun op3 ->
|
||||||
|
let operations = [ op1 ; op2 ; op3 ] in
|
||||||
|
|
||||||
|
Op.combine_operations ~source:c1 (B blk) operations >>=? fun operation ->
|
||||||
|
|
||||||
|
Context.Contract.balance (B blk) c1 >>=? fun c1_old_balance ->
|
||||||
|
Context.Contract.balance (B blk) c2 >>=? fun c2_old_balance ->
|
||||||
|
|
||||||
|
Incremental.begin_construction blk >>=? fun inc ->
|
||||||
|
Incremental.add_operation
|
||||||
|
~expect_failure:expect_balance_too_low inc operation >>=? fun inc ->
|
||||||
|
|
||||||
|
let tickets = Incremental.rev_tickets inc in
|
||||||
|
let open Apply_results in
|
||||||
|
let tickets =
|
||||||
|
List.fold_left (fun acc -> function
|
||||||
|
| No_operation_metadata -> assert false
|
||||||
|
| Operation_metadata { contents } ->
|
||||||
|
to_list (Contents_result_list contents) @ acc
|
||||||
|
) [] tickets in
|
||||||
|
begin match tickets with
|
||||||
|
| Contents_result (Manager_operation_result { operation_result = (Backtracked _) ; _ }) ::
|
||||||
|
Contents_result (Manager_operation_result { operation_result = Failed (_, [ Contract_storage.Balance_too_low _ ]) ; _ }) ::
|
||||||
|
Contents_result (Manager_operation_result { operation_result = Skipped _ ; _ }) ::
|
||||||
|
_ -> ()
|
||||||
|
| _ -> assert false
|
||||||
|
end ;
|
||||||
|
|
||||||
|
Assert.balance_is ~loc:__LOC__ (I inc) c1 c1_old_balance >>=? fun () ->
|
||||||
|
Assert.balance_is ~loc:__LOC__ (I inc) c2 c2_old_balance >>=? fun () ->
|
||||||
|
|
||||||
|
return_unit
|
||||||
|
|
||||||
|
(** Groups three operations, the midlle one failing.
|
||||||
|
Checks that the receipt is consistent.
|
||||||
|
Variant with fees, that should be spent even in case of failure. *)
|
||||||
|
let failing_operation_in_the_middle_with_fees () =
|
||||||
|
Context.init 2 >>=? fun (blk, contracts) ->
|
||||||
|
let c1 = List.nth contracts 0 in
|
||||||
|
let c2 = List.nth contracts 1 in
|
||||||
|
|
||||||
|
Op.transaction ~fee:Tez.one (B blk) c1 c2 Tez.one >>=? fun op1 ->
|
||||||
|
Op.transaction ~fee:Tez.one (B blk) c1 c2 Tez.max_tez >>=? fun op2 ->
|
||||||
|
Op.transaction ~fee:Tez.one (B blk) c1 c2 Tez.one >>=? fun op3 ->
|
||||||
|
let operations = [ op1 ; op2 ; op3 ] in
|
||||||
|
|
||||||
|
Op.combine_operations ~source:c1 (B blk) operations >>=? fun operation ->
|
||||||
|
|
||||||
|
Context.Contract.balance (B blk) c1 >>=? fun c1_old_balance ->
|
||||||
|
Context.Contract.balance (B blk) c2 >>=? fun c2_old_balance ->
|
||||||
|
|
||||||
|
Incremental.begin_construction blk >>=? fun inc ->
|
||||||
|
Incremental.add_operation
|
||||||
|
~expect_failure:expect_balance_too_low inc operation >>=? fun inc ->
|
||||||
|
|
||||||
|
let tickets = Incremental.rev_tickets inc in
|
||||||
|
let open Apply_results in
|
||||||
|
let tickets =
|
||||||
|
List.fold_left (fun acc -> function
|
||||||
|
| No_operation_metadata -> assert false
|
||||||
|
| Operation_metadata { contents } ->
|
||||||
|
to_list (Contents_result_list contents) @ acc
|
||||||
|
) [] tickets in
|
||||||
|
begin match tickets with
|
||||||
|
| Contents_result (Manager_operation_result { operation_result = (Backtracked _) ; _ }) ::
|
||||||
|
Contents_result (Manager_operation_result { operation_result = Failed (_, [ Contract_storage.Balance_too_low _ ]) ; _ }) ::
|
||||||
|
Contents_result (Manager_operation_result { operation_result = Skipped _ ; _ }) ::
|
||||||
|
_ -> ()
|
||||||
|
| _ -> assert false
|
||||||
|
end ;
|
||||||
|
|
||||||
|
(* In the presence of a failure, all the fees are collected. Even for skipped operations. *)
|
||||||
|
Assert.balance_was_debited ~loc:__LOC__ (I inc) c1 c1_old_balance (Tez.of_int 3) >>=? fun () ->
|
||||||
|
Assert.balance_is ~loc:__LOC__ (I inc) c2 c2_old_balance >>=? fun () ->
|
||||||
|
|
||||||
|
return_unit
|
||||||
|
|
||||||
|
let tests = [
|
||||||
|
Test.tztest "multiple transfers" `Quick multiple_transfers ;
|
||||||
|
Test.tztest "multiple originations and delegations" `Quick multiple_origination_and_delegation ;
|
||||||
|
Test.tztest "Failing operation in the middle" `Quick failing_operation_in_the_middle ;
|
||||||
|
Test.tztest "Failing operation in the middle (with fees)" `Quick failing_operation_in_the_middle_with_fees ;
|
||||||
|
]
|
16
vendors/ligo-utils/tezos-protocol-alpha/test/contracts/cps_fact.tz
vendored
Normal file
16
vendors/ligo-utils/tezos-protocol-alpha/test/contracts/cps_fact.tz
vendored
Normal file
@ -0,0 +1,16 @@
|
|||||||
|
storage nat ;
|
||||||
|
parameter nat ;
|
||||||
|
code { UNPAIR ;
|
||||||
|
DIP { SELF ; ADDRESS ; SOURCE;
|
||||||
|
IFCMPEQ {} { DROP ; PUSH @storage nat 1 } };
|
||||||
|
DUP ;
|
||||||
|
PUSH nat 1 ;
|
||||||
|
IFCMPGE
|
||||||
|
{ DROP ; NIL operation ; PAIR }
|
||||||
|
{ PUSH nat 1 ; SWAP ; SUB @parameter ; ISNAT ;
|
||||||
|
IF_NONE
|
||||||
|
{ NIL operation ; PAIR }
|
||||||
|
{ DUP ; DIP { PUSH nat 1 ; ADD ; MUL @storage } ; SWAP;
|
||||||
|
DIP { DIP { SELF; PUSH mutez 0 } ;
|
||||||
|
TRANSFER_TOKENS ; NIL operation ; SWAP ; CONS } ;
|
||||||
|
SWAP ; PAIR } } }
|
14
vendors/ligo-utils/tezos-protocol-alpha/test/contracts/cps_fact_2.tz
vendored
Normal file
14
vendors/ligo-utils/tezos-protocol-alpha/test/contracts/cps_fact_2.tz
vendored
Normal file
@ -0,0 +1,14 @@
|
|||||||
|
storage unit ;
|
||||||
|
parameter (pair nat nat) ;
|
||||||
|
code { CAR ; UNPAIR ;
|
||||||
|
DUP ;
|
||||||
|
PUSH nat 1 ;
|
||||||
|
IFCMPGE
|
||||||
|
{ DROP ; DROP ; UNIT ; NIL operation ; PAIR }
|
||||||
|
{ PUSH nat 1 ; SWAP ; SUB @parameter ; ISNAT ;
|
||||||
|
IF_NONE
|
||||||
|
{ DROP ; UNIT ; NIL operation ; PAIR }
|
||||||
|
{ DUP ; DIP { PUSH nat 1 ; ADD ; MUL @storage } ; PAIR ;
|
||||||
|
DIP { SELF; PUSH tez "0" } ;
|
||||||
|
TRANSFER_TOKENS ; NIL operation ; SWAP ; CONS ;
|
||||||
|
UNIT ; SWAP ; PAIR } } }
|
1171
vendors/ligo-utils/tezos-protocol-alpha/test/delegation.ml
vendored
Normal file
1171
vendors/ligo-utils/tezos-protocol-alpha/test/delegation.ml
vendored
Normal file
File diff suppressed because it is too large
Load Diff
189
vendors/ligo-utils/tezos-protocol-alpha/test/double_baking.ml
vendored
Normal file
189
vendors/ligo-utils/tezos-protocol-alpha/test/double_baking.ml
vendored
Normal file
@ -0,0 +1,189 @@
|
|||||||
|
(*****************************************************************************)
|
||||||
|
(* *)
|
||||||
|
(* Open Source License *)
|
||||||
|
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
|
||||||
|
(* *)
|
||||||
|
(* Permission is hereby granted, free of charge, to any person obtaining a *)
|
||||||
|
(* copy of this software and associated documentation files (the "Software"),*)
|
||||||
|
(* to deal in the Software without restriction, including without limitation *)
|
||||||
|
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
|
||||||
|
(* and/or sell copies of the Software, and to permit persons to whom the *)
|
||||||
|
(* Software is furnished to do so, subject to the following conditions: *)
|
||||||
|
(* *)
|
||||||
|
(* The above copyright notice and this permission notice shall be included *)
|
||||||
|
(* in all copies or substantial portions of the Software. *)
|
||||||
|
(* *)
|
||||||
|
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
|
||||||
|
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
|
||||||
|
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
|
||||||
|
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
|
||||||
|
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
|
||||||
|
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
|
||||||
|
(* DEALINGS IN THE SOFTWARE. *)
|
||||||
|
(* *)
|
||||||
|
(*****************************************************************************)
|
||||||
|
|
||||||
|
(** Double baking evidence operation may happen when a baker
|
||||||
|
baked two different blocks on the same level. *)
|
||||||
|
|
||||||
|
open Protocol
|
||||||
|
open Alpha_context
|
||||||
|
|
||||||
|
(****************************************************************)
|
||||||
|
(* Utility functions *)
|
||||||
|
(****************************************************************)
|
||||||
|
|
||||||
|
let get_first_different_baker baker bakers =
|
||||||
|
return @@ List.find (fun baker' ->
|
||||||
|
Signature.Public_key_hash.(<>) baker baker')
|
||||||
|
bakers
|
||||||
|
|
||||||
|
let get_first_different_bakers ctxt =
|
||||||
|
Context.get_bakers ctxt >>=? fun bakers ->
|
||||||
|
let baker_1 = List.hd bakers in
|
||||||
|
get_first_different_baker baker_1 (List.tl bakers) >>=? fun baker_2 ->
|
||||||
|
return (baker_1, baker_2)
|
||||||
|
|
||||||
|
let get_first_different_endorsers ctxt =
|
||||||
|
Context.get_endorsers ctxt >>=? fun endorsers ->
|
||||||
|
let endorser_1 = (List.hd endorsers).delegate in
|
||||||
|
let endorser_2 = (List.hd (List.tl endorsers)).delegate in
|
||||||
|
return (endorser_1, endorser_2)
|
||||||
|
|
||||||
|
(** Bake two block at the same level using the same policy (i.e. same
|
||||||
|
baker) *)
|
||||||
|
let block_fork ?policy contracts b =
|
||||||
|
let (contract_a, contract_b) =
|
||||||
|
List.hd contracts, List.hd (List.tl contracts) in
|
||||||
|
Op.transaction (B b) contract_a contract_b Alpha_context.Tez.one_cent >>=? fun operation ->
|
||||||
|
Block.bake ?policy ~operation b >>=? fun blk_a ->
|
||||||
|
Block.bake ?policy b >>=? fun blk_b ->
|
||||||
|
return (blk_a, blk_b)
|
||||||
|
|
||||||
|
(****************************************************************)
|
||||||
|
(* Tests *)
|
||||||
|
(****************************************************************)
|
||||||
|
|
||||||
|
(** Simple scenario where two blocks are baked by a same baker and
|
||||||
|
exposed by a double baking evidence operation *)
|
||||||
|
let valid_double_baking_evidence () =
|
||||||
|
Context.init 2 >>=? fun (b, contracts) ->
|
||||||
|
|
||||||
|
Context.get_bakers (B b) >>=? fun bakers ->
|
||||||
|
let priority_0_baker = List.hd bakers in
|
||||||
|
|
||||||
|
block_fork ~policy:(By_priority 0) contracts b >>=? fun (blk_a, blk_b) ->
|
||||||
|
|
||||||
|
Op.double_baking (B blk_a) blk_a.header blk_b.header >>=? fun operation ->
|
||||||
|
Block.bake ~policy:(Excluding [ priority_0_baker ]) ~operation blk_a >>=? fun blk ->
|
||||||
|
|
||||||
|
(* Check that the frozen deposit, the fees and rewards are removed *)
|
||||||
|
iter_s (fun kind ->
|
||||||
|
let contract = Alpha_context.Contract.implicit_contract priority_0_baker in
|
||||||
|
Assert.balance_is ~loc:__LOC__ (B blk) contract ~kind Tez.zero)
|
||||||
|
[ Deposit ; Fees ; Rewards ]
|
||||||
|
|
||||||
|
(****************************************************************)
|
||||||
|
(* The following test scenarios are supposed to raise errors. *)
|
||||||
|
(****************************************************************)
|
||||||
|
|
||||||
|
(** Check that a double baking operation fails if it exposes the same two blocks *)
|
||||||
|
let same_blocks () =
|
||||||
|
Context.init 2 >>=? fun (b, _contracts) ->
|
||||||
|
Block.bake b >>=? fun ba ->
|
||||||
|
Op.double_baking (B ba) ba.header ba.header >>=? fun operation ->
|
||||||
|
Block.bake ~operation ba >>= fun res ->
|
||||||
|
Assert.proto_error ~loc:__LOC__ res begin function
|
||||||
|
| Apply.Invalid_double_baking_evidence _ -> true
|
||||||
|
| _ -> false end >>=? fun () ->
|
||||||
|
return_unit
|
||||||
|
|
||||||
|
(** Check that a double baking operation exposing two blocks with
|
||||||
|
different levels fails *)
|
||||||
|
let different_levels () =
|
||||||
|
Context.init 2 >>=? fun (b, contracts) ->
|
||||||
|
|
||||||
|
block_fork ~policy:(By_priority 0) contracts b >>=? fun (blk_a, blk_b) ->
|
||||||
|
|
||||||
|
Block.bake blk_b >>=? fun blk_b_2 ->
|
||||||
|
|
||||||
|
Op.double_baking (B blk_a) blk_a.header blk_b_2.header >>=? fun operation ->
|
||||||
|
Block.bake ~operation blk_a >>= fun res ->
|
||||||
|
Assert.proto_error ~loc:__LOC__ res begin function
|
||||||
|
| Apply.Invalid_double_baking_evidence _ -> true
|
||||||
|
| _ -> false end
|
||||||
|
|
||||||
|
(** Check that a double baking operation exposing two yet to be baked
|
||||||
|
blocks fails *)
|
||||||
|
let too_early_double_baking_evidence () =
|
||||||
|
Context.init 2 >>=? fun (b, contracts) ->
|
||||||
|
block_fork ~policy:(By_priority 0) contracts b >>=? fun (blk_a, blk_b) ->
|
||||||
|
|
||||||
|
Op.double_baking (B b) blk_a.header blk_b.header >>=? fun operation ->
|
||||||
|
Block.bake ~operation b >>= fun res ->
|
||||||
|
Assert.proto_error ~loc:__LOC__ res begin function
|
||||||
|
| Apply.Too_early_double_baking_evidence _ -> true
|
||||||
|
| _ -> false end
|
||||||
|
|
||||||
|
(** Check that after [preserved_cycles + 1], it is not possible to
|
||||||
|
create a double baking operation anymore *)
|
||||||
|
let too_late_double_baking_evidence () =
|
||||||
|
Context.init 2 >>=? fun (b, contracts) ->
|
||||||
|
Context.get_constants (B b)
|
||||||
|
>>=? fun Constants.{ parametric = { preserved_cycles ; _ } ; _ } ->
|
||||||
|
|
||||||
|
block_fork ~policy:(By_priority 0) contracts b >>=? fun (blk_a, blk_b) ->
|
||||||
|
|
||||||
|
fold_left_s (fun blk _ -> Block.bake_until_cycle_end blk)
|
||||||
|
blk_a (1 -- (preserved_cycles + 1)) >>=? fun blk ->
|
||||||
|
|
||||||
|
Op.double_baking (B blk) blk_a.header blk_b.header >>=? fun operation ->
|
||||||
|
Block.bake ~operation blk >>= fun res ->
|
||||||
|
Assert.proto_error ~loc:__LOC__ res begin function
|
||||||
|
| Apply.Outdated_double_baking_evidence _ -> true
|
||||||
|
| _ -> false end
|
||||||
|
|
||||||
|
(** Check that an invalid double baking evidence that exposes two block
|
||||||
|
baking with same level made by different bakers fails *)
|
||||||
|
let different_delegates () =
|
||||||
|
Context.init 2 >>=? fun (b, _) ->
|
||||||
|
|
||||||
|
get_first_different_bakers (B b) >>=? fun (baker_1, baker_2) ->
|
||||||
|
Block.bake ~policy:(By_account baker_1) b >>=? fun blk_a ->
|
||||||
|
Block.bake ~policy:(By_account baker_2) b >>=? fun blk_b ->
|
||||||
|
|
||||||
|
Op.double_baking (B blk_a) blk_a.header blk_b.header >>=? fun operation ->
|
||||||
|
Block.bake ~operation blk_a >>= fun e ->
|
||||||
|
Assert.proto_error ~loc:__LOC__ e begin function
|
||||||
|
| Apply.Inconsistent_double_baking_evidence _ -> true
|
||||||
|
| _ -> false end
|
||||||
|
|
||||||
|
let wrong_signer () =
|
||||||
|
(* Baker_2 bakes a block but baker signs it. *)
|
||||||
|
let header_custom_signer baker baker_2 b =
|
||||||
|
Block.Forge.forge_header ~policy:(By_account baker_2) b >>=? fun header ->
|
||||||
|
Block.Forge.set_baker baker header |>
|
||||||
|
Block.Forge.sign_header
|
||||||
|
in
|
||||||
|
|
||||||
|
Context.init 2 >>=? fun (b, _) ->
|
||||||
|
get_first_different_bakers (B b) >>=? fun (baker_1, baker_2) ->
|
||||||
|
Block.bake ~policy:(By_account baker_1) b >>=? fun blk_a ->
|
||||||
|
header_custom_signer baker_1 baker_2 b >>=? fun header_b ->
|
||||||
|
Op.double_baking (B blk_a) blk_a.header header_b >>=? fun operation ->
|
||||||
|
Block.bake ~operation blk_a >>= fun e ->
|
||||||
|
Assert.proto_error ~loc:__LOC__ e begin function
|
||||||
|
| Baking.Invalid_block_signature _ -> true
|
||||||
|
| _ -> false end
|
||||||
|
|
||||||
|
let tests = [
|
||||||
|
Test.tztest "valid double baking evidence" `Quick valid_double_baking_evidence ;
|
||||||
|
|
||||||
|
(* Should fail*)
|
||||||
|
Test.tztest "same blocks" `Quick same_blocks ;
|
||||||
|
Test.tztest "different levels" `Quick different_levels ;
|
||||||
|
Test.tztest "too early double baking evidence" `Quick too_early_double_baking_evidence ;
|
||||||
|
Test.tztest "too late double baking evidence" `Quick too_late_double_baking_evidence ;
|
||||||
|
Test.tztest "different delegates" `Quick different_delegates ;
|
||||||
|
Test.tztest "wrong delegate" `Quick wrong_signer ;
|
||||||
|
]
|
204
vendors/ligo-utils/tezos-protocol-alpha/test/double_endorsement.ml
vendored
Normal file
204
vendors/ligo-utils/tezos-protocol-alpha/test/double_endorsement.ml
vendored
Normal file
@ -0,0 +1,204 @@
|
|||||||
|
(*****************************************************************************)
|
||||||
|
(* *)
|
||||||
|
(* Open Source License *)
|
||||||
|
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
|
||||||
|
(* *)
|
||||||
|
(* Permission is hereby granted, free of charge, to any person obtaining a *)
|
||||||
|
(* copy of this software and associated documentation files (the "Software"),*)
|
||||||
|
(* to deal in the Software without restriction, including without limitation *)
|
||||||
|
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
|
||||||
|
(* and/or sell copies of the Software, and to permit persons to whom the *)
|
||||||
|
(* Software is furnished to do so, subject to the following conditions: *)
|
||||||
|
(* *)
|
||||||
|
(* The above copyright notice and this permission notice shall be included *)
|
||||||
|
(* in all copies or substantial portions of the Software. *)
|
||||||
|
(* *)
|
||||||
|
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
|
||||||
|
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
|
||||||
|
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
|
||||||
|
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
|
||||||
|
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
|
||||||
|
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
|
||||||
|
(* DEALINGS IN THE SOFTWARE. *)
|
||||||
|
(* *)
|
||||||
|
(*****************************************************************************)
|
||||||
|
|
||||||
|
(** Double endorsement evidence operation may happen when an endorser
|
||||||
|
endorsed two different blocks on the same level. *)
|
||||||
|
|
||||||
|
open Protocol
|
||||||
|
open Alpha_context
|
||||||
|
|
||||||
|
(****************************************************************)
|
||||||
|
(* Utility functions *)
|
||||||
|
(****************************************************************)
|
||||||
|
|
||||||
|
let get_first_different_baker baker bakers =
|
||||||
|
return @@ List.find (fun baker' ->
|
||||||
|
Signature.Public_key_hash.(<>) baker baker')
|
||||||
|
bakers
|
||||||
|
|
||||||
|
let get_first_different_bakers ctxt =
|
||||||
|
Context.get_bakers ctxt >>=? fun bakers ->
|
||||||
|
let baker_1 = List.hd bakers in
|
||||||
|
get_first_different_baker baker_1 (List.tl bakers) >>=? fun baker_2 ->
|
||||||
|
return (baker_1, baker_2)
|
||||||
|
|
||||||
|
let get_first_different_endorsers ctxt =
|
||||||
|
Context.get_endorsers ctxt >>=? fun endorsers ->
|
||||||
|
let endorser_1 = (List.hd endorsers) in
|
||||||
|
let endorser_2 = (List.hd (List.tl endorsers)) in
|
||||||
|
return (endorser_1, endorser_2)
|
||||||
|
|
||||||
|
let block_fork b =
|
||||||
|
get_first_different_bakers (B b) >>=? fun (baker_1, baker_2) ->
|
||||||
|
Block.bake ~policy:(By_account baker_1) b >>=? fun blk_a ->
|
||||||
|
Block.bake ~policy:(By_account baker_2) b >>=? fun blk_b ->
|
||||||
|
return (blk_a, blk_b)
|
||||||
|
|
||||||
|
(****************************************************************)
|
||||||
|
(* Tests *)
|
||||||
|
(****************************************************************)
|
||||||
|
|
||||||
|
(** Simple scenario where two endorsements are made from the same
|
||||||
|
delegate and exposed by a double_endorsement operation. Also verify
|
||||||
|
that punishment is operated. *)
|
||||||
|
let valid_double_endorsement_evidence () =
|
||||||
|
Context.init 2 >>=? fun (b, _) ->
|
||||||
|
|
||||||
|
block_fork b >>=? fun (blk_a, blk_b) ->
|
||||||
|
|
||||||
|
Context.get_endorser (B blk_a) >>=? fun (delegate, _slots) ->
|
||||||
|
Op.endorsement ~delegate (B blk_a) () >>=? fun endorsement_a ->
|
||||||
|
Op.endorsement ~delegate (B blk_b) () >>=? fun endorsement_b ->
|
||||||
|
Block.bake ~operations:[Operation.pack endorsement_a] blk_a >>=? fun blk_a ->
|
||||||
|
(* Block.bake ~operations:[endorsement_b] blk_b >>=? fun _ -> *)
|
||||||
|
|
||||||
|
Op.double_endorsement (B blk_a) endorsement_a endorsement_b >>=? fun operation ->
|
||||||
|
|
||||||
|
(* Bake with someone different than the bad endorser *)
|
||||||
|
Context.get_bakers (B blk_a) >>=? fun bakers ->
|
||||||
|
get_first_different_baker delegate bakers >>=? fun baker ->
|
||||||
|
|
||||||
|
Block.bake ~policy:(By_account baker) ~operation blk_a >>=? fun blk ->
|
||||||
|
|
||||||
|
(* Check that the frozen deposit, the fees and rewards are removed *)
|
||||||
|
iter_s (fun kind ->
|
||||||
|
let contract = Alpha_context.Contract.implicit_contract delegate in
|
||||||
|
Assert.balance_is ~loc:__LOC__ (B blk) contract ~kind Tez.zero)
|
||||||
|
[ Deposit ; Fees ; Rewards ]
|
||||||
|
|
||||||
|
(****************************************************************)
|
||||||
|
(* The following test scenarios are supposed to raise errors. *)
|
||||||
|
(****************************************************************)
|
||||||
|
|
||||||
|
(** Check that an invalid double endorsement operation that exposes a valid
|
||||||
|
endorsement fails. *)
|
||||||
|
let invalid_double_endorsement () =
|
||||||
|
Context.init 10 >>=? fun (b, _) ->
|
||||||
|
Block.bake b >>=? fun b ->
|
||||||
|
|
||||||
|
Op.endorsement (B b) () >>=? fun endorsement ->
|
||||||
|
Block.bake ~operation:(Operation.pack endorsement) b >>=? fun b ->
|
||||||
|
|
||||||
|
Op.double_endorsement (B b) endorsement endorsement >>=? fun operation ->
|
||||||
|
Block.bake ~operation b >>= fun res ->
|
||||||
|
Assert.proto_error ~loc:__LOC__ res begin function
|
||||||
|
| Apply.Invalid_double_endorsement_evidence -> true
|
||||||
|
| _ -> false end
|
||||||
|
|
||||||
|
(** Check that a double endorsement added at the same time as a double
|
||||||
|
endorsement operation fails. *)
|
||||||
|
let too_early_double_endorsement_evidence () =
|
||||||
|
Context.init 2 >>=? fun (b, _) ->
|
||||||
|
block_fork b >>=? fun (blk_a, blk_b) ->
|
||||||
|
|
||||||
|
Context.get_endorser (B blk_a) >>=? fun (delegate, _slots) ->
|
||||||
|
Op.endorsement ~delegate (B blk_a) () >>=? fun endorsement_a ->
|
||||||
|
Op.endorsement ~delegate (B blk_b) () >>=? fun endorsement_b ->
|
||||||
|
|
||||||
|
Op.double_endorsement (B b) endorsement_a endorsement_b >>=? fun operation ->
|
||||||
|
Block.bake ~operation b >>= fun res ->
|
||||||
|
Assert.proto_error ~loc:__LOC__ res begin function
|
||||||
|
| Apply.Too_early_double_endorsement_evidence _ -> true
|
||||||
|
| _ -> false end
|
||||||
|
|
||||||
|
(** Check that after [preserved_cycles + 1], it is not possible
|
||||||
|
to create a double_endorsement anymore. *)
|
||||||
|
let too_late_double_endorsement_evidence () =
|
||||||
|
Context.init 2 >>=? fun (b, _) ->
|
||||||
|
Context.get_constants (B b)
|
||||||
|
>>=? fun Constants.{ parametric = { preserved_cycles ; _ } ; _ } ->
|
||||||
|
|
||||||
|
block_fork b >>=? fun (blk_a, blk_b) ->
|
||||||
|
|
||||||
|
Context.get_endorser (B blk_a) >>=? fun (delegate, _slots) ->
|
||||||
|
Op.endorsement ~delegate (B blk_a) () >>=? fun endorsement_a ->
|
||||||
|
Op.endorsement ~delegate (B blk_b) () >>=? fun endorsement_b ->
|
||||||
|
|
||||||
|
fold_left_s (fun blk _ -> Block.bake_until_cycle_end blk)
|
||||||
|
blk_a (1 -- (preserved_cycles + 1)) >>=? fun blk ->
|
||||||
|
|
||||||
|
Op.double_endorsement (B blk) endorsement_a endorsement_b >>=? fun operation ->
|
||||||
|
Block.bake ~operation blk >>= fun res ->
|
||||||
|
Assert.proto_error ~loc:__LOC__ res begin function
|
||||||
|
| Apply.Outdated_double_endorsement_evidence _ -> true
|
||||||
|
| _ -> false end
|
||||||
|
|
||||||
|
(** Check that an invalid double endorsement evidence that expose two
|
||||||
|
endorsements made by two different endorsers fails. *)
|
||||||
|
let different_delegates () =
|
||||||
|
Context.init 2 >>=? fun (b, _) ->
|
||||||
|
|
||||||
|
Block.bake b >>=? fun b ->
|
||||||
|
block_fork b >>=? fun (blk_a, blk_b) ->
|
||||||
|
Context.get_endorser (B blk_a) >>=? fun (endorser_a, _a_slots) ->
|
||||||
|
get_first_different_endorsers (B blk_b) >>=? fun (endorser_b1c, endorser_b2c) ->
|
||||||
|
let endorser_b =
|
||||||
|
if Signature.Public_key_hash.(=) endorser_a endorser_b1c.delegate
|
||||||
|
then endorser_b2c.delegate
|
||||||
|
else endorser_b1c.delegate
|
||||||
|
in
|
||||||
|
|
||||||
|
Op.endorsement ~delegate:endorser_a (B blk_a) () >>=? fun e_a ->
|
||||||
|
Op.endorsement ~delegate:endorser_b (B blk_b) () >>=? fun e_b ->
|
||||||
|
Block.bake ~operation:(Operation.pack e_b) blk_b >>=? fun _ ->
|
||||||
|
Op.double_endorsement (B blk_b) e_a e_b >>=? fun operation ->
|
||||||
|
Block.bake ~operation blk_b >>= fun res ->
|
||||||
|
Assert.proto_error ~loc:__LOC__ res begin function
|
||||||
|
| Apply.Inconsistent_double_endorsement_evidence _ -> true
|
||||||
|
| _ -> false end
|
||||||
|
|
||||||
|
(** Check that a double endorsement evidence that exposes a ill-formed
|
||||||
|
endorsement fails. *)
|
||||||
|
let wrong_delegate () =
|
||||||
|
Context.init ~endorsers_per_block:1 2 >>=? fun (b, contracts) ->
|
||||||
|
Error_monad.map_s (Context.Contract.manager (B b)) contracts >>=? fun accounts ->
|
||||||
|
let pkh1 = (List.nth accounts 0).Account.pkh in
|
||||||
|
let pkh2 = (List.nth accounts 1).Account.pkh in
|
||||||
|
|
||||||
|
block_fork b >>=? fun (blk_a, blk_b) ->
|
||||||
|
Context.get_endorser (B blk_a) >>=? fun (endorser_a, _a_slots) ->
|
||||||
|
Op.endorsement ~delegate:endorser_a (B blk_a) () >>=? fun endorsement_a ->
|
||||||
|
Context.get_endorser (B blk_b) >>=? fun (endorser_b, _b_slots) ->
|
||||||
|
let delegate =
|
||||||
|
if Signature.Public_key_hash.equal pkh1 endorser_b
|
||||||
|
then pkh2
|
||||||
|
else pkh1
|
||||||
|
in
|
||||||
|
Op.endorsement ~delegate (B blk_b) () >>=? fun endorsement_b ->
|
||||||
|
|
||||||
|
Op.double_endorsement (B blk_b) endorsement_a endorsement_b >>=? fun operation ->
|
||||||
|
Block.bake ~operation blk_b >>= fun e ->
|
||||||
|
Assert.proto_error ~loc:__LOC__ e begin function
|
||||||
|
| Baking.Unexpected_endorsement -> true
|
||||||
|
| _ -> false end
|
||||||
|
|
||||||
|
let tests = [
|
||||||
|
Test.tztest "valid double endorsement evidence" `Quick valid_double_endorsement_evidence ;
|
||||||
|
Test.tztest "invalid double endorsement evidence" `Quick invalid_double_endorsement ;
|
||||||
|
Test.tztest "too early double endorsement evidence" `Quick too_early_double_endorsement_evidence ;
|
||||||
|
Test.tztest "too late double endorsement evidence" `Quick too_late_double_endorsement_evidence ;
|
||||||
|
Test.tztest "different delegates" `Quick different_delegates ;
|
||||||
|
Test.tztest "wrong delegate" `Quick wrong_delegate ;
|
||||||
|
]
|
46
vendors/ligo-utils/tezos-protocol-alpha/test/dune
vendored
Normal file
46
vendors/ligo-utils/tezos-protocol-alpha/test/dune
vendored
Normal file
@ -0,0 +1,46 @@
|
|||||||
|
(executable
|
||||||
|
(name main)
|
||||||
|
(libraries tezos-base
|
||||||
|
tezos-micheline
|
||||||
|
tezos-protocol-environment
|
||||||
|
alcotest-lwt
|
||||||
|
tezos-005-PsBabyM1-test-helpers
|
||||||
|
tezos-stdlib-unix
|
||||||
|
bip39
|
||||||
|
tezos-protocol-005-PsBabyM1-parameters)
|
||||||
|
(flags (:standard -open Tezos_base__TzPervasives
|
||||||
|
-open Tezos_micheline
|
||||||
|
-open Tezos_protocol_005_PsBabyM1
|
||||||
|
-open Tezos_005_PsBabyM1_test_helpers
|
||||||
|
)))
|
||||||
|
|
||||||
|
(alias
|
||||||
|
(name buildtest)
|
||||||
|
(package tezos-protocol-005-PsBabyM1-tests)
|
||||||
|
(deps main.exe))
|
||||||
|
|
||||||
|
(rule
|
||||||
|
(copy %{lib:tezos-protocol-005-PsBabyM1-parameters:test-parameters.json}
|
||||||
|
protocol_parameters.json))
|
||||||
|
|
||||||
|
; runs only the `Quick tests
|
||||||
|
(alias
|
||||||
|
(name runtest_proto_005_PsBabyM1)
|
||||||
|
(package tezos-protocol-005-PsBabyM1-tests)
|
||||||
|
(action (run %{exe:main.exe} -v -q)))
|
||||||
|
|
||||||
|
; runs both `Quick and `Slow tests
|
||||||
|
(alias
|
||||||
|
(name runtest_slow)
|
||||||
|
(package tezos-protocol-005-PsBabyM1-tests)
|
||||||
|
(action (run %{exe:main.exe} -v)))
|
||||||
|
|
||||||
|
(alias
|
||||||
|
(name runtest)
|
||||||
|
(package tezos-protocol-005-PsBabyM1-tests)
|
||||||
|
(deps (alias runtest_proto_005_PsBabyM1)))
|
||||||
|
|
||||||
|
(alias
|
||||||
|
(name runtest_lint)
|
||||||
|
(deps (glob_files *.ml{,i}))
|
||||||
|
(action (run %{lib:tezos-tooling:lint.sh} %{deps})))
|
441
vendors/ligo-utils/tezos-protocol-alpha/test/endorsement.ml
vendored
Normal file
441
vendors/ligo-utils/tezos-protocol-alpha/test/endorsement.ml
vendored
Normal file
@ -0,0 +1,441 @@
|
|||||||
|
(*****************************************************************************)
|
||||||
|
(* *)
|
||||||
|
(* Open Source License *)
|
||||||
|
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
|
||||||
|
(* *)
|
||||||
|
(* Permission is hereby granted, free of charge, to any person obtaining a *)
|
||||||
|
(* copy of this software and associated documentation files (the "Software"),*)
|
||||||
|
(* to deal in the Software without restriction, including without limitation *)
|
||||||
|
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
|
||||||
|
(* and/or sell copies of the Software, and to permit persons to whom the *)
|
||||||
|
(* Software is furnished to do so, subject to the following conditions: *)
|
||||||
|
(* *)
|
||||||
|
(* The above copyright notice and this permission notice shall be included *)
|
||||||
|
(* in all copies or substantial portions of the Software. *)
|
||||||
|
(* *)
|
||||||
|
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
|
||||||
|
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
|
||||||
|
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
|
||||||
|
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
|
||||||
|
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
|
||||||
|
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
|
||||||
|
(* DEALINGS IN THE SOFTWARE. *)
|
||||||
|
(* *)
|
||||||
|
(*****************************************************************************)
|
||||||
|
|
||||||
|
(** Endorsing a block adds an extra layer of confidence to the Tezos's
|
||||||
|
PoS algorithm. The block endorsing operation must be included in
|
||||||
|
the following block. Each endorser possess a number of slots
|
||||||
|
corresponding to their priority. After [preserved_cycles], a reward
|
||||||
|
is given to the endorser. This reward depends on the priority of
|
||||||
|
the block that contains the endorsements. *)
|
||||||
|
|
||||||
|
open Protocol
|
||||||
|
open Alpha_context
|
||||||
|
open Test_utils
|
||||||
|
open Test_tez
|
||||||
|
|
||||||
|
(****************************************************************)
|
||||||
|
(* Utility functions *)
|
||||||
|
(****************************************************************)
|
||||||
|
|
||||||
|
let get_expected_reward ctxt ~priority ~baker ~endorsing_power =
|
||||||
|
begin if baker then
|
||||||
|
Context.get_baking_reward ctxt ~priority ~endorsing_power
|
||||||
|
else
|
||||||
|
return (Test_tez.Tez.of_int 0)
|
||||||
|
end >>=? fun baking_reward ->
|
||||||
|
Context.get_endorsing_reward ctxt ~priority ~endorsing_power >>=? fun endorsing_reward ->
|
||||||
|
Test_tez.Tez.(endorsing_reward +? baking_reward) >>?= fun reward -> return reward
|
||||||
|
|
||||||
|
let get_expected_deposit ctxt ~baker ~endorsing_power =
|
||||||
|
Context.get_constants ctxt >>=? fun Constants.
|
||||||
|
{ parametric = { endorsement_security_deposit ;
|
||||||
|
block_security_deposit ; _ } ; _ } ->
|
||||||
|
let open Environment in
|
||||||
|
let open Tez in
|
||||||
|
let baking_deposit = if baker then block_security_deposit else of_int 0 in
|
||||||
|
endorsement_security_deposit *? (Int64.of_int endorsing_power) >>?= fun endorsement_deposit ->
|
||||||
|
endorsement_deposit +? baking_deposit >>?= fun deposit -> return deposit
|
||||||
|
|
||||||
|
(* [baker] is true if the [pkh] has also baked the current block, in
|
||||||
|
which case correspoding deposit and reward should be ajusted *)
|
||||||
|
let assert_endorser_balance_consistency ~loc ?(priority=0) ?(baker=false) ~endorsing_power
|
||||||
|
ctxt pkh initial_balance =
|
||||||
|
let contract = Contract.implicit_contract pkh in
|
||||||
|
get_expected_reward ctxt ~priority ~baker ~endorsing_power >>=? fun reward ->
|
||||||
|
get_expected_deposit ctxt ~baker ~endorsing_power >>=? fun deposit ->
|
||||||
|
|
||||||
|
Assert.balance_was_debited ~loc ctxt contract initial_balance deposit >>=? fun () ->
|
||||||
|
Context.Contract.balance ~kind:Rewards ctxt contract >>=? fun reward_balance ->
|
||||||
|
Assert.equal_tez ~loc reward_balance reward >>=? fun () ->
|
||||||
|
Context.Contract.balance ~kind:Deposit ctxt contract >>=? fun deposit_balance ->
|
||||||
|
Assert.equal_tez ~loc deposit_balance deposit
|
||||||
|
|
||||||
|
let delegates_with_slots endorsers =
|
||||||
|
List.map (fun (endorser: Delegate_services.Endorsing_rights.t) ->
|
||||||
|
endorser.delegate)
|
||||||
|
endorsers
|
||||||
|
|
||||||
|
let endorsing_power endorsers =
|
||||||
|
List.fold_left
|
||||||
|
(fun sum (endorser: Delegate_services.Endorsing_rights.t) ->
|
||||||
|
sum + List.length endorser.slots)
|
||||||
|
0 endorsers
|
||||||
|
|
||||||
|
(****************************************************************)
|
||||||
|
(* Tests *)
|
||||||
|
(****************************************************************)
|
||||||
|
|
||||||
|
(** Apply a single endorsement from the slot 0 endorser *)
|
||||||
|
let simple_endorsement () =
|
||||||
|
Context.init 5 >>=? fun (b, _) ->
|
||||||
|
Context.get_endorser (B b) >>=? fun (delegate, slots) ->
|
||||||
|
Op.endorsement ~delegate (B b) () >>=? fun op ->
|
||||||
|
Context.Contract.balance (B b) (Contract.implicit_contract delegate) >>=? fun initial_balance ->
|
||||||
|
let policy = Block.Excluding [ delegate ] in
|
||||||
|
Block.get_next_baker ~policy b >>=? fun (_, priority, _) ->
|
||||||
|
Block.bake
|
||||||
|
~policy
|
||||||
|
~operations:[Operation.pack op]
|
||||||
|
b >>=? fun b2 ->
|
||||||
|
assert_endorser_balance_consistency ~loc:__LOC__
|
||||||
|
(B b2) ~priority ~endorsing_power:(List.length slots)
|
||||||
|
delegate initial_balance
|
||||||
|
|
||||||
|
(** Apply a maximum number of endorsements. An endorser can be
|
||||||
|
selected twice. *)
|
||||||
|
let max_endorsement () =
|
||||||
|
let endorsers_per_block = 16 in
|
||||||
|
Context.init ~endorsers_per_block 32 >>=? fun (b, _) ->
|
||||||
|
|
||||||
|
Context.get_endorsers (B b) >>=? fun endorsers ->
|
||||||
|
Assert.equal_int ~loc:__LOC__
|
||||||
|
(List.length
|
||||||
|
(List.concat
|
||||||
|
(List.map
|
||||||
|
(fun { Alpha_services.Delegate.Endorsing_rights.slots ; _ } -> slots)
|
||||||
|
endorsers)))
|
||||||
|
endorsers_per_block >>=? fun () ->
|
||||||
|
|
||||||
|
fold_left_s (fun (delegates, ops, balances)
|
||||||
|
(endorser : Alpha_services.Delegate.Endorsing_rights.t) ->
|
||||||
|
let delegate = endorser.delegate in
|
||||||
|
Context.Contract.balance (B b) (Contract.implicit_contract delegate) >>=? fun balance ->
|
||||||
|
Op.endorsement ~delegate (B b) () >>=? fun op ->
|
||||||
|
return (delegate :: delegates,
|
||||||
|
Operation.pack op :: ops,
|
||||||
|
(List.length endorser.slots, balance) :: balances)
|
||||||
|
)
|
||||||
|
([], [], [])
|
||||||
|
endorsers >>=? fun (delegates, ops, previous_balances) ->
|
||||||
|
|
||||||
|
Block.bake ~policy:(Excluding delegates) ~operations:(List.rev ops) b >>=? fun b ->
|
||||||
|
|
||||||
|
(* One account can endorse more than one time per level, we must
|
||||||
|
check that the bonds are summed up *)
|
||||||
|
iter_s (fun (endorser_account, (endorsing_power, previous_balance)) ->
|
||||||
|
assert_endorser_balance_consistency ~loc:__LOC__
|
||||||
|
(B b) ~endorsing_power endorser_account previous_balance
|
||||||
|
) (List.combine delegates previous_balances)
|
||||||
|
|
||||||
|
(** Check every that endorsers' balances are consistent with different priorities *)
|
||||||
|
let consistent_priorities () =
|
||||||
|
let priorities = 0 -- 64 in
|
||||||
|
Context.init 64 >>=? fun (b, _) ->
|
||||||
|
|
||||||
|
fold_left_s (fun (b, used_pkhes) priority ->
|
||||||
|
(* Choose an endorser that has not baked nor endorsed before *)
|
||||||
|
Context.get_endorsers (B b) >>=? fun endorsers ->
|
||||||
|
let endorser =
|
||||||
|
List.find_opt
|
||||||
|
(fun (e: Delegate_services.Endorsing_rights.t) ->
|
||||||
|
not (Signature.Public_key_hash.Set.mem e.delegate used_pkhes)
|
||||||
|
)
|
||||||
|
endorsers in
|
||||||
|
match endorser with
|
||||||
|
| None -> return (b, used_pkhes) (* not enough fresh endorsers; we "stop" *)
|
||||||
|
| Some endorser ->
|
||||||
|
|
||||||
|
Context.Contract.balance (B b)
|
||||||
|
(Contract.implicit_contract endorser.delegate) >>=? fun balance ->
|
||||||
|
|
||||||
|
Op.endorsement ~delegate:endorser.delegate (B b) () >>=? fun operation ->
|
||||||
|
let operation = Operation.pack operation in
|
||||||
|
|
||||||
|
Block.get_next_baker ~policy:(By_priority priority) b >>=? fun (baker, _, _) ->
|
||||||
|
let used_pkhes = Signature.Public_key_hash.Set.add baker used_pkhes in
|
||||||
|
let used_pkhes = Signature.Public_key_hash.Set.add endorser.delegate used_pkhes in
|
||||||
|
|
||||||
|
(* Bake with a specific priority *)
|
||||||
|
Block.bake ~policy:(By_priority priority) ~operation b >>=? fun b ->
|
||||||
|
|
||||||
|
let is_baker = Signature.Public_key_hash.(baker = endorser.delegate) in
|
||||||
|
|
||||||
|
assert_endorser_balance_consistency ~loc:__LOC__ ~priority ~baker:is_baker (B b)
|
||||||
|
~endorsing_power:(List.length endorser.slots)
|
||||||
|
endorser.delegate balance >>=? fun () ->
|
||||||
|
|
||||||
|
return (b, used_pkhes)
|
||||||
|
) (b, Signature.Public_key_hash.Set.empty) priorities >>=? fun _b -> return_unit
|
||||||
|
|
||||||
|
(** Check that after [preserved_cycles] cycles the endorser gets his reward *)
|
||||||
|
let reward_retrieval () =
|
||||||
|
Context.init 5 >>=? fun (b, _) ->
|
||||||
|
Context.get_constants (B b) >>=? fun Constants.
|
||||||
|
{ parametric = { preserved_cycles ; _ } ; _ } ->
|
||||||
|
Context.get_endorser (B b) >>=? fun (endorser, slots) ->
|
||||||
|
Context.Contract.balance (B b) (Contract.implicit_contract endorser) >>=? fun balance ->
|
||||||
|
Op.endorsement ~delegate:endorser (B b) () >>=? fun operation ->
|
||||||
|
let operation = Operation.pack operation in
|
||||||
|
let policy = Block.Excluding [ endorser ] in
|
||||||
|
Block.get_next_baker ~policy b >>=? fun (_, priority, _) ->
|
||||||
|
Block.bake ~policy ~operation b >>=? fun b ->
|
||||||
|
(* Bake (preserved_cycles + 1) cycles *)
|
||||||
|
fold_left_s (fun b _ ->
|
||||||
|
Block.bake_until_cycle_end ~policy:(Excluding [ endorser ]) b
|
||||||
|
) b (0 -- preserved_cycles) >>=? fun b ->
|
||||||
|
get_expected_reward (B b) ~priority ~baker:false ~endorsing_power:(List.length slots) >>=? fun reward ->
|
||||||
|
Assert.balance_was_credited ~loc:__LOC__ (B b) (Contract.implicit_contract endorser) balance reward
|
||||||
|
|
||||||
|
(** Check that after [preserved_cycles] cycles endorsers get their
|
||||||
|
reward. Two endorsers are used and they endorse in different
|
||||||
|
cycles. *)
|
||||||
|
let reward_retrieval_two_endorsers () =
|
||||||
|
Context.init 5 >>=? fun (b, _) ->
|
||||||
|
Context.get_constants (B b) >>=? fun Constants.
|
||||||
|
{ parametric = { preserved_cycles ; endorsement_reward ; endorsement_security_deposit ; _ } ; _ } ->
|
||||||
|
Context.get_endorsers (B b) >>=? fun endorsers ->
|
||||||
|
let endorser1 = List.hd endorsers in
|
||||||
|
let endorser2 = List.hd (List.tl endorsers) in
|
||||||
|
|
||||||
|
Context.Contract.balance (B b) (Contract.implicit_contract endorser1.delegate) >>=? fun balance1 ->
|
||||||
|
Context.Contract.balance (B b) (Contract.implicit_contract endorser2.delegate) >>=? fun balance2 ->
|
||||||
|
Lwt.return Tez.(endorsement_security_deposit *? Int64.of_int (List.length endorser1.slots)) >>=? fun security_deposit1 ->
|
||||||
|
|
||||||
|
(* endorser1 endorses the genesis block in cycle 0 *)
|
||||||
|
Op.endorsement ~delegate:endorser1.delegate (B b) () >>=? fun operation1 ->
|
||||||
|
|
||||||
|
let policy = Block.Excluding [ endorser1.delegate ; endorser2.delegate ] in
|
||||||
|
Block.get_next_baker ~policy b >>=? fun (_, priority, _) ->
|
||||||
|
Tez.(endorsement_reward /? Int64.(succ (of_int priority))) >>?= fun reward_per_slot ->
|
||||||
|
Lwt.return Tez.(reward_per_slot *? Int64.of_int (List.length endorser1.slots)) >>=? fun reward1 ->
|
||||||
|
|
||||||
|
(* bake next block, include endorsement of endorser1 *)
|
||||||
|
Block.bake ~policy ~operation:(Operation.pack operation1) b >>=? fun b ->
|
||||||
|
Assert.balance_was_debited ~loc:__LOC__ (B b) (Contract.implicit_contract endorser1.delegate) balance1 security_deposit1 >>=? fun () ->
|
||||||
|
Assert.balance_is ~loc:__LOC__ (B b) (Contract.implicit_contract endorser2.delegate) balance2 >>=? fun () ->
|
||||||
|
|
||||||
|
(* complete cycle 0 *)
|
||||||
|
Block.bake_until_cycle_end ~policy b >>=? fun b ->
|
||||||
|
Assert.balance_was_debited ~loc:__LOC__ (B b) (Contract.implicit_contract endorser1.delegate) balance1 security_deposit1 >>=? fun () ->
|
||||||
|
Assert.balance_is ~loc:__LOC__ (B b) (Contract.implicit_contract endorser2.delegate) balance2 >>=? fun () ->
|
||||||
|
|
||||||
|
(* get the slots of endorser2 for the current block *)
|
||||||
|
Context.get_endorsers (B b) >>=? fun endorsers ->
|
||||||
|
let same_endorser2 endorser =
|
||||||
|
Signature.Public_key_hash.(endorser.Delegate_services.Endorsing_rights.delegate = endorser2.delegate) in
|
||||||
|
let endorser2 = List.find same_endorser2 endorsers in (* No exception raised: in sandboxed mode endorsers do not change between blocks *)
|
||||||
|
Lwt.return Tez.(endorsement_security_deposit *? Int64.of_int (List.length endorser2.slots)) >>=? fun security_deposit2 ->
|
||||||
|
|
||||||
|
(* endorser2 endorses the last block in cycle 0 *)
|
||||||
|
Op.endorsement ~delegate:endorser2.delegate (B b) () >>=? fun operation2 ->
|
||||||
|
|
||||||
|
(* bake first block in cycle 1, include endorsement of endorser2 *)
|
||||||
|
Block.bake ~policy ~operation:(Operation.pack operation2) b >>=? fun b ->
|
||||||
|
|
||||||
|
let priority = b.header.protocol_data.contents.priority in
|
||||||
|
Tez.(endorsement_reward /? Int64.(succ (of_int priority))) >>?= fun reward_per_slot ->
|
||||||
|
Lwt.return Tez.(reward_per_slot *? Int64.of_int (List.length endorser2.slots)) >>=? fun reward2 ->
|
||||||
|
|
||||||
|
Assert.balance_was_debited ~loc:__LOC__ (B b) (Contract.implicit_contract endorser1.delegate) balance1 security_deposit1 >>=? fun () ->
|
||||||
|
Assert.balance_was_debited ~loc:__LOC__ (B b) (Contract.implicit_contract endorser2.delegate) balance2 security_deposit2 >>=? fun () ->
|
||||||
|
|
||||||
|
(* bake [preserved_cycles] cycles *)
|
||||||
|
fold_left_s (fun b _ ->
|
||||||
|
Assert.balance_was_debited ~loc:__LOC__ (B b) (Contract.implicit_contract endorser1.delegate) balance1 security_deposit1 >>=? fun () ->
|
||||||
|
Assert.balance_was_debited ~loc:__LOC__ (B b) (Contract.implicit_contract endorser2.delegate) balance2 security_deposit2 >>=? fun () ->
|
||||||
|
Block.bake_until_cycle_end ~policy b
|
||||||
|
) b (1 -- preserved_cycles) >>=? fun b ->
|
||||||
|
|
||||||
|
Assert.balance_was_credited ~loc:__LOC__ (B b) (Contract.implicit_contract endorser1.delegate) balance1 reward1 >>=? fun () ->
|
||||||
|
Assert.balance_was_debited ~loc:__LOC__ (B b) (Contract.implicit_contract endorser2.delegate) balance2 security_deposit2 >>=? fun () ->
|
||||||
|
|
||||||
|
(* bake cycle [preserved_cycle + 1] *)
|
||||||
|
Block.bake_until_cycle_end ~policy b >>=? fun b ->
|
||||||
|
Assert.balance_was_credited ~loc:__LOC__ (B b) (Contract.implicit_contract endorser1.delegate) balance1 reward1 >>=? fun () ->
|
||||||
|
Assert.balance_was_credited ~loc:__LOC__ (B b) (Contract.implicit_contract endorser2.delegate) balance2 reward2
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(****************************************************************)
|
||||||
|
(* The following test scenarios are supposed to raise errors. *)
|
||||||
|
(****************************************************************)
|
||||||
|
|
||||||
|
(** Wrong endorsement predecessor : apply an endorsement with an
|
||||||
|
incorrect block predecessor *)
|
||||||
|
let wrong_endorsement_predecessor () =
|
||||||
|
Context.init 5 >>=? fun (b, _) ->
|
||||||
|
|
||||||
|
Context.get_endorser (B b) >>=? fun (genesis_endorser, _slots) ->
|
||||||
|
Block.bake b >>=? fun b' ->
|
||||||
|
Op.endorsement ~delegate:genesis_endorser ~signing_context:(B b) (B b') () >>=? fun operation ->
|
||||||
|
let operation = Operation.pack operation in
|
||||||
|
Block.bake ~operation b' >>= fun res ->
|
||||||
|
|
||||||
|
Assert.proto_error ~loc:__LOC__ res begin function
|
||||||
|
| Apply.Wrong_endorsement_predecessor _ -> true
|
||||||
|
| _ -> false
|
||||||
|
end
|
||||||
|
|
||||||
|
(** Invalid_endorsement_level : apply an endorsement with an incorrect
|
||||||
|
level (i.e. the predecessor level) *)
|
||||||
|
let invalid_endorsement_level () =
|
||||||
|
Context.init 5 >>=? fun (b, _) ->
|
||||||
|
Context.get_level (B b) >>=? fun genesis_level ->
|
||||||
|
Block.bake b >>=? fun b ->
|
||||||
|
Op.endorsement ~level:genesis_level (B b) () >>=? fun operation ->
|
||||||
|
let operation = Operation.pack operation in
|
||||||
|
Block.bake ~operation b >>= fun res ->
|
||||||
|
|
||||||
|
Assert.proto_error ~loc:__LOC__ res begin function
|
||||||
|
| Apply.Invalid_endorsement_level -> true
|
||||||
|
| _ -> false
|
||||||
|
end
|
||||||
|
|
||||||
|
(** Duplicate endorsement : apply an endorsement that has already been done *)
|
||||||
|
let duplicate_endorsement () =
|
||||||
|
Context.init 5 >>=? fun (b, _) ->
|
||||||
|
Incremental.begin_construction b >>=? fun inc ->
|
||||||
|
Op.endorsement (B b) () >>=? fun operation ->
|
||||||
|
let operation = Operation.pack operation in
|
||||||
|
Incremental.add_operation inc operation >>=? fun inc ->
|
||||||
|
Op.endorsement (B b) () >>=? fun operation ->
|
||||||
|
let operation = Operation.pack operation in
|
||||||
|
Incremental.add_operation inc operation >>= fun res ->
|
||||||
|
|
||||||
|
Assert.proto_error ~loc:__LOC__ res begin function
|
||||||
|
| Apply.Duplicate_endorsement _ -> true
|
||||||
|
| _ -> false
|
||||||
|
end
|
||||||
|
|
||||||
|
(** Apply a single endorsement from the slot 0 endorser *)
|
||||||
|
let not_enough_for_deposit () =
|
||||||
|
Context.init 5 ~endorsers_per_block:1 >>=? fun (b_init, contracts) ->
|
||||||
|
Error_monad.map_s (fun c ->
|
||||||
|
Context.Contract.manager (B b_init) c >>=? fun m -> return (m, c)) contracts >>=?
|
||||||
|
fun managers ->
|
||||||
|
Block.bake b_init >>=? fun b ->
|
||||||
|
(* retrieve the level 2's endorser *)
|
||||||
|
Context.get_endorser (B b) >>=? fun (endorser, _slots) ->
|
||||||
|
let _, contract_other_than_endorser =
|
||||||
|
List.find (fun (c, _) -> not (Signature.Public_key_hash.equal c.Account.pkh endorser))
|
||||||
|
managers
|
||||||
|
in
|
||||||
|
let _, contract_of_endorser =
|
||||||
|
List.find (fun (c, _) -> (Signature.Public_key_hash.equal c.Account.pkh endorser))
|
||||||
|
managers
|
||||||
|
in
|
||||||
|
Context.Contract.balance (B b)
|
||||||
|
(Contract.implicit_contract endorser) >>=? fun initial_balance ->
|
||||||
|
(* Empty the future endorser account *)
|
||||||
|
Op.transaction (B b_init) contract_of_endorser contract_other_than_endorser initial_balance >>=? fun op_trans ->
|
||||||
|
Block.bake ~operation:op_trans b_init >>=? fun b ->
|
||||||
|
(* Endorse with a zero balance *)
|
||||||
|
Op.endorsement ~delegate:endorser (B b) () >>=? fun op_endo ->
|
||||||
|
Block.bake
|
||||||
|
~policy:(Excluding [endorser])
|
||||||
|
~operation:(Operation.pack op_endo)
|
||||||
|
b >>= fun res ->
|
||||||
|
Assert.proto_error ~loc:__LOC__ res begin function
|
||||||
|
| Delegate_storage.Balance_too_low_for_deposit _ -> true
|
||||||
|
| _ -> false
|
||||||
|
end
|
||||||
|
|
||||||
|
(* check that a block with not enough endorsement cannot be baked *)
|
||||||
|
let endorsement_threshold () =
|
||||||
|
let initial_endorsers = 28 in
|
||||||
|
let num_accounts = 100 in
|
||||||
|
Context.init ~initial_endorsers num_accounts >>=? fun (b, _) ->
|
||||||
|
Context.get_endorsers (B b) >>=? fun endorsers ->
|
||||||
|
let num_endorsers = List.length endorsers in
|
||||||
|
|
||||||
|
(* we try to bake with more and more endorsers, but at each
|
||||||
|
iteration with a timestamp smaller than required *)
|
||||||
|
iter_s (fun i ->
|
||||||
|
(* the priority is chosen rather arbitrarily *)
|
||||||
|
let priority = num_endorsers - i in
|
||||||
|
let crt_endorsers = List.take_n i endorsers in
|
||||||
|
let endorsing_power = endorsing_power crt_endorsers in
|
||||||
|
let delegates = delegates_with_slots crt_endorsers in
|
||||||
|
map_s (fun x -> Op.endorsement ~delegate:x (B b) ()) delegates >>=? fun ops ->
|
||||||
|
Context.get_minimal_valid_time (B b) ~priority ~endorsing_power >>=? fun timestamp ->
|
||||||
|
(* decrease the timestamp by one second *)
|
||||||
|
let seconds = Int64.(sub (of_string (Timestamp.to_seconds_string timestamp)) 1L) in
|
||||||
|
match Timestamp.of_seconds (Int64.to_string seconds) with
|
||||||
|
| None -> failwith "timestamp to/from string manipulation failed"
|
||||||
|
| Some timestamp ->
|
||||||
|
Block.bake ~timestamp ~policy:(By_priority priority)
|
||||||
|
~operations:(List.map Operation.pack ops) b >>= fun b2 ->
|
||||||
|
Assert.proto_error ~loc:__LOC__ b2 begin function
|
||||||
|
| Baking.Timestamp_too_early _
|
||||||
|
| Apply.Not_enough_endorsements_for_priority _ -> true
|
||||||
|
| _ -> false
|
||||||
|
end)
|
||||||
|
(0 -- (num_endorsers-1)) >>=? fun () ->
|
||||||
|
|
||||||
|
(* we bake with all endorsers endorsing, at the right time *)
|
||||||
|
let priority = 0 in
|
||||||
|
let endorsing_power = endorsing_power endorsers in
|
||||||
|
let delegates = delegates_with_slots endorsers in
|
||||||
|
map_s (fun delegate -> Op.endorsement ~delegate (B b) ()) delegates >>=? fun ops ->
|
||||||
|
Context.get_minimal_valid_time (B b) ~priority ~endorsing_power >>=? fun timestamp ->
|
||||||
|
Block.bake
|
||||||
|
~policy:(By_priority priority)
|
||||||
|
~timestamp
|
||||||
|
~operations:(List.map Operation.pack ops)
|
||||||
|
b >>= fun _ -> return_unit
|
||||||
|
|
||||||
|
let test_fitness_gap () =
|
||||||
|
let num_accounts = 5 in
|
||||||
|
Context.init num_accounts >>=? fun (b, _) ->
|
||||||
|
begin
|
||||||
|
match Fitness_repr.to_int64 b.header.shell.fitness with
|
||||||
|
| Ok fitness ->
|
||||||
|
return (Int64.to_int fitness)
|
||||||
|
| Error _ -> assert false
|
||||||
|
end >>=? fun fitness ->
|
||||||
|
Context.get_endorser (B b) >>=? fun (delegate, _slots) ->
|
||||||
|
Op.endorsement ~delegate (B b) () >>=? fun op ->
|
||||||
|
(* bake at priority 0 succeed thanks to enough endorsements *)
|
||||||
|
Block.bake
|
||||||
|
~policy:(By_priority 0)
|
||||||
|
~operations:[Operation.pack op]
|
||||||
|
b >>=? fun b ->
|
||||||
|
begin
|
||||||
|
match Fitness_repr.to_int64 b.header.shell.fitness with
|
||||||
|
| Ok new_fitness ->
|
||||||
|
return ((Int64.to_int new_fitness) - fitness)
|
||||||
|
| Error _ -> assert false
|
||||||
|
end >>=? fun res ->
|
||||||
|
(* in Emmy+, the fitness increases by 1, so the difference between
|
||||||
|
the fitness at level 1 and at level 0 is 1, independently if the
|
||||||
|
number fo endorements (here 1) *)
|
||||||
|
Assert.equal_int ~loc:__LOC__ res 1 >>=? fun () ->
|
||||||
|
return_unit
|
||||||
|
|
||||||
|
let tests = [
|
||||||
|
Test.tztest "Simple endorsement" `Quick simple_endorsement ;
|
||||||
|
Test.tztest "Maximum endorsement" `Quick max_endorsement ;
|
||||||
|
Test.tztest "Consistent priorities" `Quick consistent_priorities ;
|
||||||
|
Test.tztest "Reward retrieval" `Quick reward_retrieval ;
|
||||||
|
Test.tztest "Reward retrieval two endorsers" `Quick reward_retrieval_two_endorsers ;
|
||||||
|
Test.tztest "Endorsement threshold" `Quick endorsement_threshold ;
|
||||||
|
Test.tztest "Fitness gap" `Quick test_fitness_gap ;
|
||||||
|
|
||||||
|
(* Fail scenarios *)
|
||||||
|
Test.tztest "Wrong endorsement predecessor" `Quick wrong_endorsement_predecessor ;
|
||||||
|
Test.tztest "Invalid endorsement level" `Quick invalid_endorsement_level ;
|
||||||
|
Test.tztest "Duplicate endorsement" `Quick duplicate_endorsement ;
|
||||||
|
Test.tztest "Not enough for deposit" `Quick not_enough_for_deposit ;
|
||||||
|
]
|
92
vendors/ligo-utils/tezos-protocol-alpha/test/helpers/account.ml
vendored
Normal file
92
vendors/ligo-utils/tezos-protocol-alpha/test/helpers/account.ml
vendored
Normal file
@ -0,0 +1,92 @@
|
|||||||
|
(*****************************************************************************)
|
||||||
|
(* *)
|
||||||
|
(* Open Source License *)
|
||||||
|
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
|
||||||
|
(* *)
|
||||||
|
(* Permission is hereby granted, free of charge, to any person obtaining a *)
|
||||||
|
(* copy of this software and associated documentation files (the "Software"),*)
|
||||||
|
(* to deal in the Software without restriction, including without limitation *)
|
||||||
|
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
|
||||||
|
(* and/or sell copies of the Software, and to permit persons to whom the *)
|
||||||
|
(* Software is furnished to do so, subject to the following conditions: *)
|
||||||
|
(* *)
|
||||||
|
(* The above copyright notice and this permission notice shall be included *)
|
||||||
|
(* in all copies or substantial portions of the Software. *)
|
||||||
|
(* *)
|
||||||
|
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
|
||||||
|
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
|
||||||
|
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
|
||||||
|
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
|
||||||
|
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
|
||||||
|
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
|
||||||
|
(* DEALINGS IN THE SOFTWARE. *)
|
||||||
|
(* *)
|
||||||
|
(*****************************************************************************)
|
||||||
|
|
||||||
|
open Protocol
|
||||||
|
|
||||||
|
type t = {
|
||||||
|
pkh : Signature.Public_key_hash.t ;
|
||||||
|
pk : Signature.Public_key.t ;
|
||||||
|
sk : Signature.Secret_key.t ;
|
||||||
|
}
|
||||||
|
type account = t
|
||||||
|
|
||||||
|
let known_accounts = Signature.Public_key_hash.Table.create 17
|
||||||
|
|
||||||
|
let new_account ?seed () =
|
||||||
|
let (pkh, pk, sk) = Signature.generate_key ?seed () in
|
||||||
|
let account = { pkh ; pk ; sk } in
|
||||||
|
Signature.Public_key_hash.Table.add known_accounts pkh account ;
|
||||||
|
account
|
||||||
|
|
||||||
|
let add_account ({ pkh ; _ } as account) =
|
||||||
|
Signature.Public_key_hash.Table.add known_accounts pkh account
|
||||||
|
|
||||||
|
let activator_account = new_account ()
|
||||||
|
|
||||||
|
let find pkh =
|
||||||
|
try return (Signature.Public_key_hash.Table.find known_accounts pkh)
|
||||||
|
with Not_found ->
|
||||||
|
failwith "Missing account: %a" Signature.Public_key_hash.pp pkh
|
||||||
|
|
||||||
|
let find_alternate pkh =
|
||||||
|
let exception Found of t in
|
||||||
|
try
|
||||||
|
Signature.Public_key_hash.Table.iter
|
||||||
|
(fun pkh' account ->
|
||||||
|
if not (Signature.Public_key_hash.equal pkh pkh') then
|
||||||
|
raise (Found account))
|
||||||
|
known_accounts ;
|
||||||
|
raise Not_found
|
||||||
|
with Found account -> account
|
||||||
|
|
||||||
|
let dummy_account = new_account ()
|
||||||
|
|
||||||
|
let generate_accounts ?(initial_balances = []) n : (t * Tez_repr.t) list =
|
||||||
|
Signature.Public_key_hash.Table.clear known_accounts ;
|
||||||
|
let default_amount = Tez_repr.of_mutez_exn 4_000_000_000_000L in
|
||||||
|
let amount i = match List.nth_opt initial_balances i with
|
||||||
|
| None -> default_amount
|
||||||
|
| Some a -> Tez_repr.of_mutez_exn a
|
||||||
|
in
|
||||||
|
List.map (fun i ->
|
||||||
|
let (pkh, pk, sk) = Signature.generate_key () in
|
||||||
|
let account = { pkh ; pk ; sk } in
|
||||||
|
Signature.Public_key_hash.Table.add known_accounts pkh account ;
|
||||||
|
account, amount i)
|
||||||
|
(0--(n-1))
|
||||||
|
|
||||||
|
let commitment_secret =
|
||||||
|
Blinded_public_key_hash.activation_code_of_hex
|
||||||
|
"aaaaaaaaaaaaaaaaaaaabbbbbbbbbbbbbbbbbbbb"
|
||||||
|
|
||||||
|
let new_commitment ?seed () =
|
||||||
|
let (pkh, pk, sk) = Signature.generate_key ?seed ~algo:Ed25519 () in
|
||||||
|
let unactivated_account = { pkh; pk; sk } in
|
||||||
|
let open Commitment_repr in
|
||||||
|
let pkh = match pkh with Ed25519 pkh -> pkh | _ -> assert false in
|
||||||
|
let bpkh = Blinded_public_key_hash.of_ed25519_pkh commitment_secret pkh in
|
||||||
|
Lwt.return @@ Environment.wrap_error @@
|
||||||
|
Tez_repr.(one *? 4_000L) >>=? fun amount ->
|
||||||
|
return @@ (unactivated_account, { blinded_public_key_hash = bpkh ; amount })
|
57
vendors/ligo-utils/tezos-protocol-alpha/test/helpers/account.mli
vendored
Normal file
57
vendors/ligo-utils/tezos-protocol-alpha/test/helpers/account.mli
vendored
Normal file
@ -0,0 +1,57 @@
|
|||||||
|
(*****************************************************************************)
|
||||||
|
(* *)
|
||||||
|
(* Open Source License *)
|
||||||
|
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
|
||||||
|
(* *)
|
||||||
|
(* Permission is hereby granted, free of charge, to any person obtaining a *)
|
||||||
|
(* copy of this software and associated documentation files (the "Software"),*)
|
||||||
|
(* to deal in the Software without restriction, including without limitation *)
|
||||||
|
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
|
||||||
|
(* and/or sell copies of the Software, and to permit persons to whom the *)
|
||||||
|
(* Software is furnished to do so, subject to the following conditions: *)
|
||||||
|
(* *)
|
||||||
|
(* The above copyright notice and this permission notice shall be included *)
|
||||||
|
(* in all copies or substantial portions of the Software. *)
|
||||||
|
(* *)
|
||||||
|
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
|
||||||
|
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
|
||||||
|
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
|
||||||
|
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
|
||||||
|
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
|
||||||
|
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
|
||||||
|
(* DEALINGS IN THE SOFTWARE. *)
|
||||||
|
(* *)
|
||||||
|
(*****************************************************************************)
|
||||||
|
|
||||||
|
open Protocol
|
||||||
|
|
||||||
|
type t = {
|
||||||
|
pkh : Signature.Public_key_hash.t ;
|
||||||
|
pk : Signature.Public_key.t ;
|
||||||
|
sk : Signature.Secret_key.t ;
|
||||||
|
}
|
||||||
|
type account = t
|
||||||
|
|
||||||
|
val known_accounts: t Signature.Public_key_hash.Table.t
|
||||||
|
|
||||||
|
val activator_account: account
|
||||||
|
val dummy_account: account
|
||||||
|
|
||||||
|
val new_account: ?seed:MBytes.t -> unit -> account
|
||||||
|
|
||||||
|
val add_account : t -> unit
|
||||||
|
|
||||||
|
val find: Signature.Public_key_hash.t -> t tzresult Lwt.t
|
||||||
|
val find_alternate: Signature.Public_key_hash.t -> t
|
||||||
|
|
||||||
|
(** [generate_accounts ?initial_balances n] : generates [n] random
|
||||||
|
accounts with the initial balance of the [i]th account given by the
|
||||||
|
[i]th value in the list [initial_balances] or otherwise
|
||||||
|
4.000.000.000 tz (if the list is too short); and add them to the
|
||||||
|
global account state *)
|
||||||
|
val generate_accounts : ?initial_balances:int64 list -> int -> (t * Tez_repr.t) list
|
||||||
|
|
||||||
|
val commitment_secret : Blinded_public_key_hash.activation_code
|
||||||
|
|
||||||
|
val new_commitment : ?seed:MBytes.t -> unit ->
|
||||||
|
(account * Commitment_repr.t) tzresult Lwt.t
|
124
vendors/ligo-utils/tezos-protocol-alpha/test/helpers/assert.ml
vendored
Normal file
124
vendors/ligo-utils/tezos-protocol-alpha/test/helpers/assert.ml
vendored
Normal file
@ -0,0 +1,124 @@
|
|||||||
|
(*****************************************************************************)
|
||||||
|
(* *)
|
||||||
|
(* Open Source License *)
|
||||||
|
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
|
||||||
|
(* *)
|
||||||
|
(* Permission is hereby granted, free of charge, to any person obtaining a *)
|
||||||
|
(* copy of this software and associated documentation files (the "Software"),*)
|
||||||
|
(* to deal in the Software without restriction, including without limitation *)
|
||||||
|
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
|
||||||
|
(* and/or sell copies of the Software, and to permit persons to whom the *)
|
||||||
|
(* Software is furnished to do so, subject to the following conditions: *)
|
||||||
|
(* *)
|
||||||
|
(* The above copyright notice and this permission notice shall be included *)
|
||||||
|
(* in all copies or substantial portions of the Software. *)
|
||||||
|
(* *)
|
||||||
|
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
|
||||||
|
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
|
||||||
|
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
|
||||||
|
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
|
||||||
|
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
|
||||||
|
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
|
||||||
|
(* DEALINGS IN THE SOFTWARE. *)
|
||||||
|
(* *)
|
||||||
|
(*****************************************************************************)
|
||||||
|
|
||||||
|
open Protocol
|
||||||
|
|
||||||
|
let error ~loc v f =
|
||||||
|
match v with
|
||||||
|
| Error err when List.exists f err ->
|
||||||
|
return_unit
|
||||||
|
| Ok _ ->
|
||||||
|
failwith "Unexpected successful result (%s)" loc
|
||||||
|
| Error err ->
|
||||||
|
failwith "@[Unexpected error (%s): %a@]" loc pp_print_error err
|
||||||
|
|
||||||
|
let proto_error ~loc v f =
|
||||||
|
error ~loc v
|
||||||
|
(function
|
||||||
|
| Environment.Ecoproto_error err -> f err
|
||||||
|
| _ -> false)
|
||||||
|
|
||||||
|
let equal ~loc (cmp : 'a -> 'a -> bool) msg pp a b =
|
||||||
|
if not (cmp a b) then
|
||||||
|
failwith "@[@[[%s]@] - @[%s : %a is not equal to %a@]@]" loc msg pp a pp b
|
||||||
|
else
|
||||||
|
return_unit
|
||||||
|
|
||||||
|
let not_equal ~loc (cmp : 'a -> 'a -> bool) msg pp a b =
|
||||||
|
if cmp a b then
|
||||||
|
failwith "@[@[[%s]@] - @[%s : %a is equal to %a@]@]" loc msg pp a pp b
|
||||||
|
else
|
||||||
|
return_unit
|
||||||
|
|
||||||
|
(* tez *)
|
||||||
|
let equal_tez ~loc (a:Alpha_context.Tez.t) (b:Alpha_context.Tez.t) =
|
||||||
|
let open Alpha_context in
|
||||||
|
equal ~loc Tez.(=) "Tez aren't equal" Tez.pp a b
|
||||||
|
|
||||||
|
let not_equal_tez ~loc (a:Alpha_context.Tez.t) (b:Alpha_context.Tez.t) =
|
||||||
|
let open Alpha_context in
|
||||||
|
not_equal ~loc Tez.(=) "Tez are equal" Tez.pp a b
|
||||||
|
|
||||||
|
(* int *)
|
||||||
|
let equal_int ~loc (a:int) (b:int) =
|
||||||
|
equal ~loc (=) "Integers aren't equal" Format.pp_print_int a b
|
||||||
|
|
||||||
|
let not_equal_int ~loc (a:int) (b:int) =
|
||||||
|
not_equal ~loc (=) "Integers are equal" Format.pp_print_int a b
|
||||||
|
|
||||||
|
(* bool *)
|
||||||
|
let equal_bool ~loc (a:bool) (b:bool) =
|
||||||
|
equal ~loc (=) "Booleans aren't equal" Format.pp_print_bool a b
|
||||||
|
|
||||||
|
let not_equal_bool ~loc (a:bool) (b:bool) =
|
||||||
|
not_equal ~loc (=) "Booleans are equal" Format.pp_print_bool a b
|
||||||
|
|
||||||
|
(* pkh *)
|
||||||
|
let equal_pkh ~loc (a:Signature.Public_key_hash.t) (b:Signature.Public_key_hash.t) =
|
||||||
|
let module PKH = Signature.Public_key_hash in
|
||||||
|
equal ~loc PKH.equal "Public key hashes aren't equal" PKH.pp a b
|
||||||
|
|
||||||
|
let not_equal_pkh ~loc (a:Signature.Public_key_hash.t) (b:Signature.Public_key_hash.t) =
|
||||||
|
let module PKH = Signature.Public_key_hash in
|
||||||
|
not_equal ~loc PKH.equal "Public key hashes are equal" PKH.pp a b
|
||||||
|
|
||||||
|
open Context
|
||||||
|
(* Some asserts for account operations *)
|
||||||
|
|
||||||
|
(** [balance_is b c amount] checks that the current balance of contract [c] is
|
||||||
|
[amount].
|
||||||
|
Default balance type is [Main], pass [~kind] with [Deposit], [Fees] or
|
||||||
|
[Rewards] for the others. *)
|
||||||
|
let balance_is ~loc b contract ?(kind = Contract.Main) expected =
|
||||||
|
Contract.balance b contract ~kind >>=? fun balance ->
|
||||||
|
equal_tez ~loc balance expected
|
||||||
|
|
||||||
|
(** [balance_was_operated ~operand b c old_balance amount] checks that the
|
||||||
|
current balance of contract [c] is [operand old_balance amount] and
|
||||||
|
returns the current balance.
|
||||||
|
Default balance type is [Main], pass [~kind] with [Deposit], [Fees] or
|
||||||
|
[Rewards] for the others. *)
|
||||||
|
let balance_was_operated ~(operand) ~loc b contract ?(kind = Contract.Main) old_balance amount =
|
||||||
|
operand old_balance amount |>
|
||||||
|
Environment.wrap_error |> Lwt.return >>=? fun expected ->
|
||||||
|
balance_is ~loc b contract ~kind expected
|
||||||
|
|
||||||
|
let balance_was_credited = balance_was_operated ~operand:Alpha_context.Tez.(+?)
|
||||||
|
|
||||||
|
let balance_was_debited = balance_was_operated ~operand:Alpha_context.Tez.(-?)
|
||||||
|
|
||||||
|
|
||||||
|
(* debug *)
|
||||||
|
|
||||||
|
let print_balances ctxt id =
|
||||||
|
Contract.balance ~kind:Main ctxt id >>=? fun main ->
|
||||||
|
Contract.balance ~kind:Deposit ctxt id >>=? fun deposit ->
|
||||||
|
Contract.balance ~kind:Fees ctxt id >>=? fun fees ->
|
||||||
|
Contract.balance ~kind:Rewards ctxt id >>|? fun rewards ->
|
||||||
|
Format.printf "\nMain: %s\nDeposit: %s\nFees: %s\nRewards: %s\n"
|
||||||
|
(Alpha_context.Tez.to_string main)
|
||||||
|
(Alpha_context.Tez.to_string deposit)
|
||||||
|
(Alpha_context.Tez.to_string fees)
|
||||||
|
(Alpha_context.Tez.to_string rewards)
|
418
vendors/ligo-utils/tezos-protocol-alpha/test/helpers/block.ml
vendored
Normal file
418
vendors/ligo-utils/tezos-protocol-alpha/test/helpers/block.ml
vendored
Normal file
@ -0,0 +1,418 @@
|
|||||||
|
(*****************************************************************************)
|
||||||
|
(* *)
|
||||||
|
(* Open Source License *)
|
||||||
|
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
|
||||||
|
(* *)
|
||||||
|
(* Permission is hereby granted, free of charge, to any person obtaining a *)
|
||||||
|
(* copy of this software and associated documentation files (the "Software"),*)
|
||||||
|
(* to deal in the Software without restriction, including without limitation *)
|
||||||
|
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
|
||||||
|
(* and/or sell copies of the Software, and to permit persons to whom the *)
|
||||||
|
(* Software is furnished to do so, subject to the following conditions: *)
|
||||||
|
(* *)
|
||||||
|
(* The above copyright notice and this permission notice shall be included *)
|
||||||
|
(* in all copies or substantial portions of the Software. *)
|
||||||
|
(* *)
|
||||||
|
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
|
||||||
|
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
|
||||||
|
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
|
||||||
|
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
|
||||||
|
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
|
||||||
|
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
|
||||||
|
(* DEALINGS IN THE SOFTWARE. *)
|
||||||
|
(* *)
|
||||||
|
(*****************************************************************************)
|
||||||
|
|
||||||
|
open Protocol
|
||||||
|
module Proto_Nonce = Nonce (* Renamed otherwise is masked by Alpha_context *)
|
||||||
|
open Alpha_context
|
||||||
|
|
||||||
|
(* This type collects a block and the context that results from its application *)
|
||||||
|
type t = {
|
||||||
|
hash : Block_hash.t ;
|
||||||
|
header : Block_header.t ;
|
||||||
|
operations : Operation.packed list ;
|
||||||
|
context : Tezos_protocol_environment.Context.t ;
|
||||||
|
}
|
||||||
|
type block = t
|
||||||
|
|
||||||
|
let rpc_context block = {
|
||||||
|
Environment.Updater.block_hash = block.hash ;
|
||||||
|
block_header = block.header.shell ;
|
||||||
|
context = block.context ;
|
||||||
|
}
|
||||||
|
|
||||||
|
let rpc_ctxt =
|
||||||
|
new Environment.proto_rpc_context_of_directory
|
||||||
|
rpc_context rpc_services
|
||||||
|
|
||||||
|
(******** Policies ***********)
|
||||||
|
|
||||||
|
(* Policies are functions that take a block and return a tuple
|
||||||
|
[(account, level, timestamp)] for the [forge_header] function. *)
|
||||||
|
|
||||||
|
(* This type is used only to provide a simpler interface to the exterior. *)
|
||||||
|
type baker_policy =
|
||||||
|
| By_priority of int
|
||||||
|
| By_account of public_key_hash
|
||||||
|
| Excluding of public_key_hash list
|
||||||
|
|
||||||
|
let get_next_baker_by_priority priority block =
|
||||||
|
Alpha_services.Delegate.Baking_rights.get rpc_ctxt
|
||||||
|
~all:true
|
||||||
|
~max_priority:(priority+1) block >>=? fun bakers ->
|
||||||
|
let { Alpha_services.Delegate.Baking_rights.delegate = pkh ;
|
||||||
|
timestamp; _ } = List.find (fun { Alpha_services.Delegate.Baking_rights.priority = p ; _ } -> p = priority) bakers in
|
||||||
|
return (pkh, priority, Option.unopt_exn (Failure "") timestamp)
|
||||||
|
|
||||||
|
let get_next_baker_by_account pkh block =
|
||||||
|
Alpha_services.Delegate.Baking_rights.get rpc_ctxt
|
||||||
|
~delegates:[pkh]
|
||||||
|
~max_priority:256 block >>=? fun bakers ->
|
||||||
|
let { Alpha_services.Delegate.Baking_rights.delegate = pkh ;
|
||||||
|
timestamp ; priority ; _ } = List.hd bakers in
|
||||||
|
return (pkh, priority, Option.unopt_exn (Failure "") timestamp)
|
||||||
|
|
||||||
|
let get_next_baker_excluding excludes block =
|
||||||
|
Alpha_services.Delegate.Baking_rights.get rpc_ctxt
|
||||||
|
~max_priority:256 block >>=? fun bakers ->
|
||||||
|
let { Alpha_services.Delegate.Baking_rights.delegate = pkh ;
|
||||||
|
timestamp ; priority ; _ } =
|
||||||
|
List.find
|
||||||
|
(fun { Alpha_services.Delegate.Baking_rights.delegate ; _ } ->
|
||||||
|
not (List.mem delegate excludes))
|
||||||
|
bakers in
|
||||||
|
return (pkh, priority, Option.unopt_exn (Failure "") timestamp)
|
||||||
|
|
||||||
|
let dispatch_policy = function
|
||||||
|
| By_priority p -> get_next_baker_by_priority p
|
||||||
|
| By_account a -> get_next_baker_by_account a
|
||||||
|
| Excluding al -> get_next_baker_excluding al
|
||||||
|
|
||||||
|
let get_next_baker ?(policy = By_priority 0) = dispatch_policy policy
|
||||||
|
|
||||||
|
let get_endorsing_power b =
|
||||||
|
fold_left_s (fun acc (op: Operation.packed) ->
|
||||||
|
let Operation_data data = op.protocol_data in
|
||||||
|
match data.contents with
|
||||||
|
| Single Endorsement _ ->
|
||||||
|
Alpha_services.Delegate.Endorsing_power.get
|
||||||
|
rpc_ctxt b op Chain_id.zero >>=? fun endorsement_power ->
|
||||||
|
return (acc + endorsement_power)
|
||||||
|
| _ -> return acc)
|
||||||
|
0 b.operations
|
||||||
|
|
||||||
|
module Forge = struct
|
||||||
|
|
||||||
|
type header = {
|
||||||
|
baker : public_key_hash ; (* the signer of the block *)
|
||||||
|
shell : Block_header.shell_header ;
|
||||||
|
contents : Block_header.contents ;
|
||||||
|
}
|
||||||
|
|
||||||
|
let default_proof_of_work_nonce =
|
||||||
|
MBytes.create Constants.proof_of_work_nonce_size
|
||||||
|
|
||||||
|
let make_contents
|
||||||
|
?(proof_of_work_nonce = default_proof_of_work_nonce)
|
||||||
|
~priority ~seed_nonce_hash () =
|
||||||
|
Block_header.{ priority ;
|
||||||
|
proof_of_work_nonce ;
|
||||||
|
seed_nonce_hash }
|
||||||
|
|
||||||
|
let make_shell
|
||||||
|
~level ~predecessor ~timestamp ~fitness ~operations_hash =
|
||||||
|
Tezos_base.Block_header.{
|
||||||
|
level ;
|
||||||
|
predecessor ;
|
||||||
|
timestamp ;
|
||||||
|
fitness ;
|
||||||
|
operations_hash ;
|
||||||
|
(* We don't care of the following values, only the shell validates them. *)
|
||||||
|
proto_level = 0 ;
|
||||||
|
validation_passes = 0 ;
|
||||||
|
context = Context_hash.zero ;
|
||||||
|
}
|
||||||
|
|
||||||
|
let set_seed_nonce_hash seed_nonce_hash { baker ; shell ; contents } =
|
||||||
|
{ baker ; shell ; contents = { contents with seed_nonce_hash } }
|
||||||
|
|
||||||
|
let set_baker baker header = { header with baker }
|
||||||
|
|
||||||
|
let sign_header { baker ; shell ; contents } =
|
||||||
|
Account.find baker >>=? fun delegate ->
|
||||||
|
let unsigned_bytes =
|
||||||
|
Data_encoding.Binary.to_bytes_exn
|
||||||
|
Block_header.unsigned_encoding
|
||||||
|
(shell, contents) in
|
||||||
|
let signature =
|
||||||
|
Signature.sign ~watermark:Signature.(Block_header Chain_id.zero) delegate.sk unsigned_bytes in
|
||||||
|
Block_header.{ shell ; protocol_data = { contents ; signature } } |>
|
||||||
|
return
|
||||||
|
|
||||||
|
let forge_header
|
||||||
|
?(policy = By_priority 0)
|
||||||
|
?timestamp
|
||||||
|
?(operations = []) pred =
|
||||||
|
dispatch_policy policy pred >>=? fun (pkh, priority, _timestamp) ->
|
||||||
|
Alpha_services.Delegate.Minimal_valid_time.get
|
||||||
|
rpc_ctxt pred priority 0 >>=? fun expected_timestamp ->
|
||||||
|
let timestamp = Option.unopt ~default:expected_timestamp timestamp in
|
||||||
|
let level = Int32.succ pred.header.shell.level in
|
||||||
|
begin
|
||||||
|
match Fitness_repr.to_int64 pred.header.shell.fitness with
|
||||||
|
| Ok old_fitness ->
|
||||||
|
return (Fitness_repr.from_int64
|
||||||
|
(Int64.add (Int64.of_int 1) old_fitness))
|
||||||
|
| Error _ -> assert false
|
||||||
|
end >>=? fun fitness ->
|
||||||
|
begin
|
||||||
|
Alpha_services.Helpers.current_level ~offset:1l (rpc_ctxt) pred >>|? function
|
||||||
|
| { expected_commitment = true ; _ } -> Some (fst (Proto_Nonce.generate ()))
|
||||||
|
| { expected_commitment = false ; _ } -> None
|
||||||
|
end >>=? fun seed_nonce_hash ->
|
||||||
|
let hashes = List.map Operation.hash_packed operations in
|
||||||
|
let operations_hash = Operation_list_list_hash.compute
|
||||||
|
[Operation_list_hash.compute hashes] in
|
||||||
|
let shell = make_shell ~level ~predecessor:pred.hash
|
||||||
|
~timestamp ~fitness ~operations_hash in
|
||||||
|
let contents = make_contents ~priority ~seed_nonce_hash () in
|
||||||
|
return { baker = pkh ; shell ; contents }
|
||||||
|
|
||||||
|
(* compatibility only, needed by incremental *)
|
||||||
|
let contents
|
||||||
|
?(proof_of_work_nonce = default_proof_of_work_nonce)
|
||||||
|
?(priority = 0) ?seed_nonce_hash () =
|
||||||
|
{
|
||||||
|
Block_header.priority ;
|
||||||
|
proof_of_work_nonce ;
|
||||||
|
seed_nonce_hash ;
|
||||||
|
}
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
(********* Genesis creation *************)
|
||||||
|
|
||||||
|
(* Hard-coded context key *)
|
||||||
|
let protocol_param_key = [ "protocol_parameters" ]
|
||||||
|
|
||||||
|
let check_constants_consistency constants =
|
||||||
|
let open Constants_repr in
|
||||||
|
let { blocks_per_cycle ; blocks_per_commitment ;
|
||||||
|
blocks_per_roll_snapshot ; _ } = constants in
|
||||||
|
Error_monad.unless (blocks_per_commitment <= blocks_per_cycle)
|
||||||
|
(fun () -> failwith "Inconsistent constants : blocks per commitment must be \
|
||||||
|
less than blocks per cycle") >>=? fun () ->
|
||||||
|
Error_monad.unless (blocks_per_cycle >= blocks_per_roll_snapshot)
|
||||||
|
(fun () -> failwith "Inconsistent constants : blocks per cycle \
|
||||||
|
must be superior than blocks per roll snapshot") >>=?
|
||||||
|
return
|
||||||
|
|
||||||
|
let initial_context
|
||||||
|
?(with_commitments = false)
|
||||||
|
constants
|
||||||
|
header
|
||||||
|
initial_accounts
|
||||||
|
=
|
||||||
|
let open Tezos_protocol_005_PsBabyM1_parameters in
|
||||||
|
let bootstrap_accounts =
|
||||||
|
List.map (fun (Account.{ pk ; pkh ; _ }, amount) ->
|
||||||
|
Default_parameters.make_bootstrap_account (pkh, pk, amount)
|
||||||
|
) initial_accounts
|
||||||
|
in
|
||||||
|
|
||||||
|
let parameters =
|
||||||
|
Default_parameters.parameters_of_constants
|
||||||
|
~bootstrap_accounts
|
||||||
|
~with_commitments
|
||||||
|
constants in
|
||||||
|
let json = Default_parameters.json_of_parameters parameters in
|
||||||
|
let proto_params =
|
||||||
|
Data_encoding.Binary.to_bytes_exn Data_encoding.json json
|
||||||
|
in
|
||||||
|
Tezos_protocol_environment.Context.(
|
||||||
|
let empty = Memory_context.empty in
|
||||||
|
set empty ["version"] (MBytes.of_string "genesis") >>= fun ctxt ->
|
||||||
|
set ctxt protocol_param_key proto_params
|
||||||
|
) >>= fun ctxt ->
|
||||||
|
Main.init ctxt header
|
||||||
|
>|= Environment.wrap_error >>=? fun { context; _ } ->
|
||||||
|
return context
|
||||||
|
|
||||||
|
let genesis_with_parameters parameters =
|
||||||
|
let hash =
|
||||||
|
Block_hash.of_b58check_exn "BLockGenesisGenesisGenesisGenesisGenesisCCCCCeZiLHU"
|
||||||
|
in
|
||||||
|
let shell = Forge.make_shell
|
||||||
|
~level:0l
|
||||||
|
~predecessor:hash
|
||||||
|
~timestamp:Time.Protocol.epoch
|
||||||
|
~fitness: (Fitness_repr.from_int64 0L)
|
||||||
|
~operations_hash: Operation_list_list_hash.zero in
|
||||||
|
let contents = Forge.make_contents
|
||||||
|
~priority:0
|
||||||
|
~seed_nonce_hash:None () in
|
||||||
|
let open Tezos_protocol_005_PsBabyM1_parameters in
|
||||||
|
let json = Default_parameters.json_of_parameters parameters in
|
||||||
|
let proto_params =
|
||||||
|
Data_encoding.Binary.to_bytes_exn Data_encoding.json json
|
||||||
|
in
|
||||||
|
Tezos_protocol_environment.Context.(
|
||||||
|
let empty = Memory_context.empty in
|
||||||
|
set empty ["version"] (MBytes.of_string "genesis") >>= fun ctxt ->
|
||||||
|
set ctxt protocol_param_key proto_params
|
||||||
|
) >>= fun ctxt ->
|
||||||
|
Main.init ctxt shell
|
||||||
|
>|= Environment.wrap_error >>=? fun { context; _ } ->
|
||||||
|
let block = { hash ;
|
||||||
|
header = { shell ;
|
||||||
|
protocol_data = {
|
||||||
|
contents = contents ;
|
||||||
|
signature = Signature.zero ;
|
||||||
|
} } ;
|
||||||
|
operations = [] ;
|
||||||
|
context ;
|
||||||
|
} in
|
||||||
|
return block
|
||||||
|
|
||||||
|
(* if no parameter file is passed we check in the current directory
|
||||||
|
where the test is run *)
|
||||||
|
let genesis
|
||||||
|
?with_commitments
|
||||||
|
?endorsers_per_block
|
||||||
|
?initial_endorsers
|
||||||
|
?min_proposal_quorum
|
||||||
|
(initial_accounts : (Account.t * Tez_repr.t) list)
|
||||||
|
=
|
||||||
|
if initial_accounts = [] then
|
||||||
|
Pervasives.failwith "Must have one account with a roll to bake";
|
||||||
|
|
||||||
|
let open Tezos_protocol_005_PsBabyM1_parameters in
|
||||||
|
let constants = Default_parameters.constants_test in
|
||||||
|
let endorsers_per_block =
|
||||||
|
Option.unopt ~default:constants.endorsers_per_block endorsers_per_block in
|
||||||
|
let initial_endorsers =
|
||||||
|
Option.unopt ~default:constants.initial_endorsers initial_endorsers in
|
||||||
|
let min_proposal_quorum =
|
||||||
|
Option.unopt ~default:constants.min_proposal_quorum min_proposal_quorum in
|
||||||
|
let constants = { constants with endorsers_per_block ; initial_endorsers ; min_proposal_quorum } in
|
||||||
|
|
||||||
|
(* Check there is at least one roll *)
|
||||||
|
begin try
|
||||||
|
let open Test_utils in
|
||||||
|
fold_left_s (fun acc (_, amount) ->
|
||||||
|
Environment.wrap_error @@
|
||||||
|
Tez_repr.(+?) acc amount >>?= fun acc ->
|
||||||
|
if acc >= constants.tokens_per_roll then
|
||||||
|
raise Exit
|
||||||
|
else return acc
|
||||||
|
) Tez_repr.zero initial_accounts >>=? fun _ ->
|
||||||
|
failwith "Insufficient tokens in initial accounts to create one roll"
|
||||||
|
with Exit -> return_unit
|
||||||
|
end >>=? fun () ->
|
||||||
|
|
||||||
|
check_constants_consistency constants >>=? fun () ->
|
||||||
|
|
||||||
|
let hash =
|
||||||
|
Block_hash.of_b58check_exn "BLockGenesisGenesisGenesisGenesisGenesisCCCCCeZiLHU"
|
||||||
|
in
|
||||||
|
let shell = Forge.make_shell
|
||||||
|
~level:0l
|
||||||
|
~predecessor:hash
|
||||||
|
~timestamp:Time.Protocol.epoch
|
||||||
|
~fitness: (Fitness_repr.from_int64 0L)
|
||||||
|
~operations_hash: Operation_list_list_hash.zero in
|
||||||
|
let contents = Forge.make_contents
|
||||||
|
~priority:0
|
||||||
|
~seed_nonce_hash:None () in
|
||||||
|
initial_context
|
||||||
|
?with_commitments
|
||||||
|
constants
|
||||||
|
shell
|
||||||
|
initial_accounts
|
||||||
|
>>=? fun context ->
|
||||||
|
let block =
|
||||||
|
{ hash ;
|
||||||
|
header = {
|
||||||
|
shell = shell ;
|
||||||
|
protocol_data = {
|
||||||
|
contents = contents ;
|
||||||
|
signature = Signature.zero ;
|
||||||
|
} ;
|
||||||
|
};
|
||||||
|
operations = [] ;
|
||||||
|
context ;
|
||||||
|
}
|
||||||
|
in
|
||||||
|
return block
|
||||||
|
|
||||||
|
(********* Baking *************)
|
||||||
|
|
||||||
|
let apply header ?(operations = []) pred =
|
||||||
|
begin
|
||||||
|
let open Environment.Error_monad in
|
||||||
|
Main.begin_application
|
||||||
|
~chain_id: Chain_id.zero
|
||||||
|
~predecessor_context: pred.context
|
||||||
|
~predecessor_fitness: pred.header.shell.fitness
|
||||||
|
~predecessor_timestamp: pred.header.shell.timestamp
|
||||||
|
header >>=? fun vstate ->
|
||||||
|
fold_left_s
|
||||||
|
(fun vstate op ->
|
||||||
|
apply_operation vstate op >>=? fun (state, _result) ->
|
||||||
|
return state)
|
||||||
|
vstate operations >>=? fun vstate ->
|
||||||
|
Main.finalize_block vstate >>=? fun (validation, _result) ->
|
||||||
|
return validation.context
|
||||||
|
end >|= Environment.wrap_error >>|? fun context ->
|
||||||
|
let hash = Block_header.hash header in
|
||||||
|
{ hash ; header ; operations ; context }
|
||||||
|
|
||||||
|
let bake ?policy ?timestamp ?operation ?operations pred =
|
||||||
|
let operations =
|
||||||
|
match operation,operations with
|
||||||
|
| Some op, Some ops -> Some (op::ops)
|
||||||
|
| Some op, None -> Some [op]
|
||||||
|
| None, Some ops -> Some ops
|
||||||
|
| None, None -> None
|
||||||
|
in
|
||||||
|
Forge.forge_header ?timestamp ?policy ?operations pred >>=? fun header ->
|
||||||
|
Forge.sign_header header >>=? fun header ->
|
||||||
|
apply header ?operations pred
|
||||||
|
|
||||||
|
(********** Cycles ****************)
|
||||||
|
|
||||||
|
(* This function is duplicated from Context to avoid a cyclic dependency *)
|
||||||
|
let get_constants b =
|
||||||
|
Alpha_services.Constants.all rpc_ctxt b
|
||||||
|
|
||||||
|
let bake_n ?policy n b =
|
||||||
|
Error_monad.fold_left_s
|
||||||
|
(fun b _ -> bake ?policy b) b (1 -- n)
|
||||||
|
|
||||||
|
let bake_until_cycle_end ?policy b =
|
||||||
|
get_constants b >>=? fun Constants.{ parametric = { blocks_per_cycle ; _ } ; _ } ->
|
||||||
|
let current_level = b.header.shell.level in
|
||||||
|
let current_level = Int32.rem current_level blocks_per_cycle in
|
||||||
|
let delta = Int32.sub blocks_per_cycle current_level in
|
||||||
|
bake_n ?policy (Int32.to_int delta) b
|
||||||
|
|
||||||
|
let bake_until_n_cycle_end ?policy n b =
|
||||||
|
Error_monad.fold_left_s
|
||||||
|
(fun b _ -> bake_until_cycle_end ?policy b) b (1 -- n)
|
||||||
|
|
||||||
|
let bake_until_cycle ?policy cycle (b:t) =
|
||||||
|
get_constants b >>=? fun Constants.{ parametric = { blocks_per_cycle ; _ } ; _ } ->
|
||||||
|
let rec loop (b:t) =
|
||||||
|
let current_cycle =
|
||||||
|
let current_level = b.header.shell.level in
|
||||||
|
let current_cycle = Int32.div current_level blocks_per_cycle in
|
||||||
|
current_cycle
|
||||||
|
in
|
||||||
|
if Int32.equal (Cycle.to_int32 cycle) current_cycle then
|
||||||
|
return b
|
||||||
|
else
|
||||||
|
bake_until_cycle_end ?policy b >>=? fun b ->
|
||||||
|
loop b
|
||||||
|
in
|
||||||
|
loop b
|
137
vendors/ligo-utils/tezos-protocol-alpha/test/helpers/block.mli
vendored
Normal file
137
vendors/ligo-utils/tezos-protocol-alpha/test/helpers/block.mli
vendored
Normal file
@ -0,0 +1,137 @@
|
|||||||
|
(*****************************************************************************)
|
||||||
|
(* *)
|
||||||
|
(* Open Source License *)
|
||||||
|
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
|
||||||
|
(* *)
|
||||||
|
(* Permission is hereby granted, free of charge, to any person obtaining a *)
|
||||||
|
(* copy of this software and associated documentation files (the "Software"),*)
|
||||||
|
(* to deal in the Software without restriction, including without limitation *)
|
||||||
|
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
|
||||||
|
(* and/or sell copies of the Software, and to permit persons to whom the *)
|
||||||
|
(* Software is furnished to do so, subject to the following conditions: *)
|
||||||
|
(* *)
|
||||||
|
(* The above copyright notice and this permission notice shall be included *)
|
||||||
|
(* in all copies or substantial portions of the Software. *)
|
||||||
|
(* *)
|
||||||
|
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
|
||||||
|
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
|
||||||
|
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
|
||||||
|
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
|
||||||
|
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
|
||||||
|
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
|
||||||
|
(* DEALINGS IN THE SOFTWARE. *)
|
||||||
|
(* *)
|
||||||
|
(*****************************************************************************)
|
||||||
|
|
||||||
|
open Protocol
|
||||||
|
open Alpha_context
|
||||||
|
|
||||||
|
type t = {
|
||||||
|
hash : Block_hash.t ;
|
||||||
|
header : Block_header.t ;
|
||||||
|
operations : Operation.packed list ;
|
||||||
|
context : Tezos_protocol_environment.Context.t ; (** Resulting context *)
|
||||||
|
}
|
||||||
|
type block = t
|
||||||
|
|
||||||
|
val rpc_ctxt: t Environment.RPC_context.simple
|
||||||
|
|
||||||
|
(** Policies to select the next baker:
|
||||||
|
- [By_priority p] selects the baker at priority [p]
|
||||||
|
- [By_account pkh] selects the first slot for baker [pkh]
|
||||||
|
- [Excluding pkhs] selects the first baker that doesn't belong to [pkhs]
|
||||||
|
*)
|
||||||
|
type baker_policy =
|
||||||
|
| By_priority of int
|
||||||
|
| By_account of public_key_hash
|
||||||
|
| Excluding of public_key_hash list
|
||||||
|
|
||||||
|
(** Returns (account, priority, timestamp) of the next baker given
|
||||||
|
a policy, defaults to By_priority 0. *)
|
||||||
|
val get_next_baker:
|
||||||
|
?policy:baker_policy ->
|
||||||
|
t -> (public_key_hash * int * Time.Protocol.t) tzresult Lwt.t
|
||||||
|
|
||||||
|
val get_endorsing_power: block -> int tzresult Lwt.t
|
||||||
|
|
||||||
|
module Forge : sig
|
||||||
|
|
||||||
|
val contents:
|
||||||
|
?proof_of_work_nonce:MBytes.t ->
|
||||||
|
?priority:int ->
|
||||||
|
?seed_nonce_hash: Nonce_hash.t ->
|
||||||
|
unit -> Block_header.contents
|
||||||
|
|
||||||
|
type header
|
||||||
|
|
||||||
|
(** Forges a correct header following the policy.
|
||||||
|
The header can then be modified and applied with [apply]. *)
|
||||||
|
val forge_header:
|
||||||
|
?policy:baker_policy ->
|
||||||
|
?timestamp: Timestamp.time ->
|
||||||
|
?operations: Operation.packed list ->
|
||||||
|
t -> header tzresult Lwt.t
|
||||||
|
|
||||||
|
(** Sets uniquely seed_nonce_hash of a header *)
|
||||||
|
val set_seed_nonce_hash:
|
||||||
|
Nonce_hash.t option -> header -> header
|
||||||
|
|
||||||
|
(** Sets the baker that will sign the header to an arbitrary pkh *)
|
||||||
|
val set_baker:
|
||||||
|
public_key_hash -> header -> header
|
||||||
|
|
||||||
|
(** Signs the header with the key of the baker configured in the header.
|
||||||
|
The header can no longer be modified, only applied. *)
|
||||||
|
val sign_header:
|
||||||
|
header ->
|
||||||
|
Block_header.block_header tzresult Lwt.t
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
(** [genesis <opts> accounts] : generates an initial block with the
|
||||||
|
given constants [<opts>] and initializes [accounts] with their
|
||||||
|
associated amounts.
|
||||||
|
*)
|
||||||
|
val genesis:
|
||||||
|
?with_commitments:bool ->
|
||||||
|
?endorsers_per_block:int ->
|
||||||
|
?initial_endorsers: int ->
|
||||||
|
?min_proposal_quorum: int32 ->
|
||||||
|
(Account.t * Tez_repr.tez) list -> block tzresult Lwt.t
|
||||||
|
|
||||||
|
val genesis_with_parameters: Parameters_repr.t -> block tzresult Lwt.t
|
||||||
|
|
||||||
|
(** Applies a signed header and its operations to a block and
|
||||||
|
obtains a new block *)
|
||||||
|
val apply:
|
||||||
|
Block_header.block_header ->
|
||||||
|
?operations: Operation.packed list ->
|
||||||
|
t -> t tzresult Lwt.t
|
||||||
|
|
||||||
|
(**
|
||||||
|
[bake b] returns a block [b'] which has as predecessor block [b].
|
||||||
|
Optional parameter [policy] allows to pick the next baker in several ways.
|
||||||
|
This function bundles together [forge_header], [sign_header] and [apply].
|
||||||
|
These functions should be used instead of bake to craft unusual blocks for
|
||||||
|
testing together with setters for properties of the headers.
|
||||||
|
For examples see seed.ml or double_baking.ml
|
||||||
|
*)
|
||||||
|
val bake:
|
||||||
|
?policy: baker_policy ->
|
||||||
|
?timestamp: Timestamp.time ->
|
||||||
|
?operation: Operation.packed ->
|
||||||
|
?operations: Operation.packed list ->
|
||||||
|
t -> t tzresult Lwt.t
|
||||||
|
|
||||||
|
(** Bakes [n] blocks. *)
|
||||||
|
val bake_n : ?policy:baker_policy -> int -> t -> block tzresult Lwt.t
|
||||||
|
|
||||||
|
(** Given a block [b] at level [l] bakes enough blocks to complete a cycle,
|
||||||
|
that is [blocks_per_cycle - (l % blocks_per_cycle)]. *)
|
||||||
|
val bake_until_cycle_end : ?policy:baker_policy -> t -> t tzresult Lwt.t
|
||||||
|
|
||||||
|
(** Bakes enough blocks to end [n] cycles. *)
|
||||||
|
val bake_until_n_cycle_end : ?policy:baker_policy -> int -> t -> t tzresult Lwt.t
|
||||||
|
|
||||||
|
(** Bakes enough blocks to reach the cycle. *)
|
||||||
|
val bake_until_cycle : ?policy:baker_policy -> Cycle.t -> t -> t tzresult Lwt.t
|
285
vendors/ligo-utils/tezos-protocol-alpha/test/helpers/context.ml
vendored
Normal file
285
vendors/ligo-utils/tezos-protocol-alpha/test/helpers/context.ml
vendored
Normal file
@ -0,0 +1,285 @@
|
|||||||
|
(*****************************************************************************)
|
||||||
|
(* *)
|
||||||
|
(* Open Source License *)
|
||||||
|
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
|
||||||
|
(* *)
|
||||||
|
(* Permission is hereby granted, free of charge, to any person obtaining a *)
|
||||||
|
(* copy of this software and associated documentation files (the "Software"),*)
|
||||||
|
(* to deal in the Software without restriction, including without limitation *)
|
||||||
|
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
|
||||||
|
(* and/or sell copies of the Software, and to permit persons to whom the *)
|
||||||
|
(* Software is furnished to do so, subject to the following conditions: *)
|
||||||
|
(* *)
|
||||||
|
(* The above copyright notice and this permission notice shall be included *)
|
||||||
|
(* in all copies or substantial portions of the Software. *)
|
||||||
|
(* *)
|
||||||
|
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
|
||||||
|
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
|
||||||
|
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
|
||||||
|
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
|
||||||
|
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
|
||||||
|
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
|
||||||
|
(* DEALINGS IN THE SOFTWARE. *)
|
||||||
|
(* *)
|
||||||
|
(*****************************************************************************)
|
||||||
|
|
||||||
|
open Protocol
|
||||||
|
open Alpha_context
|
||||||
|
|
||||||
|
type t =
|
||||||
|
| B of Block.t
|
||||||
|
| I of Incremental.t
|
||||||
|
|
||||||
|
let branch = function
|
||||||
|
| B b -> b.hash
|
||||||
|
| I i -> (Incremental.predecessor i).hash
|
||||||
|
|
||||||
|
let level = function
|
||||||
|
| B b -> b.header.shell.level
|
||||||
|
| I i -> (Incremental.level i)
|
||||||
|
|
||||||
|
let get_level ctxt =
|
||||||
|
level ctxt
|
||||||
|
|> Raw_level.of_int32
|
||||||
|
|> Environment.wrap_error
|
||||||
|
|> Lwt.return
|
||||||
|
|
||||||
|
let rpc_ctxt = object
|
||||||
|
method call_proto_service0 :
|
||||||
|
'm 'q 'i 'o.
|
||||||
|
([< RPC_service.meth ] as 'm, Environment.RPC_context.t, Environment.RPC_context.t, 'q, 'i, 'o) RPC_service.t ->
|
||||||
|
t -> 'q -> 'i -> 'o tzresult Lwt.t =
|
||||||
|
fun s pr q i ->
|
||||||
|
match pr with
|
||||||
|
| B b -> Block.rpc_ctxt#call_proto_service0 s b q i
|
||||||
|
| I b -> Incremental.rpc_ctxt#call_proto_service0 s b q i
|
||||||
|
method call_proto_service1 :
|
||||||
|
'm 'a 'q 'i 'o.
|
||||||
|
([< RPC_service.meth ] as 'm, Environment.RPC_context.t, Environment.RPC_context.t * 'a, 'q, 'i, 'o) RPC_service.t ->
|
||||||
|
t -> 'a -> 'q -> 'i -> 'o tzresult Lwt.t =
|
||||||
|
fun s pr a q i ->
|
||||||
|
match pr with
|
||||||
|
| B bl -> Block.rpc_ctxt#call_proto_service1 s bl a q i
|
||||||
|
| I bl -> Incremental.rpc_ctxt#call_proto_service1 s bl a q i
|
||||||
|
method call_proto_service2 :
|
||||||
|
'm 'a 'b 'q 'i 'o.
|
||||||
|
([< RPC_service.meth ] as 'm, Environment.RPC_context.t, (Environment.RPC_context.t * 'a) * 'b, 'q, 'i, 'o) RPC_service.t ->
|
||||||
|
t -> 'a -> 'b -> 'q -> 'i -> 'o tzresult Lwt.t =
|
||||||
|
fun s pr a b q i ->
|
||||||
|
match pr with
|
||||||
|
| B bl -> Block.rpc_ctxt#call_proto_service2 s bl a b q i
|
||||||
|
| I bl -> Incremental.rpc_ctxt#call_proto_service2 s bl a b q i
|
||||||
|
method call_proto_service3 :
|
||||||
|
'm 'a 'b 'c 'q 'i 'o.
|
||||||
|
([< RPC_service.meth ] as 'm, Environment.RPC_context.t, ((Environment.RPC_context.t * 'a) * 'b) * 'c, 'q, 'i, 'o) RPC_service.t ->
|
||||||
|
t -> 'a -> 'b -> 'c -> 'q -> 'i -> 'o tzresult Lwt.t =
|
||||||
|
fun s pr a b c q i ->
|
||||||
|
match pr with
|
||||||
|
| B bl -> Block.rpc_ctxt#call_proto_service3 s bl a b c q i
|
||||||
|
| I bl -> Incremental.rpc_ctxt#call_proto_service3 s bl a b c q i
|
||||||
|
end
|
||||||
|
|
||||||
|
let get_endorsers ctxt =
|
||||||
|
Alpha_services.Delegate.Endorsing_rights.get rpc_ctxt ctxt
|
||||||
|
|
||||||
|
let get_endorser ctxt =
|
||||||
|
Alpha_services.Delegate.Endorsing_rights.get rpc_ctxt ctxt >>=? fun endorsers ->
|
||||||
|
let endorser = List.hd endorsers in
|
||||||
|
return (endorser.delegate, endorser.slots)
|
||||||
|
|
||||||
|
let get_bakers ctxt =
|
||||||
|
Alpha_services.Delegate.Baking_rights.get
|
||||||
|
~max_priority:256
|
||||||
|
rpc_ctxt ctxt >>=? fun bakers ->
|
||||||
|
return (List.map
|
||||||
|
(fun p -> p.Alpha_services.Delegate.Baking_rights.delegate)
|
||||||
|
bakers)
|
||||||
|
|
||||||
|
let get_seed_nonce_hash ctxt =
|
||||||
|
let header =
|
||||||
|
match ctxt with
|
||||||
|
| B { header ; _ } -> header
|
||||||
|
| I i -> Incremental.header i in
|
||||||
|
match header.protocol_data.contents.seed_nonce_hash with
|
||||||
|
| None -> failwith "No committed nonce"
|
||||||
|
| Some hash -> return hash
|
||||||
|
|
||||||
|
let get_seed ctxt = Alpha_services.Seed.get rpc_ctxt ctxt
|
||||||
|
|
||||||
|
let get_constants ctxt =
|
||||||
|
Alpha_services.Constants.all rpc_ctxt ctxt
|
||||||
|
|
||||||
|
let get_minimal_valid_time ctxt ~priority ~endorsing_power =
|
||||||
|
Alpha_services.Delegate.Minimal_valid_time.get rpc_ctxt ctxt priority endorsing_power
|
||||||
|
|
||||||
|
|
||||||
|
let get_baking_reward ctxt ~priority ~endorsing_power =
|
||||||
|
get_constants ctxt >>=? fun Constants.
|
||||||
|
{ parametric = { block_reward ; endorsers_per_block ; _ } ; _ } ->
|
||||||
|
let prio_factor_denominator = Int64.(succ (of_int priority)) in
|
||||||
|
let endo_factor_numerator = Int64.of_int (8 + 2 * endorsing_power / endorsers_per_block) in
|
||||||
|
let endo_factor_denominator = 10L in
|
||||||
|
Lwt.return
|
||||||
|
Test_tez.Tez.(
|
||||||
|
block_reward *? endo_factor_numerator >>? fun val1 ->
|
||||||
|
val1 /? endo_factor_denominator >>? fun val2 ->
|
||||||
|
val2 /? prio_factor_denominator)
|
||||||
|
|
||||||
|
let get_endorsing_reward ctxt ~priority ~endorsing_power =
|
||||||
|
get_constants ctxt >>=? fun Constants.
|
||||||
|
{ parametric = { endorsement_reward ; _ } ; _ } ->
|
||||||
|
let open Test_utils in
|
||||||
|
Test_tez.Tez.(
|
||||||
|
endorsement_reward /? Int64.(succ (of_int priority)) >>?= fun reward_per_slot ->
|
||||||
|
reward_per_slot *? (Int64.of_int endorsing_power) >>?= fun reward ->
|
||||||
|
return reward)
|
||||||
|
|
||||||
|
|
||||||
|
(* Voting *)
|
||||||
|
|
||||||
|
module Vote = struct
|
||||||
|
|
||||||
|
let get_ballots ctxt =
|
||||||
|
Alpha_services.Voting.ballots rpc_ctxt ctxt
|
||||||
|
|
||||||
|
let get_ballot_list ctxt =
|
||||||
|
Alpha_services.Voting.ballot_list rpc_ctxt ctxt
|
||||||
|
|
||||||
|
let get_voting_period ctxt =
|
||||||
|
Alpha_services.Helpers.current_level rpc_ctxt ~offset:1l ctxt >>=? fun l ->
|
||||||
|
return l.voting_period
|
||||||
|
|
||||||
|
let get_voting_period_position ctxt =
|
||||||
|
Alpha_services.Helpers.current_level rpc_ctxt ~offset:1l ctxt >>=? fun l ->
|
||||||
|
return l.voting_period_position
|
||||||
|
|
||||||
|
let get_current_period_kind ctxt =
|
||||||
|
Alpha_services.Voting.current_period_kind rpc_ctxt ctxt
|
||||||
|
|
||||||
|
let get_current_quorum ctxt =
|
||||||
|
Alpha_services.Voting.current_quorum rpc_ctxt ctxt
|
||||||
|
|
||||||
|
let get_listings ctxt =
|
||||||
|
Alpha_services.Voting.listings rpc_ctxt ctxt
|
||||||
|
|
||||||
|
let get_proposals ctxt =
|
||||||
|
Alpha_services.Voting.proposals rpc_ctxt ctxt
|
||||||
|
|
||||||
|
let get_current_proposal ctxt =
|
||||||
|
Alpha_services.Voting.current_proposal rpc_ctxt ctxt
|
||||||
|
|
||||||
|
let get_protocol (b:Block.t) =
|
||||||
|
Tezos_protocol_environment.Context.get b.context ["protocol"] >>= function
|
||||||
|
| None -> assert false
|
||||||
|
| Some p -> Lwt.return (Protocol_hash.of_bytes_exn p)
|
||||||
|
|
||||||
|
let get_participation_ema (b:Block.t) =
|
||||||
|
Environment.Context.get b.context ["votes"; "participation_ema"] >>= function
|
||||||
|
| None -> assert false
|
||||||
|
| Some bytes -> return (MBytes.get_int32 bytes 0)
|
||||||
|
|
||||||
|
let set_participation_ema (b:Block.t) ema =
|
||||||
|
let bytes = MBytes.make 4 '\000' in
|
||||||
|
MBytes.set_int32 bytes 0 ema ;
|
||||||
|
Environment.Context.set b.context
|
||||||
|
["votes"; "participation_ema"] bytes >>= fun context ->
|
||||||
|
Lwt.return { b with context }
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
module Contract = struct
|
||||||
|
|
||||||
|
let pp = Alpha_context.Contract.pp
|
||||||
|
|
||||||
|
let pkh c = Alpha_context.Contract.is_implicit c |> function
|
||||||
|
| Some p -> return p
|
||||||
|
| None -> failwith "pkh: only for implicit contracts"
|
||||||
|
|
||||||
|
type balance_kind = Main | Deposit | Fees | Rewards
|
||||||
|
|
||||||
|
let balance ?(kind = Main) ctxt contract =
|
||||||
|
begin match kind with
|
||||||
|
| Main ->
|
||||||
|
Alpha_services.Contract.balance rpc_ctxt ctxt contract
|
||||||
|
| _ ->
|
||||||
|
match Alpha_context.Contract.is_implicit contract with
|
||||||
|
| None ->
|
||||||
|
invalid_arg
|
||||||
|
"get_balance: no frozen accounts for an originated contract."
|
||||||
|
| Some pkh ->
|
||||||
|
Alpha_services.Delegate.frozen_balance_by_cycle
|
||||||
|
rpc_ctxt ctxt pkh >>=? fun map ->
|
||||||
|
Lwt.return @@
|
||||||
|
Cycle.Map.fold
|
||||||
|
(fun _cycle { Delegate.deposit ; fees ; rewards } acc ->
|
||||||
|
acc >>?fun acc ->
|
||||||
|
match kind with
|
||||||
|
| Deposit -> Test_tez.Tez.(acc +? deposit)
|
||||||
|
| Fees -> Test_tez.Tez.(acc +? fees)
|
||||||
|
| Rewards -> Test_tez.Tez.(acc +? rewards)
|
||||||
|
| _ -> assert false)
|
||||||
|
map
|
||||||
|
(Ok Tez.zero)
|
||||||
|
end
|
||||||
|
|
||||||
|
let counter ctxt contract =
|
||||||
|
match Contract.is_implicit contract with
|
||||||
|
| None -> invalid_arg "Helpers.Context.counter"
|
||||||
|
| Some mgr ->
|
||||||
|
Alpha_services.Contract.counter rpc_ctxt ctxt mgr
|
||||||
|
|
||||||
|
let manager _ contract =
|
||||||
|
match Contract.is_implicit contract with
|
||||||
|
| None -> invalid_arg "Helpers.Context.manager"
|
||||||
|
| Some pkh -> Account.find pkh
|
||||||
|
|
||||||
|
let is_manager_key_revealed ctxt contract =
|
||||||
|
match Contract.is_implicit contract with
|
||||||
|
| None -> invalid_arg "Helpers.Context.is_manager_key_revealed"
|
||||||
|
| Some mgr ->
|
||||||
|
Alpha_services.Contract.manager_key rpc_ctxt ctxt mgr >>=? fun res ->
|
||||||
|
return (res <> None)
|
||||||
|
|
||||||
|
let delegate ctxt contract =
|
||||||
|
Alpha_services.Contract.delegate rpc_ctxt ctxt contract
|
||||||
|
|
||||||
|
let delegate_opt ctxt contract =
|
||||||
|
Alpha_services.Contract.delegate_opt rpc_ctxt ctxt contract
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
module Delegate = struct
|
||||||
|
|
||||||
|
type info = Delegate_services.info = {
|
||||||
|
balance: Tez.t ;
|
||||||
|
frozen_balance: Tez.t ;
|
||||||
|
frozen_balance_by_cycle: Delegate.frozen_balance Cycle.Map.t ;
|
||||||
|
staking_balance: Tez.t ;
|
||||||
|
delegated_contracts: Contract_repr.t list ;
|
||||||
|
delegated_balance: Tez.t ;
|
||||||
|
deactivated: bool ;
|
||||||
|
grace_period: Cycle.t ;
|
||||||
|
}
|
||||||
|
|
||||||
|
let info ctxt pkh =
|
||||||
|
Alpha_services.Delegate.info rpc_ctxt ctxt pkh
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
let init
|
||||||
|
?endorsers_per_block
|
||||||
|
?with_commitments
|
||||||
|
?(initial_balances = [])
|
||||||
|
?initial_endorsers
|
||||||
|
?min_proposal_quorum
|
||||||
|
n =
|
||||||
|
let accounts = Account.generate_accounts ~initial_balances n in
|
||||||
|
let contracts = List.map (fun (a, _) ->
|
||||||
|
Alpha_context.Contract.implicit_contract Account.(a.pkh)) accounts in
|
||||||
|
Block.genesis
|
||||||
|
?endorsers_per_block
|
||||||
|
?with_commitments
|
||||||
|
?initial_endorsers
|
||||||
|
?min_proposal_quorum
|
||||||
|
accounts >>=? fun blk ->
|
||||||
|
return (blk, contracts)
|
119
vendors/ligo-utils/tezos-protocol-alpha/test/helpers/context.mli
vendored
Normal file
119
vendors/ligo-utils/tezos-protocol-alpha/test/helpers/context.mli
vendored
Normal file
@ -0,0 +1,119 @@
|
|||||||
|
(*****************************************************************************)
|
||||||
|
(* *)
|
||||||
|
(* Open Source License *)
|
||||||
|
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
|
||||||
|
(* *)
|
||||||
|
(* Permission is hereby granted, free of charge, to any person obtaining a *)
|
||||||
|
(* copy of this software and associated documentation files (the "Software"),*)
|
||||||
|
(* to deal in the Software without restriction, including without limitation *)
|
||||||
|
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
|
||||||
|
(* and/or sell copies of the Software, and to permit persons to whom the *)
|
||||||
|
(* Software is furnished to do so, subject to the following conditions: *)
|
||||||
|
(* *)
|
||||||
|
(* The above copyright notice and this permission notice shall be included *)
|
||||||
|
(* in all copies or substantial portions of the Software. *)
|
||||||
|
(* *)
|
||||||
|
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
|
||||||
|
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
|
||||||
|
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
|
||||||
|
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
|
||||||
|
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
|
||||||
|
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
|
||||||
|
(* DEALINGS IN THE SOFTWARE. *)
|
||||||
|
(* *)
|
||||||
|
(*****************************************************************************)
|
||||||
|
|
||||||
|
open Protocol
|
||||||
|
open Alpha_context
|
||||||
|
open Environment
|
||||||
|
|
||||||
|
type t =
|
||||||
|
| B of Block.t
|
||||||
|
| I of Incremental.t
|
||||||
|
|
||||||
|
val branch: t -> Block_hash.t
|
||||||
|
|
||||||
|
val get_level: t -> Raw_level.t tzresult Lwt.t
|
||||||
|
|
||||||
|
val get_endorsers: t -> Alpha_services.Delegate.Endorsing_rights.t list tzresult Lwt.t
|
||||||
|
|
||||||
|
val get_endorser: t -> (public_key_hash * int list) tzresult Lwt.t
|
||||||
|
|
||||||
|
val get_bakers: t -> public_key_hash list tzresult Lwt.t
|
||||||
|
|
||||||
|
val get_seed_nonce_hash: t -> Nonce_hash.t tzresult Lwt.t
|
||||||
|
|
||||||
|
(** Returns the seed of the cycle to which the block belongs to. *)
|
||||||
|
val get_seed: t -> Seed.seed tzresult Lwt.t
|
||||||
|
|
||||||
|
(** Returns all the constants of the protocol *)
|
||||||
|
val get_constants: t -> Constants.t tzresult Lwt.t
|
||||||
|
|
||||||
|
val get_minimal_valid_time: t -> priority:int -> endorsing_power:int -> Time.t tzresult Lwt.t
|
||||||
|
|
||||||
|
val get_baking_reward: t -> priority:int -> endorsing_power:int -> Tez.t tzresult Lwt.t
|
||||||
|
|
||||||
|
val get_endorsing_reward: t -> priority:int -> endorsing_power:int -> Tez.t tzresult Lwt.t
|
||||||
|
|
||||||
|
module Vote : sig
|
||||||
|
val get_ballots: t -> Vote.ballots tzresult Lwt.t
|
||||||
|
val get_ballot_list: t -> (Signature.Public_key_hash.t * Vote.ballot) list tzresult Lwt.t
|
||||||
|
val get_voting_period: t -> Voting_period.t tzresult Lwt.t
|
||||||
|
val get_voting_period_position: t -> Int32.t tzresult Lwt.t
|
||||||
|
val get_current_period_kind: t -> Voting_period.kind tzresult Lwt.t
|
||||||
|
val get_current_quorum: t -> Int32.t tzresult Lwt.t
|
||||||
|
val get_participation_ema: Block.t -> Int32.t tzresult Lwt.t
|
||||||
|
val get_listings: t -> (Signature.Public_key_hash.t * int32) list tzresult Lwt.t
|
||||||
|
val get_proposals: t -> Int32.t Protocol_hash.Map.t tzresult Lwt.t
|
||||||
|
val get_current_proposal: t -> Protocol_hash.t option tzresult Lwt.t
|
||||||
|
val get_protocol : Block.t -> Protocol_hash.t Lwt.t
|
||||||
|
val set_participation_ema : Block.t -> int32 -> Block.t Lwt.t
|
||||||
|
end
|
||||||
|
|
||||||
|
module Contract : sig
|
||||||
|
|
||||||
|
val pp : Format.formatter -> Contract.t -> unit
|
||||||
|
val pkh: Contract.t -> public_key_hash tzresult Lwt.t
|
||||||
|
|
||||||
|
type balance_kind = Main | Deposit | Fees | Rewards
|
||||||
|
|
||||||
|
(** Returns the balance of a contract, by default the main balance.
|
||||||
|
If the contract is implicit the frozen balances are available too:
|
||||||
|
deposit, fees or rewards. *)
|
||||||
|
val balance: ?kind:balance_kind -> t -> Contract.t -> Tez.t tzresult Lwt.t
|
||||||
|
|
||||||
|
val counter: t -> Contract.t -> Z.t tzresult Lwt.t
|
||||||
|
val manager: t -> Contract.t -> Account.t tzresult Lwt.t
|
||||||
|
val is_manager_key_revealed: t -> Contract.t -> bool tzresult Lwt.t
|
||||||
|
|
||||||
|
val delegate: t -> Contract.t -> public_key_hash tzresult Lwt.t
|
||||||
|
val delegate_opt: t -> Contract.t -> public_key_hash option tzresult Lwt.t
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
module Delegate : sig
|
||||||
|
|
||||||
|
type info = Delegate_services.info = {
|
||||||
|
balance: Tez.t ;
|
||||||
|
frozen_balance: Tez.t ;
|
||||||
|
frozen_balance_by_cycle: Delegate.frozen_balance Cycle.Map.t ;
|
||||||
|
staking_balance: Tez.t ;
|
||||||
|
delegated_contracts: Contract_repr.t list ;
|
||||||
|
delegated_balance: Tez.t ;
|
||||||
|
deactivated: bool ;
|
||||||
|
grace_period: Cycle.t ;
|
||||||
|
}
|
||||||
|
|
||||||
|
val info: t -> public_key_hash -> Delegate_services.info tzresult Lwt.t
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
(** [init n] : returns an initial block with [n] initialized accounts
|
||||||
|
and the associated implicit contracts *)
|
||||||
|
val init:
|
||||||
|
?endorsers_per_block: int ->
|
||||||
|
?with_commitments: bool ->
|
||||||
|
?initial_balances: int64 list ->
|
||||||
|
?initial_endorsers: int ->
|
||||||
|
?min_proposal_quorum: int32 ->
|
||||||
|
int -> (Block.t * Alpha_context.Contract.t list) tzresult Lwt.t
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user