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

y e s s s

Browse Source
This commit is contained in:
galfour 2019-09-05 15:21:01 +02:00
parent 32599ae90b
commit f831793fbd
178 changed files with 28767 additions and 1437 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/ast_simplified/dune
View File

@ -6,7 +6,7 @@
tezos-utils tezos-utils
) )
(preprocess (preprocess
(pps simple-utils.ppx_let_generalized) (pps ppx_let)
) )
(flags (:standard -open Simple_utils )) (flags (:standard -open Simple_utils ))
) )

2
src/ast_simplified/types.ml
View File

@ -92,7 +92,7 @@ and literal =
| Literal_bytes of bytes | Literal_bytes of bytes
| Literal_address of string | Literal_address of string
| Literal_timestamp of int | Literal_timestamp of int
| Literal_operation of Memory_proto_alpha.Alpha_context.packed_internal_operation | Literal_operation of Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation
and 'a matching = and 'a matching =
| Match_bool of { | Match_bool of {

2
src/ast_typed/dune
View File

@ -7,7 +7,7 @@
ast_simplified ; Is that a good idea? ast_simplified ; Is that a good idea?
) )
(preprocess (preprocess
(pps simple-utils.ppx_let_generalized) (pps ppx_let)
) )
(flags (:standard -open Simple_utils)) (flags (:standard -open Simple_utils))
) )

2
src/ast_typed/types.ml
View File

@ -122,7 +122,7 @@ and literal =
| Literal_string of string | Literal_string of string
| Literal_bytes of bytes | Literal_bytes of bytes
| Literal_address of string | Literal_address of string
| Literal_operation of Memory_proto_alpha.Alpha_context.packed_internal_operation | Literal_operation of Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation
and access = and access =
| Access_tuple of int | Access_tuple of int

2
src/bin/dune
View File

@ -8,7 +8,7 @@
) )
(package ligo) (package ligo)
(preprocess (preprocess
(pps simple-utils.ppx_let_generalized) (pps ppx_let)
) )
(flags (:standard -open Simple_utils)) (flags (:standard -open Simple_utils))
) )

154
src/compiler/compiler_environment.ml
View File

@ -3,12 +3,9 @@ open Trace
open Mini_c open Mini_c
open Environment open Environment
open Michelson open Michelson
open Memory_proto_alpha.Script_ir_translator
module Stack = Meta_michelson.Stack
let get : environment -> string -> michelson result = fun e s -> let get : environment -> string -> michelson result = fun e s ->
let%bind (type_value , position) = let%bind (_type_value , position) =
let error = let error =
let title () = "Environment.get" in let title () = "Environment.get" in
let content () = Format.asprintf "%s in %a" let content () = Format.asprintf "%s in %a"
@ -26,22 +23,10 @@ let get : environment -> string -> michelson result = fun e s ->
in in
let code = aux position in let code = aux position in
let%bind () =
let error () = ok @@ simple_error "error producing Env.get" in
let%bind (Stack.Ex_stack_ty input_stack_ty) = Compiler_type.Ty.environment e in
let%bind (Ex_ty ty) = Compiler_type.Ty.type_ type_value in
let output_stack_ty = Stack.(ty @: input_stack_ty) in
let%bind _ =
Trace.trace_tzresult_lwt_r error @@
Memory_proto_alpha.parse_michelson code
input_stack_ty output_stack_ty in
ok ()
in
ok code ok code
let set : environment -> string -> michelson result = fun e s -> let set : environment -> string -> michelson result = fun e s ->
let%bind (type_value , position) = let%bind (_type_value , position) =
generic_try (simple_error "Environment.get") @@ generic_try (simple_error "Environment.get") @@
(fun () -> Environment.get_i s e) in (fun () -> Environment.get_i s e) in
let rec aux = fun n -> let rec aux = fun n ->
@ -54,37 +39,11 @@ let set : environment -> string -> michelson result = fun e s ->
in in
let code = aux position in let code = aux position in
let%bind () =
let error () = ok @@ simple_error "error producing Env.set" in
let%bind (Stack.Ex_stack_ty env_stack_ty) = Compiler_type.Ty.environment e in
let%bind (Ex_ty ty) = Compiler_type.Ty.type_ type_value in
let input_stack_ty = Stack.(ty @: env_stack_ty) in
let output_stack_ty = env_stack_ty in
let%bind _ =
Trace.trace_tzresult_lwt_r error @@
Memory_proto_alpha.parse_michelson code
input_stack_ty output_stack_ty in
ok ()
in
ok code ok code
let add : environment -> (string * type_value) -> michelson result = fun e (_s , type_value) -> let add : environment -> (string * type_value) -> michelson result = fun _e (_s , _type_value) ->
let code = seq [] in let code = seq [] in
let%bind () =
let error () = ok @@ simple_error "error producing Env.get" in
let%bind (Stack.Ex_stack_ty env_stack_ty) = Compiler_type.Ty.environment e in
let%bind (Ex_ty ty) = Compiler_type.Ty.type_ type_value in
let input_stack_ty = Stack.(ty @: env_stack_ty) in
let output_stack_ty = Stack.(ty @: env_stack_ty) in
let%bind _ =
Trace.trace_tzresult_lwt_r error @@
Memory_proto_alpha.parse_michelson code
input_stack_ty output_stack_ty in
ok ()
in
ok code ok code
let select ?(rev = false) ?(keep = true) : environment -> string list -> michelson result = fun e lst -> let select ?(rev = false) ?(keep = true) : environment -> string list -> michelson result = fun e lst ->
@ -111,32 +70,6 @@ let select ?(rev = false) ?(keep = true) : environment -> string list -> michels
in in
List.fold_right' aux (seq []) e_lst in List.fold_right' aux (seq []) e_lst in
let%bind () =
let%bind (Stack.Ex_stack_ty input_stack_ty) = Compiler_type.Ty.environment e in
let e' =
Environment.of_list
@@ List.map fst
@@ List.filter snd
@@ e_lst
in
let%bind (Stack.Ex_stack_ty output_stack_ty) = Compiler_type.Ty.environment e' in
let error () =
let title () = "error producing Env.select" in
let content () = Format.asprintf "\nInput : %a\nOutput : %a\nList : {%a}\nCode : %a\nLog : %s\n"
PP.environment e
PP.environment e'
PP_helpers.(list_sep (pair PP.environment_element bool) (const " || ")) e_lst
Michelson.pp code
(L.get ())
in
ok @@ (error title content) in
let%bind _ =
Trace.trace_tzresult_lwt_r error @@
Memory_proto_alpha.parse_michelson code
input_stack_ty output_stack_ty in
ok ()
in
ok code ok code
let select_env : environment -> environment -> michelson result = fun source filter -> let select_env : environment -> environment -> michelson result = fun source filter ->
@ -158,23 +91,6 @@ let pack : environment -> michelson result = fun e ->
Assert.assert_true (List.length e <> 0) in Assert.assert_true (List.length e <> 0) in
let code = seq @@ List.map (Function.constant i_pair) @@ List.tl e in let code = seq @@ List.map (Function.constant i_pair) @@ List.tl e in
let%bind () =
let%bind (Stack.Ex_stack_ty input_stack_ty) = Compiler_type.Ty.environment e in
let repr = Environment.closure_representation e in
let%bind (Ex_ty output_ty) = Compiler_type.Ty.type_ repr in
let output_stack_ty = Stack.(output_ty @: nil) in
let error () =
let title () = "error producing Env.pack" in
let content () = Format.asprintf ""
in
ok @@ (error title content) in
let%bind _ =
Trace.trace_tzresult_lwt_r error @@
Memory_proto_alpha.parse_michelson code
input_stack_ty output_stack_ty in
ok ()
in
ok code ok code
let unpack : environment -> michelson result = fun e -> let unpack : environment -> michelson result = fun e ->
@ -192,26 +108,6 @@ let unpack : environment -> michelson result = fun e ->
] in ] in
let code = aux l in let code = aux l in
let%bind () =
let%bind (Stack.Ex_stack_ty output_stack_ty) = Compiler_type.Ty.environment e in
let repr = Environment.closure_representation e in
let%bind (Ex_ty input_ty) = Compiler_type.Ty.type_ repr in
let input_stack_ty = Stack.(input_ty @: nil) in
let error () =
let title () = "error producing Env.unpack" in
let content () = Format.asprintf "\nEnvironment:%a\nType Representation:%a\nCode:%a\n"
PP.environment e
PP.type_ repr
Michelson.pp code
in
ok @@ (error title content) in
let%bind _ =
Trace.trace_tzresult_lwt_r error @@
Memory_proto_alpha.parse_michelson code
input_stack_ty output_stack_ty in
ok ()
in
ok code ok code
@ -239,53 +135,11 @@ let pack_select : environment -> string list -> michelson result = fun e lst ->
in in
List.fold_right' aux (true , seq []) e_lst in List.fold_right' aux (true , seq []) e_lst in
let%bind () =
let%bind (Stack.Ex_stack_ty input_stack_ty) = Compiler_type.Ty.environment e in
let e' =
Environment.of_list
@@ List.map fst
@@ List.filter snd
@@ e_lst
in
let%bind (Ex_ty output_ty) = Compiler_type.Ty.environment_representation e' in
let output_stack_ty = Stack.(output_ty @: input_stack_ty) in
let error () =
let title () = "error producing Env.pack_select" in
let content () = Format.asprintf "\nInput : %a\nOutput : %a\nList : {%a}\nCode : %a\nLog : %s\n"
PP.environment e
PP.environment e'
PP_helpers.(list_sep (pair PP.environment_element bool) (const " || ")) e_lst
Michelson.pp code
(L.get ())
in
ok @@ (error title content) in
let%bind _ =
Trace.trace_tzresult_lwt_r error @@
Memory_proto_alpha.parse_michelson code
input_stack_ty output_stack_ty in
ok ()
in
ok code ok code
let add_packed_anon : environment -> type_value -> michelson result = fun e type_value -> let add_packed_anon : environment -> type_value -> michelson result = fun _e _type_value ->
let code = seq [i_pair] in let code = seq [i_pair] in
let%bind () =
let error () = ok @@ simple_error "error producing add packed" in
let%bind (Ex_ty input_ty) = Compiler_type.Ty.environment_representation e in
let e' = Environment.add ("_add_packed_anon" , type_value) e in
let%bind (Ex_ty output_ty) = Compiler_type.Ty.environment_representation e' in
let%bind (Ex_ty ty) = Compiler_type.Ty.type_ type_value in
let input_stack_ty = Stack.(ty @: input_ty @: nil) in
let output_stack_ty = Stack.(output_ty @: nil) in
let%bind _ =
Trace.trace_tzresult_lwt_r error @@
Memory_proto_alpha.parse_michelson code
input_stack_ty output_stack_ty in
ok ()
in
ok code ok code
let pop : environment -> environment result = fun e -> let pop : environment -> environment result = fun e ->

13
src/compiler/compiler_program.ml
View File

@ -2,10 +2,8 @@ open Trace
open Mini_c open Mini_c
open Michelson open Michelson
module Stack = Meta_michelson.Stack
module Contract_types = Meta_michelson.Types
open Memory_proto_alpha.Script_ir_translator open Memory_proto_alpha.Protocol.Script_ir_translator
open Operators.Compiler open Operators.Compiler
@ -141,9 +139,9 @@ and translate_expression ?push_var_name (expr:expression) (env:environment) : (m
else ok end_env else ok end_env
) )
in in
let%bind (Stack.Ex_stack_ty input_stack_ty) = Compiler_type.Ty.environment env in let%bind (Ex_stack_ty input_stack_ty) = Compiler_type.Ty.environment env in
let%bind output_type = Compiler_type.type_ ty in let%bind output_type = Compiler_type.type_ ty in
let%bind (Stack.Ex_stack_ty output_stack_ty) = Compiler_type.Ty.environment env' in let%bind (Ex_stack_ty output_stack_ty) = Compiler_type.Ty.environment env' in
let error_message () = let error_message () =
let%bind schema_michelsons = Compiler_type.environment env in let%bind schema_michelsons = Compiler_type.environment env in
ok @@ Format.asprintf ok @@ Format.asprintf
@ -470,10 +468,11 @@ and translate_quote_body ({result ; binder ; input} as f:anon_function) : michel
] in ] in
let%bind _assert_type = let%bind _assert_type =
let open Memory_proto_alpha.Protocol.Script_typed_ir in
let%bind (Ex_ty input_ty) = Compiler_type.Ty.type_ f.input in let%bind (Ex_ty input_ty) = Compiler_type.Ty.type_ f.input in
let%bind (Ex_ty output_ty) = Compiler_type.Ty.type_ f.output in let%bind (Ex_ty output_ty) = Compiler_type.Ty.type_ f.output in
let input_stack_ty = Stack.(input_ty @: nil) in let input_stack_ty = Item_t (input_ty, Empty_t, None) in
let output_stack_ty = Stack.(output_ty @: nil) in let output_stack_ty = Item_t (output_ty, Empty_t, None) in
let error_message () = let error_message () =
Format.asprintf Format.asprintf
"\nCode : %a\nMichelson code : %a\ninput : %a\noutput : %a\nstart env : %a\nend env : %a\n" "\nCode : %a\nMichelson code : %a\ninput : %a\noutput : %a\nstart env : %a\nend env : %a\n"

70
src/compiler/compiler_type.ml
View File

@ -2,18 +2,52 @@ open Trace
open Mini_c.Types open Mini_c.Types
open Proto_alpha_utils.Memory_proto_alpha open Proto_alpha_utils.Memory_proto_alpha
open Protocol
open Script_ir_translator open Script_ir_translator
module O = Tezos_utils.Michelson module O = Tezos_utils.Michelson
module Contract_types = Meta_michelson.Types
module Ty = struct module Ty = struct
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) ()
open Script_typed_ir
let nat_k = Nat_key None
let tez_k = Mutez_key None
let int_k = Int_key None
let string_k = String_key None
let address_k = Address_key None
let timestamp_k = Timestamp_key None
let bytes_k = Bytes_key None
(* let timestamp_k = Timestamp_key None *)
let unit = Unit_t None
let bytes = Bytes_t None
let nat = Nat_t None
let tez = Mutez_t None
let int = Int_t None
let big_map k v = Big_map_t (k, v, None)
let signature = Signature_t None
let operation = Operation_t None
let bool = Bool_t None
let mutez = Mutez_t None
let string = String_t None
let key = Key_t None
let list a = List_t (a, None)
let set a = Set_t (a, None)
let address = Address_t None
let option a = Option_t ((a, None), None, None)
let contract a = Contract_t (a, None)
let lambda a b = Lambda_t (a, b, None)
let timestamp = Timestamp_t None
let map a b = Map_t (a, b, None)
let pair a b = Pair_t ((a, None, None), (b, None, None), None)
let union a b = Union_t ((a, None), (b, None), None)
let comparable_type_base : type_base -> ex_comparable_ty result = fun tb -> let comparable_type_base : type_base -> ex_comparable_ty result = fun tb ->
let open Contract_types in
let return x = ok @@ Ex_comparable_ty x in let return x = ok @@ Ex_comparable_ty x in
match tb with match tb with
| Base_unit -> fail (not_comparable "unit") | Base_unit -> fail (not_comparable "unit")
@ -42,7 +76,6 @@ module Ty = struct
| T_contract _ -> fail (not_comparable "contract") | T_contract _ -> fail (not_comparable "contract")
let base_type : type_base -> ex_ty result = fun b -> let base_type : type_base -> ex_ty result = fun b ->
let open Contract_types in
let return x = ok @@ Ex_ty x in let return x = ok @@ Ex_ty x in
match b with match b with
| Base_unit -> return unit | Base_unit -> return unit
@ -63,57 +96,56 @@ module Ty = struct
| T_pair (t, t') -> ( | T_pair (t, t') -> (
type_ t >>? fun (Ex_ty t) -> type_ t >>? fun (Ex_ty t) ->
type_ t' >>? fun (Ex_ty t') -> type_ t' >>? fun (Ex_ty t') ->
ok @@ Ex_ty (Contract_types.pair t t') ok @@ Ex_ty (pair t t')
) )
| T_or (t, t') -> ( | T_or (t, t') -> (
type_ t >>? fun (Ex_ty t) -> type_ t >>? fun (Ex_ty t) ->
type_ t' >>? fun (Ex_ty t') -> type_ t' >>? fun (Ex_ty t') ->
ok @@ Ex_ty (Contract_types.union t t') ok @@ Ex_ty (union t t')
) )
| T_function (arg, ret) -> | T_function (arg, ret) ->
let%bind (Ex_ty arg) = type_ arg in let%bind (Ex_ty arg) = type_ arg in
let%bind (Ex_ty ret) = type_ ret in let%bind (Ex_ty ret) = type_ ret in
ok @@ Ex_ty (Contract_types.lambda arg ret) ok @@ Ex_ty (lambda arg ret)
| T_deep_closure (c, arg, ret) -> | T_deep_closure (c, arg, ret) ->
let%bind (Ex_ty capture) = environment_representation c in let%bind (Ex_ty capture) = environment_representation c in
let%bind (Ex_ty arg) = type_ arg in let%bind (Ex_ty arg) = type_ arg in
let%bind (Ex_ty ret) = type_ ret in let%bind (Ex_ty ret) = type_ ret in
ok @@ Ex_ty Contract_types.(pair (lambda (pair arg capture) ret) capture) ok @@ Ex_ty (pair (lambda (pair arg capture) ret) capture)
| T_map (k, v) -> | T_map (k, v) ->
let%bind (Ex_comparable_ty k') = comparable_type k in let%bind (Ex_comparable_ty k') = comparable_type k in
let%bind (Ex_ty v') = type_ v in let%bind (Ex_ty v') = type_ v in
ok @@ Ex_ty Contract_types.(map k' v') ok @@ Ex_ty (map k' v')
| T_list t -> | T_list t ->
let%bind (Ex_ty t') = type_ t in let%bind (Ex_ty t') = type_ t in
ok @@ Ex_ty Contract_types.(list t') ok @@ Ex_ty (list t')
| T_set t -> ( | T_set t -> (
let%bind (Ex_comparable_ty t') = comparable_type t in let%bind (Ex_comparable_ty t') = comparable_type t in
ok @@ Ex_ty Contract_types.(set t') ok @@ Ex_ty (set t')
) )
| T_option t -> | T_option t ->
let%bind (Ex_ty t') = type_ t in let%bind (Ex_ty t') = type_ t in
ok @@ Ex_ty Contract_types.(option t') ok @@ Ex_ty (option t')
| T_contract t -> | T_contract t ->
let%bind (Ex_ty t') = type_ t in let%bind (Ex_ty t') = type_ t in
ok @@ Ex_ty Contract_types.(contract t') ok @@ Ex_ty (contract t')
and environment_representation = function and environment_representation = function
| [] -> ok @@ Ex_ty Contract_types.unit | [] -> ok @@ Ex_ty unit
| [a] -> type_ @@ snd a | [a] -> type_ @@ snd a
| a::b -> | a::b ->
let%bind (Ex_ty a) = type_ @@ snd a in let%bind (Ex_ty a) = type_ @@ snd a in
let%bind (Ex_ty b) = environment_representation b in let%bind (Ex_ty b) = environment_representation b in
ok @@ Ex_ty (Contract_types.pair a b) ok @@ Ex_ty (pair a b)
and environment : environment -> Meta_michelson.Stack.ex_stack_ty result = fun env -> and environment : environment -> ex_stack_ty result = fun env ->
let open Meta_michelson in
let%bind lst = let%bind lst =
bind_map_list type_ bind_map_list type_
@@ List.map snd env in @@ List.map snd env in
let aux (Stack.Ex_stack_ty st) (Ex_ty cur) = let aux (Ex_stack_ty st) (Ex_ty cur) =
Stack.Ex_stack_ty (Stack.stack cur st) Ex_stack_ty (Item_t (cur, st, None))
in in
ok @@ List.fold_right' aux (Ex_stack_ty Stack.nil) lst ok @@ List.fold_right' aux (Ex_stack_ty Empty_t) lst
end end

4
src/compiler/dune
View File

@ -3,13 +3,13 @@
(public_name ligo.compiler) (public_name ligo.compiler)
(libraries (libraries
simple-utils simple-utils
proto-alpha-utils
tezos-utils tezos-utils
meta_michelson
mini_c mini_c
operators operators
) )
(preprocess (preprocess
(pps simple-utils.ppx_let_generalized) (pps ppx_let)
) )
(flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils -open Tezos_utils )) (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils -open Tezos_utils ))
) )

4
src/compiler/uncompiler.ml
View File

@ -1,6 +1,8 @@
open Mini_c.Types open Mini_c.Types
open Memory_proto_alpha open Proto_alpha_utils.Memory_proto_alpha
open X
open Proto_alpha_utils.Trace open Proto_alpha_utils.Trace
open Protocol
open Script_typed_ir open Script_typed_ir
open Script_ir_translator open Script_ir_translator

5
src/dune
View File

@ -6,11 +6,10 @@
simple-utils simple-utils
tezos-utils tezos-utils
tezos-micheline tezos-micheline
meta_michelson
main main
) )
(preprocess (preprocess
(pps simple-utils.ppx_let_generalized) (pps ppx_let)
) )
) )
@ -29,4 +28,4 @@
(name manual-test) (name manual-test)
(action (run test/manual_test.exe)) (action (run test/manual_test.exe))
(deps (glob_files contracts/*)) (deps (glob_files contracts/*))
) )

2
src/main/dune
View File

@ -15,7 +15,7 @@
compiler compiler
) )
(preprocess (preprocess
(pps simple-utils.ppx_let_generalized) (pps ppx_let)
) )
(flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils -open Tezos_utils )) (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils -open Tezos_utils ))
) )

7
src/main/run_mini_c.ml
View File

@ -2,7 +2,8 @@ open Proto_alpha_utils
open Trace open Trace
open Mini_c open Mini_c
open! Compiler.Program open! Compiler.Program
open Memory_proto_alpha.Script_ir_translator open Memory_proto_alpha.Protocol.Script_ir_translator
open Memory_proto_alpha.X
let run_aux ?options (program:compiled_program) (input_michelson:Michelson.t) : ex_typed_value result = let run_aux ?options (program:compiled_program) (input_michelson:Michelson.t) : ex_typed_value result =
let Compiler.Program.{input;output;body} : compiled_program = program in let Compiler.Program.{input;output;body} : compiled_program = program in
@ -15,8 +16,8 @@ let run_aux ?options (program:compiled_program) (input_michelson:Michelson.t) :
let%bind descr = let%bind descr =
Trace.trace_tzresult_lwt (simple_error "error parsing program code") @@ Trace.trace_tzresult_lwt (simple_error "error parsing program code") @@
Memory_proto_alpha.parse_michelson body Memory_proto_alpha.parse_michelson body
(Stack.(input_ty @: nil)) (Stack.(output_ty @: nil)) in (Item_t (input_ty, Empty_t, None)) (Item_t (output_ty, Empty_t, None)) in
let open! Memory_proto_alpha.Script_interpreter in let open! Memory_proto_alpha.Protocol.Script_interpreter in
let%bind (Item(output, Empty)) = let%bind (Item(output, Empty)) =
Trace.trace_tzresult_lwt (simple_error "error of execution") @@ Trace.trace_tzresult_lwt (simple_error "error of execution") @@
Memory_proto_alpha.interpret ?options descr (Item(input, Empty)) in Memory_proto_alpha.interpret ?options descr (Item(input, Empty)) in

6
src/main/run_source.ml
View File

@ -259,7 +259,7 @@ let run_contract ?amount source_filename entry_point storage input syntax =
parsify_expression syntax input in parsify_expression syntax input in
let options = let options =
let open Proto_alpha_utils.Memory_proto_alpha in let open Proto_alpha_utils.Memory_proto_alpha in
let amount = Option.bind (fun amount -> Alpha_context.Tez.of_string amount) amount in let amount = Option.bind (fun amount -> Protocol.Alpha_context.Tez.of_string amount) amount in
(make_options ?amount ()) in (make_options ?amount ()) in
Run_simplified.run_simplityped ~options typed entry_point (Ast_simplified.e_pair storage_simpl input_simpl) Run_simplified.run_simplityped ~options typed entry_point (Ast_simplified.e_pair storage_simpl input_simpl)
@ -271,7 +271,7 @@ let run_function ?amount source_filename entry_point parameter syntax =
parsify_expression syntax parameter in parsify_expression syntax parameter in
let options = let options =
let open Proto_alpha_utils.Memory_proto_alpha in let open Proto_alpha_utils.Memory_proto_alpha in
let amount = Option.bind (fun amount -> Alpha_context.Tez.of_string amount) amount in let amount = Option.bind (fun amount -> Protocol.Alpha_context.Tez.of_string amount) amount in
(make_options ?amount ()) in (make_options ?amount ()) in
Run_simplified.run_simplityped ~options typed entry_point parameter' Run_simplified.run_simplityped ~options typed entry_point parameter'
@ -281,6 +281,6 @@ let evaluate_value ?amount source_filename entry_point syntax =
type_file syntax source_filename in type_file syntax source_filename in
let options = let options =
let open Proto_alpha_utils.Memory_proto_alpha in let open Proto_alpha_utils.Memory_proto_alpha in
let amount = Option.bind (fun amount -> Alpha_context.Tez.of_string amount) amount in let amount = Option.bind (fun amount -> Protocol.Alpha_context.Tez.of_string amount) amount in
(make_options ?amount ()) in (make_options ?amount ()) in
Run_simplified.evaluate_simplityped ~options typed entry_point Run_simplified.evaluate_simplityped ~options typed entry_point

30
src/meta_michelson/alpha_wrap.ml
View File

@ -1,30 +0,0 @@
open Proto_alpha_utils.Error_monad
let dummy_environment = force_lwt ~msg:"getting dummy env" @@ Misc.init_environment ()
let tc = dummy_environment.tezos_context
module Proto_alpha = Proto_alpha_utils.Memory_proto_alpha
open Proto_alpha
open Alpha_context
open Alpha_environment
let pack ty v = fst @@ force_lwt_alpha ~msg:"packing" @@ Script_ir_translator.pack_data tc ty v
let unpack_opt (type a) : a Script_typed_ir.ty -> MBytes.t -> a option = fun ty bytes ->
force_lwt ~msg:"unpacking : parse" (
if Compare.Int.(MBytes.length bytes >= 1) &&
Compare.Int.(MBytes.get_uint8 bytes 0 = 0x05) then
let bytes = MBytes.sub bytes 1 (MBytes.length bytes - 1) in
match Data_encoding.Binary.of_bytes Script.expr_encoding bytes with
| None -> return None
| Some expr ->
Script_ir_translator.parse_data tc ty (Micheline.root expr) >>=?? fun x -> return (Some (fst x))
else
return None
)
let unpack ty a = match unpack_opt ty a with
| None -> raise @@ Failure "unpacking : of_bytes"
| Some x -> x
let blake2b b = Alpha_environment.Raw_hashes.blake2b b

317
src/meta_michelson/contract.ml
View File

@ -1,317 +0,0 @@
open Misc
open Proto_alpha_utils.Error_monad
open Memory_proto_alpha
open Alpha_context
open Script_ir_translator
open Script_typed_ir
module Option = Simple_utils.Option
module Cast = Proto_alpha_utils.Cast
type ('param, 'storage) toplevel = {
param_type : 'param ty ;
storage_type : 'storage ty ;
code : ('param * 'storage, packed_internal_operation list * 'storage) lambda
}
type ex_toplevel =
Ex_toplevel : ('a, 'b) toplevel -> ex_toplevel
let get_toplevel ?environment toplevel_path claimed_storage_type claimed_parameter_type =
let toplevel_str = Streams.read_file toplevel_path in
contextualize ?environment ~msg:"toplevel" @@ fun {tezos_context = context ; _ } ->
let toplevel_expr = Cast.tl_of_string toplevel_str in
let (param_ty_node, storage_ty_node, code_field) =
force_ok_alpha ~msg:"parsing toplevel" @@
parse_toplevel toplevel_expr in
let (Ex_ty param_type, _) =
force_ok_alpha ~msg:"parse arg ty" @@
Script_ir_translator.parse_ty context ~allow_big_map:false ~allow_operation:false param_ty_node in
let (Ex_ty storage_type, _) =
force_ok_alpha ~msg:"parse storage ty" @@
parse_storage_ty context storage_ty_node in
let _ = force_ok_alpha ~msg:"storage eq" @@ Script_ir_translator.ty_eq context storage_type claimed_storage_type in
let _ = force_ok_alpha ~msg:"param eq" @@ Script_ir_translator.ty_eq context param_type claimed_parameter_type in
let param_type_full = Pair_t ((claimed_parameter_type, None, None),
(claimed_storage_type, None, None), None) in
let ret_type_full =
Pair_t ((List_t (Operation_t None, None), None, None),
(claimed_storage_type, None, None), None) in
parse_returning (Toplevel { storage_type = claimed_storage_type ; param_type = claimed_parameter_type })
context (param_type_full, None) ret_type_full code_field >>=?? fun (code, _) ->
Error_monad.return {
param_type = claimed_parameter_type;
storage_type = claimed_storage_type;
code ;
}
let make_toplevel code storage_type param_type =
{ param_type ; storage_type ; code }
module type ENVIRONMENT = sig
val identities : identity list
val tezos_context : t
end
type ex_typed_stack = Ex_typed_stack : ('a stack_ty * 'a Script_interpreter.stack) -> ex_typed_stack
open Error_monad
module Step (Env: ENVIRONMENT) = struct
open Env
type config = {
source : Contract.t option ;
payer : Contract.t option ;
self : Contract.t option ;
visitor : (Script_interpreter.ex_descr_stack -> unit) option ;
timestamp : Script_timestamp.t option ;
debug_visitor : (ex_typed_stack -> unit) option ;
amount : Tez.t option ;
}
let no_config = {
source = None ;
payer = None ;
self = None ;
visitor = None ;
debug_visitor = None ;
timestamp = None ;
amount = None ;
}
let of_param base param = match param with
| None -> base
| Some _ as x -> x
let make_config ?base_config ?source ?payer ?self ?visitor ?debug_visitor ?timestamp ?amount () =
let base_config = Option.unopt ~default:no_config base_config in {
source = Option.bind_eager_or source base_config.source ;
payer = Option.bind_eager_or payer base_config.payer ;
self = Option.bind_eager_or self base_config.self ;
visitor = Option.bind_eager_or visitor base_config.visitor ;
debug_visitor = Option.bind_eager_or debug_visitor base_config.debug_visitor ;
timestamp = Option.bind_eager_or timestamp base_config.timestamp ;
amount = Option.bind_eager_or amount base_config.amount ;
}
open Error_monad
let debug_visitor ?f () =
let open Script_interpreter in
let aux (Ex_descr_stack (descr, stack)) =
(match (descr.instr, descr.bef) with
| Nop, Item_t (String_t _, stack_ty, _) -> (
let (Item (s, stack)) = stack in
if s = "_debug"
then (
match f with
| None -> Format.printf "debug: %s\n%!" @@ Cast.stack_to_string stack_ty stack
| Some f -> f (Ex_typed_stack(stack_ty, stack))
) else ()
)
| _ -> ()) ;
() in
aux
let step_lwt ?(config=no_config) (stack:'a Script_interpreter.stack) (code:('a, 'b) descr) =
let source = Option.unopt
~default:(List.nth identities 0).implicit_contract config.source in
let payer = Option.unopt
~default:(List.nth identities 1).implicit_contract config.payer in
let self = Option.unopt
~default:(List.nth identities 2).implicit_contract config.self in
let amount = Option.unopt ~default:(Tez.one) config.amount in
let visitor =
let default = debug_visitor ?f:config.debug_visitor () in
Option.unopt ~default config.visitor in
let tezos_context = match config.timestamp with
| None -> tezos_context
| Some s -> Alpha_context.Script_timestamp.set_now tezos_context s in
Script_interpreter.step tezos_context ~source ~payer ~self ~visitor amount code stack >>=?? fun (stack, _) ->
return stack
let step_1_2 ?config (a:'a) (descr:('a * end_of_stack, 'b * ('c * end_of_stack)) descr) =
let open Script_interpreter in
step_lwt ?config (Item(a, Empty)) descr >>=? fun (Item(b, Item(c, Empty))) ->
return (b, c)
let step_3_1 ?config (a:'a) (b:'b) (c:'c)
(descr:('a * ('b * ('c * end_of_stack)), 'd * end_of_stack) descr) =
let open Script_interpreter in
step_lwt ?config (Item(a, Item(b, Item(c, Empty)))) descr >>=? fun (Item(d, Empty)) ->
return d
let step_2_1 ?config (a:'a) (b:'b) (descr:('a * ('b * end_of_stack), 'c * end_of_stack) descr) =
let open Script_interpreter in
step_lwt ?config (Item(a, Item(b, Empty))) descr >>=? fun (Item(c, Empty)) ->
return c
let step_1_1 ?config (a:'a) (descr:('a * end_of_stack, 'b * end_of_stack) descr) =
let open Script_interpreter in
step_lwt ?config (Item(a, Empty)) descr >>=? fun (Item(b, Empty)) ->
return b
let step_value ?config (a:'a) (descr:('a * end_of_stack, 'a * end_of_stack) descr) =
step_1_1 ?config a descr
let step ?config stack code =
force_lwt ~msg:"running a step" @@ step_lwt ?config stack code
end
let run_lwt_full ?source ?payer ?self toplevel storage param {identities ; tezos_context = context} =
let { code ; _ } : (_, _) toplevel = toplevel in
let source = Option.unopt
~default:(List.nth identities 0).implicit_contract source in
let payer = Option.unopt
~default:(List.nth identities 1).implicit_contract payer in
let self = Option.unopt
~default:(List.nth identities 2).implicit_contract self in
let amount = Tez.one in
Script_interpreter.interp context ~source ~payer ~self amount code (param, storage)
>>=?? fun ((ops, storage), new_ctxt) ->
let gas = Alpha_context.Gas.consumed ~since:context ~until:new_ctxt in
return (storage, ops, gas)
let run_lwt ?source ?payer ?self toplevel storage param env =
run_lwt_full ?source ?payer ?self toplevel storage param env >>=? fun (storage, _ops, _gas) ->
return storage
let run ?environment toplevel storage param =
contextualize ?environment ~msg:"run toplevel" @@ run_lwt toplevel storage param
let run_node ?environment toplevel storage_node param_node =
contextualize ?environment ~msg:"run toplevel" @@ fun {tezos_context = context ; _} ->
let {param_type ; storage_type ; _ } = toplevel in
parse_data context param_type param_node >>=?? fun (param, _) ->
parse_data context storage_type storage_node >>=?? fun (storage, _) ->
let storage = run toplevel storage param in
unparse_data context Readable storage_type storage >>=?? fun (storage_node, _) ->
return storage_node
let run_str toplevel storage_str param_str =
let param_node = Cast.node_of_string param_str in
let storage_node = Cast.node_of_string storage_str in
run_node toplevel storage_node param_node
type input = {
toplevel_path : string ;
storage : string ;
parameter : string
}
let parse_json json_str : input =
let json = force_ok_str ~msg:"main_contract: invalid json" @@ Tezos_utils.Data_encoding.Json.from_string json_str in
let json = match json with
| `O json -> json
| _ -> raise @@ Failure "main_contract: not recorD"
in
let open Json in
let toplevel_path = force_string ~msg:"main_contract, top_level" @@ List.assoc "top_level" json in
let parameter = force_string ~msg:"main_contract, param" @@ List.assoc "param" json in
let storage = force_string ~msg:"main_contract, storage" @@ List.assoc "storage" json in
{ toplevel_path ; storage ; parameter }
let generate_json (storage_node:Script.node) : string =
let storage_expr = Tezos_micheline.Micheline.strip_locations storage_node in
let json = Data_encoding.Json.construct Script.expr_encoding storage_expr in
Format.fprintf Format.str_formatter "%a" Data_encoding.Json.pp json ;
Format.flush_str_formatter ()
module Types = struct
open Script_typed_ir
let union a b = Union_t ((a, None), (b, None), None)
let assert_union = function
| Union_t ((a, _), (b, _), _) -> (a, b)
| _ -> assert false
let pair a b = Pair_t ((a, None, None), (b, None, None), None)
let assert_pair = function
| Pair_t ((a, _, _), ((b, _, _)), _) -> (a, b)
| _ -> assert false
let assert_pair_ex ?(msg="assert pair") (Ex_ty ty) = match ty with
| Pair_t ((a, _, _), ((b, _, _)), _) -> (Ex_ty a, Ex_ty b)
| _ -> raise (Failure msg)
let unit = Unit_t None
let bytes = Bytes_t None
let bytes_k = Bytes_key None
let nat = Nat_t None
let tez = Mutez_t None
let int = Int_t None
let nat_k = Nat_key None
let tez_k = Mutez_key None
let int_k = Int_key None
let big_map k v = Big_map_t (k, v, None)
let signature = Signature_t None
let operation = Operation_t None
let bool = Bool_t None
let mutez = Mutez_t None
let string = String_t None
let string_k = String_key None
let address_k = Address_key None
let key = Key_t None
let list a = List_t (a, None)
let set a = Set_t (a, None)
let assert_list = function
| List_t (a, _) -> a
| _ -> assert false
let option a = Option_t ((a, None), None, None)
let contract a = Contract_t (a, None)
let assert_option = function
| Option_t ((a, _), _, _) -> a
| _ -> assert false
let address = Address_t None
let lambda a b = Lambda_t (a, b, None)
let assert_lambda = function
| Lambda_t (a, b, _) -> (a, b)
| _ -> assert false
type ex_lambda = Ex_lambda : (_, _) lambda ty -> ex_lambda
let is_lambda : type a . a ty -> ex_lambda option = function
| Lambda_t (_, _, _) as x -> Some (Ex_lambda x)
| _ -> None
let timestamp = Timestamp_t None
let timestamp_k = Timestamp_key None
let map a b = Map_t (a, b, None)
let assert_type (_:'a ty) (_:'a) = ()
end
module Values = struct
let empty_map t = empty_map t
let empty_big_map key_type comparable_key_ty value_type : ('a, 'b) big_map = {
key_type ; value_type ; diff = empty_map comparable_key_ty ;
}
let int n = Script_int.of_int n
let nat n = Script_int.abs @@ Script_int.of_int n
let nat_to_int n = Option.unopt_exn @@ Script_int.to_int n
let tez n = Option.unopt_exn @@ Tez.of_mutez @@ Int64.of_int n
let left a = L a
let right b = R b
end

11
src/meta_michelson/dune
View File

@ -1,11 +0,0 @@
(library
(name meta_michelson)
(public_name ligo.meta_michelson)
(libraries
simple-utils
tezos-utils
proto-alpha-utils
michelson-parser
tezos-micheline
)
)

7
src/meta_michelson/json.ml
View File

@ -1,7 +0,0 @@
let force_record ~msg json = match json with
| `O json -> json
| _ -> raise @@ Failure ("not json record : " ^ msg)
let force_string ~msg json = match json with
| `String str -> str
| _ -> raise @@ Failure ("not json str : " ^ msg)

12
src/meta_michelson/meta_michelson.ml
View File

@ -1,12 +0,0 @@
module Run = struct
open Contract
let run_lwt_full = run_lwt_full
let run_lwt = run_lwt
let run_str = run_str
let run_node = run_node
let run = run
end
module Stack = Michelson_wrap.Stack
module Values = Contract.Values
module Types = Contract.Types

514
src/meta_michelson/michelson_wrap.ml
View File

@ -1,514 +0,0 @@
open Proto_alpha_utils.Memory_proto_alpha
module AC = Alpha_context
module Types = Contract.Types
module Option = Simple_utils.Option
module MBytes = Alpha_environment.MBytes
module Stack = struct
open Script_typed_ir
let descr bef aft instr =
{
loc = 0 ;
bef ; aft ; instr
}
type nonrec 'a ty = 'a ty
type 'a t = 'a stack_ty
type nonrec ('a, 'b) descr = ('a, 'b) descr
type ('a, 'b) code = ('a t) -> ('a, 'b) descr
type ex_stack_ty = Ex_stack_ty : 'a t -> ex_stack_ty
type ex_descr = Ex_descr : ('a, 'b) descr -> ex_descr
type ex_code = Ex_code : ('a, 'b) code -> ex_code
let stack ?annot a b = Item_t (a, b, annot)
let unstack (item: (('a * 'rest) stack_ty)) : ('a ty * 'rest stack_ty) =
let Item_t (hd, tl, _) = item in
(hd, tl)
let nil = Empty_t
let head x = fst @@ unstack x
let tail x = snd @@ unstack x
let seq a b bef =
let a_descr = a bef in
let b_descr = b a_descr.aft in
let aft = b_descr.aft in
descr bef aft @@ Seq (a_descr, b_descr)
let (@>) (stack : 'b t) (code : ('a, 'b) code) = code stack
let (@|) = seq
let (@:) = stack
let (!:) : ('a, 'b) descr -> ('a, 'b) code = fun d _ -> d
let (<.) (stack:'a t) (code: ('a, 'b) code): ('a, 'b) descr = code stack
let (<::) : ('a, 'b) descr -> ('b, 'c) descr -> ('a, 'c) descr = fun ab bc ->
descr ab.bef bc.aft @@ Seq(ab, bc)
let (<:) (ab_descr:('a, 'b) descr) (code:('b, 'c) code) : ('a, 'c) descr =
let bc_descr = code ab_descr.aft in
ab_descr <:: bc_descr
end
open Stack
type nat = AC.Script_int.n AC.Script_int.num
type int_num = AC.Script_int.z AC.Script_int.num
type bytes = MBytes.t
type address = AC.Contract.t Script_typed_ir.ty
type mutez = AC.Tez.t Script_typed_ir.ty
module Stack_ops = struct
open Script_typed_ir
let dup : ('a * 'rest, 'a * ('a * 'rest)) code = fun bef ->
let Item_t (ty, rest, _) = bef in
descr bef (Item_t (ty, Item_t (ty, rest, None), None)) Dup
let drop : ('a * 'rest, 'rest) code = fun bef ->
let aft = snd @@ unstack bef in
descr bef aft Drop
let swap (bef : (('a * ('b * 'c)) stack_ty)) =
let Item_t (a, Item_t (b, rest, _), _) = bef in
descr bef (Item_t (b, (Item_t (a, rest, None)), None)) Swap
let dip code (bef : ('ty * 'rest) stack_ty) =
let Item_t (ty, rest, _) = bef in
let applied = code rest in
let aft = Item_t (ty, applied.aft, None) in
descr bef aft (Dip (code rest))
let noop : ('r, 'r) code = fun bef ->
descr bef bef Nop
let exec : (_, _) code = fun bef ->
let lambda = head @@ tail bef in
let (_, ret) = Types.assert_lambda lambda in
let aft = ret @: (tail @@ tail bef) in
descr bef aft Exec
let fail aft : ('a * 'r, 'b) code = fun bef ->
let head = fst @@ unstack bef in
descr bef aft (Failwith head)
let push_string str (bef : 'rest stack_ty) : (_, (string * 'rest)) descr =
let aft = Item_t (Types.string, bef, None) in
descr bef aft (Const (str))
let push_none (a:'a ty) : ('rest, 'a option * 'rest) code = fun r ->
let aft = stack (Types.option a) r in
descr r aft (Const None)
let push_unit : ('rest, unit * 'rest) code = fun r ->
let aft = stack Types.unit r in
descr r aft (Const ())
let push_nat n (bef : 'rest stack_ty) : (_, (nat * 'rest)) descr =
let aft = Item_t (Types.nat, bef, None) in
descr bef aft (Const (Contract.Values.nat n))
let push_int n (bef : 'rest stack_ty) : (_, (int_num * 'rest)) descr =
let aft = Types.int @: bef in
descr bef aft (Const (Contract.Values.int n))
let push_tez n (bef : 'rest stack_ty) : (_, (AC.Tez.tez * 'rest)) descr =
let aft = Types.mutez @: bef in
descr bef aft (Const (Contract.Values.tez n))
let push_bool b : ('s, bool * 's) code = fun bef ->
let aft = stack Types.bool bef in
descr bef aft (Const b)
let push_generic ty v : ('s, _ * 's) code = fun bef ->
let aft = stack ty bef in
descr bef aft (Const v)
let failstring str aft =
push_string str @| fail aft
end
module Stack_shortcuts = struct
open Stack_ops
let diip c x = dip (dip c) x
let diiip c x = dip (diip c) x
let diiiip c x = dip (diiip c) x
let bubble_1 = swap
let bubble_down_1 = swap
let bubble_2 : ('a * ('b * ('c * 'r)), 'c * ('a * ('b * 'r))) code = fun bef ->
bef <. dip swap <: swap
let bubble_down_2 : ('a * ('b * ('c * 'r)), ('b * ('c * ('a * 'r)))) code = fun bef ->
bef <. swap <: dip swap
let bubble_3 : ('a * ('b * ('c * ('d * 'r))), 'd * ('a * ('b * ('c * 'r)))) code = fun bef ->
bef <. diip swap <: dip swap <: swap
let keep_1 : type r s . ('a * r, s) code -> ('a * r, 'a * s) code = fun code bef ->
bef <. dup <: dip code
let save_1_1 : type r . ('a * r, 'b * r) code -> ('a * r, 'b * ('a * r)) code = fun code s ->
s <. keep_1 code <: swap
let keep_2 : type r s . ('a * ('b * r), s) code -> ('a * ('b * r), ('a * ('b * s))) code = fun code bef ->
(dup @| dip (swap @| dup @| dip (swap @| code))) bef
let keep_2_1 : type r s . ('a * ('b * r), s) code -> ('a * ('b * r), 'b * s) code = fun code bef ->
(dip dup @| swap @| dip code) bef
let relativize_1_1 : ('a * unit, 'b * unit) descr -> ('a * 'r, 'b * 'r) code = fun d s ->
let aft = head d.aft @: tail s in
descr s aft d.instr
end
module Pair_ops = struct
let car (bef : (('a * 'b) * 'rest) Stack.t) =
let (pair, rest) = unstack bef in
let (a, _) = Contract.Types.assert_pair pair in
descr bef (stack a rest) Car
let cdr (bef : (('a * 'b) * 'rest) Stack.t) =
let (pair, rest) = unstack bef in
let (_, b) = Contract.Types.assert_pair pair in
descr bef (stack b rest) Cdr
let pair (bef : ('a * ('b * 'rest)) Stack.t) =
let (a, rest) = unstack bef in
let (b, rest) = unstack rest in
let aft = (Types.pair a b) @: rest in
descr bef aft Cons_pair
open Stack_ops
let carcdr s = s <. car <: Stack_ops.dip cdr
let cdrcar s = s <. cdr <: dip car
let cdrcdr s = s <. cdr <: dip cdr
let carcar s = s <. car <: dip car
let cdar s = s <. cdr <: car
let unpair s = s <. dup <: car <: dip cdr
end
module Option_ops = struct
open Script_typed_ir
let cons bef =
let (hd, tl) = unstack bef in
descr bef (stack (Contract.Types.option hd) tl) Cons_some
let cond ?target none_branch some_branch : ('a option * 'r, 'b) code = fun bef ->
let (a_opt, base) = unstack bef in
let a = Types.assert_option a_opt in
let target = Option.unopt ~default:(none_branch base).aft target in
descr bef target (If_none (none_branch base, some_branch (stack a base)))
let force_some ?msg : ('a option * 'r, 'a * 'r) code = fun s ->
let (a_opt, base) = unstack s in
let a = Types.assert_option a_opt in
let target = a @: base in
cond ~target
(Stack_ops.failstring ("force_some : " ^ Option.unopt ~default:"" msg) target)
Stack_ops.noop s
end
module Union_ops = struct
open Script_typed_ir
let left (b:'b ty) : ('a * 'r, ('a, 'b) union * 'r) code = fun bef ->
let (a, base) = unstack bef in
let aft = Types.union a b @: base in
descr bef aft Left
let right (a:'a ty) : ('b * 'r, ('a, 'b) union * 'r) code = fun bef ->
let (b, base) = unstack bef in
let aft = Types.union a b @: base in
descr bef aft Right
let loop ?after (code: ('a * 'r, ('a, 'b) union * 'r) code): (('a, 'b) union * 'r, 'b * 'r) code = fun bef ->
let (union, base) = unstack bef in
let (a, b) = Types.assert_union union in
let code_stack = a @: base in
let aft = Option.unopt ~default:(b @: base) after in
descr bef aft (Loop_left (code code_stack))
end
module Arithmetic = struct
let neq : (int_num * 'r, bool *'r) code = fun bef ->
let aft = stack Types.bool @@ snd @@ unstack bef in
descr bef aft Neq
let neg : (int_num * 'r, int_num *'r) code = fun bef ->
let aft = stack Types.int @@ snd @@ unstack bef in
descr bef aft Neg_int
let abs : (int_num * 'r, nat *'r) code = fun bef ->
let aft = stack Types.nat @@ snd @@ unstack bef in
descr bef aft Abs_int
let int : (nat * 'r, int_num*'r) code = fun bef ->
let aft = stack Types.int @@ snd @@ unstack bef in
descr bef aft Int_nat
let nat_opt : (int_num * 'r, nat option * 'r) code = fun bef ->
let aft = stack Types.(option nat) @@ tail bef in
descr bef aft Is_nat
let nat_neq = fun s -> (int @| neq) s
let add_natnat (bef : (nat * (nat * 'rest)) Stack.t) =
let (nat, rest) = unstack bef in
let rest = tail rest in
let aft = stack nat rest in
descr bef aft Add_natnat
let add_intint (bef : (int_num * (int_num * 'rest)) Stack.t) =
let (nat, rest) = unstack bef in
let rest = tail rest in
let aft = stack nat rest in
descr bef aft Add_intint
let add_teztez : (AC.Tez.tez * (AC.Tez.tez * 'rest), _) code = fun bef ->
let aft = tail bef in
descr bef aft Add_tez
let mul_natnat (bef : (nat * (nat * 'rest)) Stack.t) =
let nat = head bef in
let rest = tail @@ tail bef in
let aft = stack nat rest in
descr bef aft Mul_natnat
let mul_intint (bef : (int_num * (int_num * 'rest)) Stack.t) =
let nat = head bef in
let rest = tail @@ tail bef in
let aft = stack nat rest in
descr bef aft Mul_intint
let sub_intint : (int_num * (int_num * 'r), int_num * 'r) code = fun bef ->
let aft = tail bef in
descr bef aft Sub_int
let sub_natnat : (nat * (nat * 'r), int_num * 'r) code =
fun bef -> bef <. int <: Stack_ops.dip int <: sub_intint
let ediv : (nat * (nat * 'r), (nat * nat) option * 'r) code = fun s ->
let (n, base) = unstack @@ snd @@ unstack s in
let aft = Types.option (Types.pair n n) @: base in
descr s aft Ediv_natnat
let ediv_tez = fun s ->
let aft = Types.(option @@ pair (head s) (head s)) @: tail @@ tail s in
descr s aft Ediv_teznat
open Option_ops
let force_ediv x = x <. ediv <: force_some
let force_ediv_tez x = (ediv_tez @| force_some) x
open Pair_ops
let div x = x <. force_ediv <: car
open Stack_ops
let div_n n s = s <. push_nat n <: swap <: div
let add_n n s = s <. push_nat n <: swap <: add_natnat
let add_teztez_n n s = s <. push_tez n <: swap <: add_teztez
let sub_n n s = s <. push_nat n <: swap <: sub_natnat
let force_nat s = s <. nat_opt <: force_some ~msg:"force nat"
end
module Boolean = struct
let bool_and (type r) : (bool * (bool * r), bool * r) code = fun bef ->
let aft = Types.bool @: tail @@ tail bef in
descr bef aft And
let bool_or (type r) : (bool * (bool * r), bool * r) code = fun bef ->
let aft = Types.bool @: tail @@ tail bef in
descr bef aft Or
open Script_typed_ir
let cond ?target true_branch false_branch : (bool * 'r, 's) code = fun bef ->
let base = tail bef in
let aft = Option.unopt ~default:((true_branch base).aft) target in
descr bef aft (If (true_branch base, false_branch base))
let loop (code : ('s, bool * 's) code) : ((bool * 's), 's) code = fun bef ->
let aft = tail bef in
descr bef aft @@ Loop (code aft)
end
module Comparison_ops = struct
let cmp c_ty : _ code = fun bef ->
let aft = stack Contract.Types.int @@ tail @@ tail @@ bef in
descr bef aft (Compare c_ty)
let cmp_bytes = fun x -> cmp (Bytes_key None) x
let eq : (int_num * 'r, bool *'r) code = fun bef ->
let aft = stack Contract.Types.bool @@ snd @@ unstack bef in
descr bef aft Eq
open Arithmetic
let eq_n n s = s <. sub_n n <: eq
let ge : (int_num * 'r, bool * 'r) code = fun bef ->
let base = tail bef in
let aft = stack Types.bool base in
descr bef aft Ge
let gt : (int_num * 'r, bool * 'r) code = fun bef ->
let base = tail bef in
let aft = stack Types.bool base in
descr bef aft Gt
let lt : (int_num * 'r, bool * 'r) code = fun bef ->
let base = tail bef in
let aft = stack Types.bool base in
descr bef aft Lt
let gt_nat s = s <. int <: gt
open Stack_ops
let assert_positive_nat s = s <. dup <: gt_nat <: Boolean.cond noop (failstring "positive" s)
let cmp_ge_nat : (nat * (nat * 'r), bool * 'r) code = fun bef ->
bef <. sub_natnat <: ge
let cmp_ge_timestamp : (AC.Script_timestamp.t * (AC.Script_timestamp.t * 'r), bool * 'r) code = fun bef ->
bef <. cmp Types.timestamp_k <: ge
let assert_cmp_ge_nat : (nat * (nat * 'r), 'r) code = fun bef ->
bef <. cmp_ge_nat <: Boolean.cond noop (failstring "assert cmp ge nat" (tail @@ tail bef))
let assert_cmp_ge_timestamp : (AC.Script_timestamp.t * (AC.Script_timestamp.t * 'r), 'r) code = fun bef ->
bef <. cmp_ge_timestamp <: Boolean.cond noop (failstring "assert cmp ge timestamp" (tail @@ tail bef))
end
module Bytes = struct
open Script_typed_ir
let pack (ty:'a ty) : ('a * 'r, bytes * 'r) code = fun bef ->
let aft = stack Types.bytes @@ tail bef in
descr bef aft (Pack ty)
let unpack_opt : type a . a ty -> (bytes * 'r, a option * 'r) code = fun ty bef ->
let aft = stack (Types.option ty) (tail bef) in
descr bef aft (Unpack ty)
let unpack ty s = s <. unpack_opt ty <: Option_ops.force_some
let concat : (MBytes.t * (MBytes.t * 'rest), MBytes.t * 'rest) code = fun bef ->
let aft = tail bef in
descr bef aft Concat_bytes_pair
let sha256 : (MBytes.t * 'rest, MBytes.t * 'rest) code = fun bef ->
descr bef bef Sha256
let blake2b : (MBytes.t * 'rest, MBytes.t * 'rest) code = fun bef ->
descr bef bef Blake2b
end
module Map = struct
open Script_typed_ir
type ('a, 'b) t = ('a, 'b) map
let empty c_ty = Script_ir_translator.empty_map c_ty
let set (type a b) m (k:a) (v:b) = Script_ir_translator.map_update k (Some v) m
module Ops = struct
let update (bef : (('a * ('b option * (('a, 'b) map * ('rest)))) Stack.t)) : (_, ('a, 'b) map * 'rest) descr =
let Item_t (_, Item_t (_, Item_t (map, rest, _), _), _) = bef in
let aft = Item_t (map, rest, None) in
descr bef aft Map_update
let get : ?a:('a ty) -> 'b ty -> ('a * (('a, 'b) map * 'r), 'b option * 'r) code = fun ?a b bef ->
let _ = a in
let base = snd @@ unstack @@ snd @@ unstack bef in
let aft = stack (Types.option b) base in
descr bef aft Map_get
let big_get : 'a ty -> 'b ty -> ('a * (('a, 'b) big_map * 'r), 'b option * 'r) code = fun _a b bef ->
let base = snd @@ unstack @@ snd @@ unstack bef in
let aft = stack (Types.option b) base in
descr bef aft Big_map_get
let big_update : ('a * ('b option * (('a, 'b) big_map * 'r)), ('a, 'b) big_map * 'r) code = fun bef ->
let base = tail @@ tail bef in
descr bef base Big_map_update
end
end
module List_ops = struct
let nil ele bef =
let aft = stack (Types.list ele) bef in
descr bef aft Nil
let cons bef =
let aft = tail bef in
descr bef aft Cons_list
let cond ~target cons_branch nil_branch bef =
let (lst, aft) = unstack bef in
let a = Types.assert_list lst in
let cons_descr = cons_branch (a @: Types.list a @: aft) in
let nil_descr = nil_branch aft in
descr bef target (If_cons (cons_descr, nil_descr))
let list_iter : type a r . (a * r, r) code -> (a list * r, r) code = fun code bef ->
let (a_lst, aft) = unstack bef in
let a = Types.assert_list a_lst in
descr bef aft (List_iter (code (a @: aft)))
end
module Tez = struct
let amount : ('r, AC.Tez.t * 'r) code = fun bef ->
let aft = Types.mutez @: bef in
descr bef aft Amount
open Bytes
let tez_nat s = s <. pack Types.mutez <: unpack Types.nat
let amount_nat s = s <. amount <: pack Types.mutez <: unpack Types.nat
end
module Misc = struct
open Stack_ops
open Stack_shortcuts
open Comparison_ops
let min_nat : (nat * (nat * 'r), nat * 'r) code = fun s ->
s <.
keep_2 cmp_ge_nat <: bubble_2 <:
Boolean.cond drop (dip drop)
let debug ~msg () s = s <. push_string msg <: push_string "_debug" <: noop <: drop <: drop
let debug_msg msg = debug ~msg ()
let now : ('r, AC.Script_timestamp.t * 'r) code = fun bef ->
let aft = stack Types.timestamp bef in
descr bef aft Now
end

302
src/meta_michelson/misc.ml
View File

@ -1,302 +0,0 @@
module Signature = Tezos_base.TzPervasives.Signature
open Proto_alpha_utils.Memory_proto_alpha
module Data_encoding = Alpha_environment.Data_encoding
module MBytes = Alpha_environment.MBytes
module Error_monad = Proto_alpha_utils.Error_monad
open Error_monad
module Context_init = struct
type account = {
pkh : Signature.Public_key_hash.t ;
pk : Signature.Public_key.t ;
sk : Signature.Secret_key.t ;
}
let generate_accounts n : (account * Tez_repr.t) list =
let amount = Tez_repr.of_mutez_exn 4_000_000_000_000L in
List.map (fun _ ->
let (pkh, pk, sk) = Signature.generate_key () in
let account = { pkh ; pk ; sk } in
account, amount)
(Simple_utils.List.range n)
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 = Alpha_environment.Context_hash.zero ;
}
let default_proof_of_work_nonce =
MBytes.create Alpha_context.Constants.proof_of_work_nonce_size
let protocol_param_key = [ "protocol_parameters" ]
let check_constants_consistency constants =
let open Constants_repr in
let open Error_monad 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
constants
header
commitments
initial_accounts
security_deposit_ramp_up_cycles
no_reward_cycles
=
let open Tezos_base.TzPervasives.Error_monad in
let bootstrap_accounts =
List.map (fun ({ pk ; pkh ; _ }, amount) ->
let open! Parameters_repr in
{ public_key_hash = pkh ; public_key = Some pk ; amount }
) initial_accounts
in
let json =
Data_encoding.Json.construct
Parameters_repr.encoding
Parameters_repr.{
bootstrap_accounts ;
bootstrap_contracts = [] ;
commitments ;
constants ;
security_deposit_ramp_up_cycles ;
no_reward_cycles ;
}
in
let proto_params =
Data_encoding.Binary.to_bytes_exn Data_encoding.json json
in
Tezos_protocol_environment_memory.Context.(
set empty ["version"] (MBytes.of_string "genesis")
) >>= fun ctxt ->
Tezos_protocol_environment_memory.Context.(
set ctxt protocol_param_key proto_params
) >>= fun ctxt ->
Main.init ctxt header
>|= Alpha_environment.wrap_error >>=? fun { context; _ } ->
return context
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 = [])
?(security_deposit_ramp_up_cycles = None)
?(no_reward_cycles = None)
(initial_accounts : (account * Tez_repr.t) list)
=
if initial_accounts = [] then
Pervasives.failwith "Must have one account with a roll to bake";
(* Check there is at least one roll *)
let open Tezos_base.TzPervasives.Error_monad 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 = {
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 ;
} in
check_constants_consistency constants >>=? fun () ->
let hash =
Alpha_environment.Block_hash.of_b58check_exn "BLockGenesisGenesisGenesisGenesisGenesisCCCCCeZiLHU"
in
let shell = make_shell
~level:0l
~predecessor:hash
~timestamp:Tezos_utils.Time.epoch
~fitness: (Fitness_repr.from_int64 0L)
~operations_hash: Alpha_environment.Operation_list_list_hash.zero in
initial_context
constants
shell
commitments
initial_accounts
security_deposit_ramp_up_cycles
no_reward_cycles
>>=? fun context ->
return (context, shell, hash)
let init
?(slow=false)
?preserved_cycles
?endorsers_per_block
?commitments
n =
let open Error_monad in
let accounts = generate_accounts n in
let contracts = List.map (fun (a, _) ->
Alpha_context.Contract.implicit_contract (a.pkh)) accounts in
begin
if slow then
genesis
?preserved_cycles
?endorsers_per_block
?commitments
accounts
else
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
accounts
end >>=? fun ctxt ->
return (ctxt, accounts, contracts)
let contents
?(proof_of_work_nonce = default_proof_of_work_nonce)
?(priority = 0) ?seed_nonce_hash () =
Alpha_context.Block_header.({
priority ;
proof_of_work_nonce ;
seed_nonce_hash ;
})
let begin_construction ?(priority=0) ~timestamp ~(header:Alpha_context.Block_header.shell_header) ~hash ctxt =
let contents = contents ~priority () in
let protocol_data =
let open! Alpha_context.Block_header in {
contents ;
signature = Signature.zero ;
} in
let header = {
Alpha_context.Block_header.shell = {
predecessor = hash ;
proto_level = header.proto_level ;
validation_passes = header.validation_passes ;
fitness = header.fitness ;
timestamp ;
level = header.level ;
context = Alpha_environment.Context_hash.zero ;
operations_hash = Alpha_environment.Operation_list_list_hash.zero ;
} ;
protocol_data = {
contents ;
signature = Signature.zero ;
} ;
} in
Main.begin_construction
~chain_id: Alpha_environment.Chain_id.zero
~predecessor_context: ctxt
~predecessor_timestamp: header.shell.timestamp
~predecessor_fitness: header.shell.fitness
~predecessor_level: header.shell.level
~predecessor:hash
~timestamp
~protocol_data
() >>= fun x -> Lwt.return @@ Alpha_environment.wrap_error x >>=? fun state ->
return state.ctxt
let main n =
init n >>=? fun ((ctxt, header, hash), accounts, contracts) ->
let timestamp = Tezos_base.Time.now () in
begin_construction ~timestamp ~header ~hash ctxt >>=? fun ctxt ->
return (ctxt, accounts, contracts)
end
type identity = {
public_key_hash : Signature.public_key_hash;
public_key : Signature.public_key;
secret_key : Signature.secret_key;
implicit_contract : Alpha_context.Contract.t;
}
type environment = {
tezos_context : Alpha_context.t ;
identities : identity list ;
}
let init_environment () =
Context_init.main 10 >>=? fun (tezos_context, accounts, contracts) ->
let accounts = List.map fst accounts in
let tezos_context = Alpha_context.Gas.set_limit tezos_context @@ Z.of_int 350000 in
let identities =
List.map (fun ((a:Context_init.account), c) -> {
public_key = a.pk ;
public_key_hash = a.pkh ;
secret_key = a.sk ;
implicit_contract = c ;
}) @@
List.combine accounts contracts in
return {tezos_context ; identities}
let contextualize ~msg ?environment f =
let lwt =
let environment = match environment with
| None -> init_environment ()
| Some x -> return x in
environment >>=? f
in
force_ok ~msg @@ Lwt_main.run lwt

18
src/meta_michelson/streams.ml
View File

@ -1,18 +0,0 @@
let read_file f =
let ic = open_in f in
let n = in_channel_length ic in
let s = Bytes.create n in
really_input ic s 0 n;
close_in ic;
Bytes.to_string s
let read_lines filename =
let lines = ref [] in
let chan = open_in filename in
try
while true; do
lines := input_line chan :: !lines
done; !lines
with End_of_file ->
close_in chan;
List.rev !lines

3
src/mini_c/dune
View File

@ -4,10 +4,9 @@
(libraries (libraries
simple-utils simple-utils
tezos-utils tezos-utils
meta_michelson
) )
(preprocess (preprocess
(pps simple-utils.ppx_let_generalized) (pps ppx_let)
) )
(flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils )) (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils ))
) )

2
src/mini_c/types.ml
View File

@ -51,7 +51,7 @@ type value =
| D_set of value list | D_set of value list
(* | `Macro of anon_macro ... The future. *) (* | `Macro of anon_macro ... The future. *)
| D_function of anon_function | D_function of anon_function
| D_operation of Memory_proto_alpha.Alpha_context.packed_internal_operation | D_operation of Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation
and selector = var_name list and selector = var_name list

2
src/operators/dune
View File

@ -8,7 +8,7 @@
mini_c mini_c
) )
(preprocess (preprocess
(pps simple-utils.ppx_let_generalized) (pps ppx_let)
) )
(flags (:standard -open Simple_utils )) (flags (:standard -open Simple_utils ))
) )

2
src/parser/camligo/dune
View File

@ -10,7 +10,7 @@
(flags (:standard -w +1..62-4-9-44-40-42-48@39@33 -open Simple_utils -open Tezos_utils )) (flags (:standard -w +1..62-4-9-44-40-42-48@39@33 -open Simple_utils -open Tezos_utils ))
(preprocess (preprocess
(pps (pps
simple-utils.ppx_let_generalized ppx_let
ppx_deriving.std ppx_deriving.std
) )
) )

2
src/parser/dune
View File

@ -10,7 +10,7 @@
parser_ligodity parser_ligodity
) )
(preprocess (preprocess
(pps simple-utils.ppx_let_generalized) (pps ppx_let)
) )
(flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils -open Parser_shared )) (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils -open Parser_shared ))
) )

2
src/simplify/dune
View File

@ -10,7 +10,7 @@
(modules ligodity pascaligo simplify) (modules ligodity pascaligo simplify)
(preprocess (preprocess
(pps (pps
simple-utils.ppx_let_generalized ppx_let
) )
) )
(flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils )) (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils ))

2
src/test/dune
View File

@ -6,7 +6,7 @@
alcotest alcotest
) )
(preprocess (preprocess
(pps simple-utils.ppx_let_generalized) (pps ppx_let)
) )
(flags (:standard -w +1..62-4-9-44-40-42-48@39@33 -open Simple_utils )) (flags (:standard -w +1..62-4-9-44-40-42-48@39@33 -open Simple_utils ))
) )

2
src/transpiler/dune
View File

@ -9,7 +9,7 @@
operators operators
) )
(preprocess (preprocess
(pps simple-utils.ppx_let_generalized) (pps ppx_let)
) )
(flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils )) (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils ))
) )

2
src/typer/dune
View File

@ -9,7 +9,7 @@
operators operators
) )
(preprocess (preprocess
(pps simple-utils.ppx_let_generalized) (pps ppx_let)
) )
(flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils )) (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils ))
) )

2
vendors/ligo-utils/memory-proto-alpha/dune-project vendored Normal file
View File

@ -0,0 +1,2 @@
(lang dune 1.11)
(name tezos-memory-proto-alpha)

195
vendors/ligo-utils/proto-alpha-utils/cast.ml vendored
View File

@ -4,6 +4,7 @@ open Tezos_micheline
let env = Error_monad.force_lwt ~msg:"Cast:init environment" @@ Init_proto_alpha.init_environment () let env = Error_monad.force_lwt ~msg:"Cast:init environment" @@ Init_proto_alpha.init_environment ()
open Memory_proto_alpha open Memory_proto_alpha
open Protocol
open Alpha_context open Alpha_context
exception Expr_from_string exception Expr_from_string
@ -44,6 +45,196 @@ let node_to_string (node:_ Micheline.node) =
open Script_ir_translator open Script_ir_translator
type ex_typed_value =
Ex_typed_value : ('a Script_typed_ir.ty * 'a) -> ex_typed_value
include struct
open Script_typed_ir
open Protocol.Environment.Error_monad
module Unparse_costs = Michelson_v1_gas.Cost_of.Unparse
open Micheline
open Michelson_v1_primitives
open Protocol.Environment
let rec unparse_data_generic
: type a. context -> ?mapper:(ex_typed_value -> Script.node option tzresult Lwt.t) ->
unparsing_mode -> a ty -> a -> (Script.node * context) tzresult Lwt.t
= fun ctxt ?(mapper = fun _ -> return None) mode ty a ->
Lwt.return (Gas.consume ctxt Unparse_costs.cycle) >>=? fun ctxt ->
mapper (Ex_typed_value (ty, a)) >>=? function
| Some x -> return (x, ctxt)
| None -> (
match ty, a with
| Unit_t _, () ->
Lwt.return (Gas.consume ctxt Unparse_costs.unit) >>=? fun ctxt ->
return (Prim (-1, D_Unit, [], []), ctxt)
| Int_t _, v ->
Lwt.return (Gas.consume ctxt (Unparse_costs.int v)) >>=? fun ctxt ->
return (Int (-1, Script_int.to_zint v), ctxt)
| Nat_t _, v ->
Lwt.return (Gas.consume ctxt (Unparse_costs.int v)) >>=? fun ctxt ->
return (Int (-1, Script_int.to_zint v), ctxt)
| String_t _, s ->
Lwt.return (Gas.consume ctxt (Unparse_costs.string s)) >>=? fun ctxt ->
return (String (-1, s), ctxt)
| Bytes_t _, s ->
Lwt.return (Gas.consume ctxt (Unparse_costs.bytes s)) >>=? fun ctxt ->
return (Bytes (-1, s), ctxt)
| Bool_t _, true ->
Lwt.return (Gas.consume ctxt Unparse_costs.bool) >>=? fun ctxt ->
return (Prim (-1, D_True, [], []), ctxt)
| Bool_t _, false ->
Lwt.return (Gas.consume ctxt Unparse_costs.bool) >>=? fun ctxt ->
return (Prim (-1, D_False, [], []), ctxt)
| Timestamp_t _, t ->
Lwt.return (Gas.consume ctxt (Unparse_costs.timestamp t)) >>=? fun ctxt ->
begin
match mode with
| Optimized -> return (Int (-1, Script_timestamp.to_zint t), ctxt)
| Readable ->
match Script_timestamp.to_notation t with
| None -> return (Int (-1, Script_timestamp.to_zint t), ctxt)
| Some s -> return (String (-1, s), ctxt)
end
| Address_t _, c ->
Lwt.return (Gas.consume ctxt Unparse_costs.contract) >>=? fun ctxt ->
begin
match mode with
| Optimized ->
let bytes = Data_encoding.Binary.to_bytes_exn Contract.encoding c in
return (Bytes (-1, bytes), ctxt)
| Readable -> return (String (-1, Contract.to_b58check c), ctxt)
end
| Contract_t _, (_, c) ->
Lwt.return (Gas.consume ctxt Unparse_costs.contract) >>=? fun ctxt ->
begin
match mode with
| Optimized ->
let bytes = Data_encoding.Binary.to_bytes_exn Contract.encoding c in
return (Bytes (-1, bytes), ctxt)
| Readable -> return (String (-1, Contract.to_b58check c), ctxt)
end
| Signature_t _, s ->
Lwt.return (Gas.consume ctxt Unparse_costs.signature) >>=? fun ctxt ->
begin
match mode with
| Optimized ->
let bytes = Data_encoding.Binary.to_bytes_exn Signature.encoding s in
return (Bytes (-1, bytes), ctxt)
| Readable ->
return (String (-1, Signature.to_b58check s), ctxt)
end
| Mutez_t _, v ->
Lwt.return (Gas.consume ctxt Unparse_costs.tez) >>=? fun ctxt ->
return (Int (-1, Z.of_int64 (Tez.to_mutez v)), ctxt)
| Key_t _, k ->
Lwt.return (Gas.consume ctxt Unparse_costs.key) >>=? fun ctxt ->
begin
match mode with
| Optimized ->
let bytes = Data_encoding.Binary.to_bytes_exn Signature.Public_key.encoding k in
return (Bytes (-1, bytes), ctxt)
| Readable ->
return (String (-1, Signature.Public_key.to_b58check k), ctxt)
end
| Key_hash_t _, k ->
Lwt.return (Gas.consume ctxt Unparse_costs.key_hash) >>=? fun ctxt ->
begin
match mode with
| Optimized ->
let bytes = Data_encoding.Binary.to_bytes_exn Signature.Public_key_hash.encoding k in
return (Bytes (-1, bytes), ctxt)
| Readable ->
return (String (-1, Signature.Public_key_hash.to_b58check k), ctxt)
end
| Operation_t _, op ->
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 ->
return (Bytes (-1, bytes), ctxt)
| Pair_t ((tl, _, _), (tr, _, _), _), (l, r) ->
Lwt.return (Gas.consume ctxt Unparse_costs.pair) >>=? fun ctxt ->
unparse_data_generic ~mapper ctxt mode tl l >>=? fun (l, ctxt) ->
unparse_data_generic ~mapper ctxt mode tr r >>=? fun (r, ctxt) ->
return (Prim (-1, D_Pair, [ l; r ], []), ctxt)
| Union_t ((tl, _), _, _), L l ->
Lwt.return (Gas.consume ctxt Unparse_costs.union) >>=? fun ctxt ->
unparse_data_generic ~mapper ctxt mode tl l >>=? fun (l, ctxt) ->
return (Prim (-1, D_Left, [ l ], []), ctxt)
| Union_t (_, (tr, _), _), R r ->
Lwt.return (Gas.consume ctxt Unparse_costs.union) >>=? fun ctxt ->
unparse_data_generic ~mapper ctxt mode tr r >>=? fun (r, ctxt) ->
return (Prim (-1, D_Right, [ r ], []), ctxt)
| Option_t ((t, _), _, _), Some v ->
Lwt.return (Gas.consume ctxt Unparse_costs.some) >>=? fun ctxt ->
unparse_data_generic ~mapper ctxt mode t v >>=? fun (v, ctxt) ->
return (Prim (-1, D_Some, [ v ], []), ctxt)
| Option_t _, None ->
Lwt.return (Gas.consume ctxt Unparse_costs.none) >>=? fun ctxt ->
return (Prim (-1, D_None, [], []), ctxt)
| List_t (t, _), items ->
fold_left_s
(fun (l, ctxt) element ->
Lwt.return (Gas.consume ctxt Unparse_costs.list_element) >>=? fun ctxt ->
unparse_data_generic ~mapper ctxt mode t element >>=? fun (unparsed, ctxt) ->
return (unparsed :: l, ctxt))
([], ctxt)
items >>=? fun (items, ctxt) ->
return (Micheline.Seq (-1, List.rev items), ctxt)
| Set_t (t, _), set ->
let t = ty_of_comparable_ty t in
fold_left_s
(fun (l, ctxt) item ->
Lwt.return (Gas.consume ctxt Unparse_costs.set_element) >>=? fun ctxt ->
unparse_data_generic ~mapper ctxt mode t item >>=? fun (item, ctxt) ->
return (item :: l, ctxt))
([], ctxt)
(set_fold (fun e acc -> e :: acc) set []) >>=? fun (items, ctxt) ->
return (Micheline.Seq (-1, items), ctxt)
| Map_t (kt, vt, _), map ->
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 ~mapper ctxt mode kt k >>=? fun (key, ctxt) ->
unparse_data_generic ~mapper ctxt mode vt v >>=? fun (value, ctxt) ->
return (Prim (-1, D_Elt, [ key ; value ], []) :: l, ctxt))
([], ctxt)
(map_fold (fun k v acc -> (k, v) :: acc) map []) >>=? fun (items, ctxt) ->
return (Micheline.Seq (-1, items), ctxt)
| Big_map_t (_kt, _kv, _), _map ->
return (Micheline.Seq (-1, []), ctxt)
| Lambda_t _, Lam (_, original_code) ->
unparse_code_generic ~mapper ctxt mode (root original_code)
)
and unparse_code_generic ctxt ?mapper mode = function
| 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) ->
parse_data ctxt t data >>=? fun (data, ctxt) ->
unparse_data_generic ?mapper ctxt mode t data >>=? fun (data, ctxt) ->
Lwt.return (Gas.consume ctxt (Unparse_costs.prim_cost 2 annot)) >>=? fun ctxt ->
return (Prim (loc, I_PUSH, [ ty ; data ], annot), ctxt)
| Seq (loc, items) ->
fold_left_s
(fun (l, ctxt) item ->
unparse_code_generic ?mapper ctxt mode item >>=? fun (item, ctxt) ->
return (item :: l, ctxt))
([], ctxt) items >>=? fun (items, ctxt) ->
Lwt.return (Gas.consume ctxt (Unparse_costs.seq_cost (List.length items))) >>=? fun ctxt ->
return (Micheline.Seq (loc, List.rev items), ctxt)
| Prim (loc, prim, items, annot) ->
fold_left_s
(fun (l, ctxt) item ->
unparse_code_generic ?mapper ctxt mode item >>=? fun (item, ctxt) ->
return (item :: l, ctxt))
([], ctxt) items >>=? fun (items, ctxt) ->
Lwt.return (Gas.consume ctxt (Unparse_costs.prim_cost 3 annot)) >>=? fun ctxt ->
return (Prim (loc, prim, List.rev items, annot), ctxt)
| Int _ | String _ | Bytes _ as atom -> return (atom, ctxt)
end
let rec mapper (Ex_typed_value (ty, a)) = let rec mapper (Ex_typed_value (ty, a)) =
let open Alpha_environment.Error_monad in let open Alpha_environment.Error_monad in
let open Script_typed_ir in let open Script_typed_ir in
@ -67,7 +258,7 @@ let rec mapper (Ex_typed_value (ty, a)) =
and data_to_node (Ex_typed_value (ty, data)) = and data_to_node (Ex_typed_value (ty, data)) =
let tc = env.tezos_context in let tc = env.tezos_context in
let node_lwt = Script_ir_translator.unparse_data tc ~mapper Readable ty data in let node_lwt = unparse_data_generic tc ~mapper Readable ty data in
let node = fst @@ Error_monad.force_lwt_alpha ~msg:"data to string" node_lwt in let node = fst @@ Error_monad.force_lwt_alpha ~msg:"data to string" node_lwt in
node node
@ -125,7 +316,7 @@ let descr_to_node x =
| Car -> prim I_CAR | Car -> prim I_CAR
| Cdr -> prim I_CDR | Cdr -> prim I_CDR
| Cons_pair -> prim I_PAIR | Cons_pair -> prim I_PAIR
| Nop -> prim I_NOP | Nop -> Micheline.Seq (0, [prim I_UNIT ; prim I_DROP])
| Seq (a, b) -> Micheline.Seq (0, List.map f [Ex_descr a ; Ex_descr b]) | Seq (a, b) -> Micheline.Seq (0, List.map f [Ex_descr a ; Ex_descr b])
| Const v -> ( | Const v -> (
let (Item_t (ty, _, _)) = descr.aft in let (Item_t (ty, _, _)) = descr.aft in

1
vendors/ligo-utils/proto-alpha-utils/dune vendored
View File

@ -4,6 +4,7 @@
(libraries (libraries
tezos-error-monad tezos-error-monad
tezos-stdlib-unix tezos-stdlib-unix
tezos-protocol-alpha-parameters
tezos-memory-proto-alpha tezos-memory-proto-alpha
simple-utils simple-utils
tezos-utils tezos-utils

17
vendors/ligo-utils/proto-alpha-utils/init_proto_alpha.ml vendored
View File

@ -4,7 +4,7 @@ module Data_encoding = Alpha_environment.Data_encoding
module MBytes = Alpha_environment.MBytes module MBytes = Alpha_environment.MBytes
module Error_monad = X_error_monad module Error_monad = X_error_monad
open Error_monad open Error_monad
open Protocol
module Context_init = struct module Context_init = struct
@ -85,10 +85,10 @@ module Context_init = struct
let proto_params = let proto_params =
Data_encoding.Binary.to_bytes_exn Data_encoding.json json Data_encoding.Binary.to_bytes_exn Data_encoding.json json
in in
Tezos_protocol_environment_memory.Context.( Tezos_protocol_environment.Context.(
set empty ["version"] (MBytes.of_string "genesis") set Memory_context.empty ["version"] (MBytes.of_string "genesis")
) >>= fun ctxt -> ) >>= fun ctxt ->
Tezos_protocol_environment_memory.Context.( Tezos_protocol_environment.Context.(
set ctxt protocol_param_key proto_params set ctxt protocol_param_key proto_params
) >>= fun ctxt -> ) >>= fun ctxt ->
Main.init ctxt header Main.init ctxt header
@ -141,7 +141,7 @@ module Context_init = struct
with Exit -> return () with Exit -> return ()
end >>=? fun () -> end >>=? fun () ->
let constants : Constants_repr.parametric = { let constants : Constants_repr.parametric = Tezos_protocol_alpha_parameters.Default_parameters.({
preserved_cycles ; preserved_cycles ;
blocks_per_cycle ; blocks_per_cycle ;
blocks_per_commitment ; blocks_per_commitment ;
@ -162,7 +162,8 @@ module Context_init = struct
endorsement_reward ; endorsement_reward ;
cost_per_byte ; cost_per_byte ;
hard_storage_limit_per_operation ; hard_storage_limit_per_operation ;
} in test_chain_duration = constants_mainnet.test_chain_duration ;
}) in
check_constants_consistency constants >>=? fun () -> check_constants_consistency constants >>=? fun () ->
let hash = let hash =
@ -171,7 +172,7 @@ module Context_init = struct
let shell = make_shell let shell = make_shell
~level:0l ~level:0l
~predecessor:hash ~predecessor:hash
~timestamp:Tezos_base.TzPervasives.Time.epoch ~timestamp:Tezos_base.TzPervasives.Time.Protocol.epoch
~fitness: (Fitness_repr.from_int64 0L) ~fitness: (Fitness_repr.from_int64 0L)
~operations_hash: Alpha_environment.Operation_list_list_hash.zero in ~operations_hash: Alpha_environment.Operation_list_list_hash.zero in
initial_context initial_context
@ -246,7 +247,7 @@ module Context_init = struct
let main n = let main n =
init n >>=? fun ((ctxt, header, hash), accounts, contracts) -> init n >>=? fun ((ctxt, header, hash), accounts, contracts) ->
let timestamp = Tezos_base.Time.now () in let timestamp = Environment.Time.of_seconds @@ Int64.of_float @@ Unix.time () in
begin_construction ~timestamp ~header ~hash ctxt >>=? fun ctxt -> begin_construction ~timestamp ~header ~hash ctxt >>=? fun ctxt ->
return (ctxt, accounts, contracts) return (ctxt, accounts, contracts)

1
vendors/ligo-utils/proto-alpha-utils/proto-alpha-utils.opam vendored
View File

@ -39,6 +39,7 @@ depends: [
"tezos-data-encoding" "tezos-data-encoding"
"tezos-protocol-environment" "tezos-protocol-environment"
"tezos-protocol-alpha" "tezos-protocol-alpha"
"tezos-protocol-alpha-parameters"
"michelson-parser" "michelson-parser"
"simple-utils" "simple-utils"
"tezos-utils" "tezos-utils"

937
vendors/ligo-utils/proto-alpha-utils/x_memory_proto_alpha.ml vendored
View File

@ -4,15 +4,940 @@ include Memory_proto_alpha
let init_environment = Init_proto_alpha.init_environment let init_environment = Init_proto_alpha.init_environment
let dummy_environment = Init_proto_alpha.dummy_environment let dummy_environment = Init_proto_alpha.dummy_environment
open X_error_monad
open Protocol
open Script_typed_ir open Script_typed_ir
open Script_ir_translator open Script_ir_translator
open Script_interpreter open Script_interpreter
module X = struct
open Alpha_context
open Script_tc_errors
open Alpha_environment.Error_monad
let rec stack_ty_eq
: type ta tb. context -> int -> ta stack_ty -> tb stack_ty ->
((ta stack_ty, tb stack_ty) eq * context) tzresult
= fun ctxt lvl ta tb ->
match ta, tb with
| Item_t (tva, ra, _), Item_t (tvb, rb, _) ->
ty_eq ctxt tva tvb |>
record_trace (Bad_stack_item lvl) >>? fun (Eq, ctxt) ->
stack_ty_eq ctxt (lvl + 1) ra rb >>? fun (Eq, ctxt) ->
(Ok (Eq, ctxt) : ((ta stack_ty, tb stack_ty) eq * context) tzresult)
| Empty_t, Empty_t -> Ok (Eq, ctxt)
| _, _ -> error Bad_stack_length
open Script_typed_ir
open Protocol.Environment.Error_monad
module Unparse_costs = Michelson_v1_gas.Cost_of.Unparse
open Tezos_micheline.Micheline
open Michelson_v1_primitives
open Protocol.Environment
type ex_typed_value =
Ex_typed_value : ('a Script_typed_ir.ty * 'a) -> ex_typed_value
let rec unparse_data_generic
: type a. context -> ?mapper:(ex_typed_value -> Script.node option tzresult Lwt.t) ->
unparsing_mode -> a ty -> a -> (Script.node * context) tzresult Lwt.t
= fun ctxt ?(mapper = fun _ -> return None) mode ty a ->
Lwt.return (Gas.consume ctxt Unparse_costs.cycle) >>=? fun ctxt ->
mapper (Ex_typed_value (ty, a)) >>=? function
| Some x -> return (x, ctxt)
| None -> (
match ty, a with
| Unit_t _, () ->
Lwt.return (Gas.consume ctxt Unparse_costs.unit) >>=? fun ctxt ->
return (Prim (-1, D_Unit, [], []), ctxt)
| Int_t _, v ->
Lwt.return (Gas.consume ctxt (Unparse_costs.int v)) >>=? fun ctxt ->
return (Int (-1, Script_int.to_zint v), ctxt)
| Nat_t _, v ->
Lwt.return (Gas.consume ctxt (Unparse_costs.int v)) >>=? fun ctxt ->
return (Int (-1, Script_int.to_zint v), ctxt)
| String_t _, s ->
Lwt.return (Gas.consume ctxt (Unparse_costs.string s)) >>=? fun ctxt ->
return (String (-1, s), ctxt)
| Bytes_t _, s ->
Lwt.return (Gas.consume ctxt (Unparse_costs.bytes s)) >>=? fun ctxt ->
return (Bytes (-1, s), ctxt)
| Bool_t _, true ->
Lwt.return (Gas.consume ctxt Unparse_costs.bool) >>=? fun ctxt ->
return (Prim (-1, D_True, [], []), ctxt)
| Bool_t _, false ->
Lwt.return (Gas.consume ctxt Unparse_costs.bool) >>=? fun ctxt ->
return (Prim (-1, D_False, [], []), ctxt)
| Timestamp_t _, t ->
Lwt.return (Gas.consume ctxt (Unparse_costs.timestamp t)) >>=? fun ctxt ->
begin
match mode with
| Optimized -> return (Int (-1, Script_timestamp.to_zint t), ctxt)
| Readable ->
match Script_timestamp.to_notation t with
| None -> return (Int (-1, Script_timestamp.to_zint t), ctxt)
| Some s -> return (String (-1, s), ctxt)
end
| Address_t _, c ->
Lwt.return (Gas.consume ctxt Unparse_costs.contract) >>=? fun ctxt ->
begin
match mode with
| Optimized ->
let bytes = Data_encoding.Binary.to_bytes_exn Contract.encoding c in
return (Bytes (-1, bytes), ctxt)
| Readable -> return (String (-1, Contract.to_b58check c), ctxt)
end
| Contract_t _, (_, c) ->
Lwt.return (Gas.consume ctxt Unparse_costs.contract) >>=? fun ctxt ->
begin
match mode with
| Optimized ->
let bytes = Data_encoding.Binary.to_bytes_exn Contract.encoding c in
return (Bytes (-1, bytes), ctxt)
| Readable -> return (String (-1, Contract.to_b58check c), ctxt)
end
| Signature_t _, s ->
Lwt.return (Gas.consume ctxt Unparse_costs.signature) >>=? fun ctxt ->
begin
match mode with
| Optimized ->
let bytes = Data_encoding.Binary.to_bytes_exn Signature.encoding s in
return (Bytes (-1, bytes), ctxt)
| Readable ->
return (String (-1, Signature.to_b58check s), ctxt)
end
| Mutez_t _, v ->
Lwt.return (Gas.consume ctxt Unparse_costs.tez) >>=? fun ctxt ->
return (Int (-1, Z.of_int64 (Tez.to_mutez v)), ctxt)
| Key_t _, k ->
Lwt.return (Gas.consume ctxt Unparse_costs.key) >>=? fun ctxt ->
begin
match mode with
| Optimized ->
let bytes = Data_encoding.Binary.to_bytes_exn Signature.Public_key.encoding k in
return (Bytes (-1, bytes), ctxt)
| Readable ->
return (String (-1, Signature.Public_key.to_b58check k), ctxt)
end
| Key_hash_t _, k ->
Lwt.return (Gas.consume ctxt Unparse_costs.key_hash) >>=? fun ctxt ->
begin
match mode with
| Optimized ->
let bytes = Data_encoding.Binary.to_bytes_exn Signature.Public_key_hash.encoding k in
return (Bytes (-1, bytes), ctxt)
| Readable ->
return (String (-1, Signature.Public_key_hash.to_b58check k), ctxt)
end
| Operation_t _, op ->
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 ->
return (Bytes (-1, bytes), ctxt)
| Pair_t ((tl, _, _), (tr, _, _), _), (l, r) ->
Lwt.return (Gas.consume ctxt Unparse_costs.pair) >>=? fun ctxt ->
unparse_data_generic ~mapper ctxt mode tl l >>=? fun (l, ctxt) ->
unparse_data_generic ~mapper ctxt mode tr r >>=? fun (r, ctxt) ->
return (Prim (-1, D_Pair, [ l; r ], []), ctxt)
| Union_t ((tl, _), _, _), L l ->
Lwt.return (Gas.consume ctxt Unparse_costs.union) >>=? fun ctxt ->
unparse_data_generic ~mapper ctxt mode tl l >>=? fun (l, ctxt) ->
return (Prim (-1, D_Left, [ l ], []), ctxt)
| Union_t (_, (tr, _), _), R r ->
Lwt.return (Gas.consume ctxt Unparse_costs.union) >>=? fun ctxt ->
unparse_data_generic ~mapper ctxt mode tr r >>=? fun (r, ctxt) ->
return (Prim (-1, D_Right, [ r ], []), ctxt)
| Option_t ((t, _), _, _), Some v ->
Lwt.return (Gas.consume ctxt Unparse_costs.some) >>=? fun ctxt ->
unparse_data_generic ~mapper ctxt mode t v >>=? fun (v, ctxt) ->
return (Prim (-1, D_Some, [ v ], []), ctxt)
| Option_t _, None ->
Lwt.return (Gas.consume ctxt Unparse_costs.none) >>=? fun ctxt ->
return (Prim (-1, D_None, [], []), ctxt)
| List_t (t, _), items ->
fold_left_s
(fun (l, ctxt) element ->
Lwt.return (Gas.consume ctxt Unparse_costs.list_element) >>=? fun ctxt ->
unparse_data_generic ~mapper ctxt mode t element >>=? fun (unparsed, ctxt) ->
return (unparsed :: l, ctxt))
([], ctxt)
items >>=? fun (items, ctxt) ->
return (Micheline.Seq (-1, List.rev items), ctxt)
| Set_t (t, _), set ->
let t = ty_of_comparable_ty t in
fold_left_s
(fun (l, ctxt) item ->
Lwt.return (Gas.consume ctxt Unparse_costs.set_element) >>=? fun ctxt ->
unparse_data_generic ~mapper ctxt mode t item >>=? fun (item, ctxt) ->
return (item :: l, ctxt))
([], ctxt)
(set_fold (fun e acc -> e :: acc) set []) >>=? fun (items, ctxt) ->
return (Micheline.Seq (-1, items), ctxt)
| Map_t (kt, vt, _), map ->
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 ~mapper ctxt mode kt k >>=? fun (key, ctxt) ->
unparse_data_generic ~mapper ctxt mode vt v >>=? fun (value, ctxt) ->
return (Prim (-1, D_Elt, [ key ; value ], []) :: l, ctxt))
([], ctxt)
(map_fold (fun k v acc -> (k, v) :: acc) map []) >>=? fun (items, ctxt) ->
return (Micheline.Seq (-1, items), ctxt)
| Big_map_t (_kt, _kv, _), _map ->
return (Micheline.Seq (-1, []), ctxt)
| Lambda_t _, Lam (_, original_code) ->
unparse_code_generic ~mapper ctxt mode (root original_code)
)
and unparse_code_generic ctxt ?mapper mode = function
| 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) ->
parse_data ctxt t data >>=? fun (data, ctxt) ->
unparse_data_generic ?mapper ctxt mode t data >>=? fun (data, ctxt) ->
Lwt.return (Gas.consume ctxt (Unparse_costs.prim_cost 2 annot)) >>=? fun ctxt ->
return (Prim (loc, I_PUSH, [ ty ; data ], annot), ctxt)
| Seq (loc, items) ->
fold_left_s
(fun (l, ctxt) item ->
unparse_code_generic ?mapper ctxt mode item >>=? fun (item, ctxt) ->
return (item :: l, ctxt))
([], ctxt) items >>=? fun (items, ctxt) ->
Lwt.return (Gas.consume ctxt (Unparse_costs.seq_cost (List.length items))) >>=? fun ctxt ->
return (Micheline.Seq (loc, List.rev items), ctxt)
| Prim (loc, prim, items, annot) ->
fold_left_s
(fun (l, ctxt) item ->
unparse_code_generic ?mapper ctxt mode item >>=? fun (item, ctxt) ->
return (item :: l, ctxt))
([], ctxt) items >>=? fun (items, ctxt) ->
Lwt.return (Gas.consume ctxt (Unparse_costs.prim_cost 3 annot)) >>=? fun ctxt ->
return (Prim (loc, prim, List.rev items, annot), ctxt)
| Int _ | String _ | Bytes _ as atom -> return (atom, ctxt)
module Interp_costs = Michelson_v1_gas.Cost_of
type ex_descr_stack = Ex_descr_stack : (('a, 'b) descr * 'a stack) -> ex_descr_stack
let unparse_stack ctxt (stack, stack_ty) =
(* We drop the gas limit as this function is only used for debugging/errors. *)
let ctxt = Gas.set_unlimited ctxt in
let rec unparse_stack
: type a. a stack * a stack_ty -> (Script.expr * string option) list tzresult Lwt.t
= function
| Empty, Empty_t -> return_nil
| Item (v, rest), Item_t (ty, rest_ty, annot) ->
unparse_data ctxt Readable ty v >>=? fun (data, _ctxt) ->
unparse_stack (rest, rest_ty) >>=? fun rest ->
let annot = match Script_ir_annot.unparse_var_annot annot with
| [] -> None
| [ a ] -> Some a
| _ -> assert false in
let data = Micheline.strip_locations data in
return ((data, annot) :: rest) in
unparse_stack (stack, stack_ty)
let rec step
: type b a.
(?log: execution_trace ref ->
context ->
source: Contract.t ->
self: Contract.t ->
payer: Contract.t ->
?visitor: (ex_descr_stack -> unit) ->
Tez.t ->
(b, a) descr -> b stack ->
(a stack * context) tzresult Lwt.t) =
fun ?log ctxt ~source ~self ~payer ?visitor amount ({ instr ; loc ; _ } as descr) stack ->
Lwt.return (Gas.consume ctxt Interp_costs.cycle) >>=? fun ctxt ->
(match visitor with
| Some visitor -> visitor @@ Ex_descr_stack(descr, stack)
| None -> ()) ;
let step_same ctxt = step ?log ctxt ~source ~self ~payer ?visitor amount in
let logged_return : type a b.
(b, a) descr ->
a stack * context ->
(a stack * context) tzresult Lwt.t =
fun descr (ret, ctxt) ->
match log with
| None -> return (ret, ctxt)
| Some log ->
trace
Cannot_serialize_log
(unparse_stack ctxt (ret, descr.aft)) >>=? fun stack ->
log := (descr.loc, Gas.level ctxt, stack) :: !log ;
return (ret, ctxt) in
let get_log (log : execution_trace ref option) =
Option.map ~f:(fun l -> List.rev !l) log in
let consume_gas_terop : type ret arg1 arg2 arg3 rest.
(_ * (_ * (_ * rest)), ret * rest) descr ->
((arg1 -> arg2 -> arg3 -> ret) * arg1 * arg2 * arg3) ->
(arg1 -> arg2 -> arg3 -> Gas.cost) ->
rest stack ->
((ret * rest) stack * context) tzresult Lwt.t =
fun descr (op, x1, x2, x3) cost_func rest ->
Lwt.return (Gas.consume ctxt (cost_func x1 x2 x3)) >>=? fun ctxt ->
logged_return descr (Item (op x1 x2 x3, rest), ctxt) in
let consume_gas_binop : type ret arg1 arg2 rest.
(_ * (_ * rest), ret * rest) descr ->
((arg1 -> arg2 -> ret) * arg1 * arg2) ->
(arg1 -> arg2 -> Gas.cost) ->
rest stack ->
context ->
((ret * rest) stack * context) tzresult Lwt.t =
fun descr (op, x1, x2) cost_func rest ctxt ->
Lwt.return (Gas.consume ctxt (cost_func x1 x2)) >>=? fun ctxt ->
logged_return descr (Item (op x1 x2, rest), ctxt) in
let consume_gas_unop : type ret arg rest.
(_ * rest, ret * rest) descr ->
((arg -> ret) * arg) ->
(arg -> Gas.cost) ->
rest stack ->
context ->
((ret * rest) stack * context) tzresult Lwt.t =
fun descr (op, arg) cost_func rest ctxt ->
Lwt.return (Gas.consume ctxt (cost_func arg)) >>=? fun ctxt ->
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 :
a stack * context ->
(a stack * context) tzresult Lwt.t =
logged_return descr in
match instr, stack with
(* stack ops *)
| Drop, Item (_, rest) ->
Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt ->
logged_return (rest, ctxt)
| Dup, Item (v, rest) ->
Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt ->
logged_return (Item (v, Item (v, rest)), ctxt)
| Swap, Item (vi, Item (vo, rest)) ->
Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt ->
logged_return (Item (vo, Item (vi, rest)), ctxt)
| Const v, rest ->
Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt ->
logged_return (Item (v, rest), ctxt)
(* options *)
| Cons_some, Item (v, rest) ->
Lwt.return (Gas.consume ctxt Interp_costs.wrap) >>=? fun ctxt ->
logged_return (Item (Some v, rest), ctxt)
| Cons_none _, rest ->
Lwt.return (Gas.consume ctxt Interp_costs.variant_no_data) >>=? fun ctxt ->
logged_return (Item (None, rest), ctxt)
| If_none (bt, _), Item (None, rest) ->
Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt ->
step_same ctxt bt rest
| If_none (_, bf), Item (Some v, rest) ->
Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt ->
step_same ctxt bf (Item (v, rest))
(* pairs *)
| Cons_pair, Item (a, Item (b, rest)) ->
Lwt.return (Gas.consume ctxt Interp_costs.pair) >>=? fun ctxt ->
logged_return (Item ((a, b), rest), ctxt)
| Car, Item ((a, _), rest) ->
Lwt.return (Gas.consume ctxt Interp_costs.pair_access) >>=? fun ctxt ->
logged_return (Item (a, rest), ctxt)
| Cdr, Item ((_, b), rest) ->
Lwt.return (Gas.consume ctxt Interp_costs.pair_access) >>=? fun ctxt ->
logged_return (Item (b, rest), ctxt)
(* unions *)
| Left, Item (v, rest) ->
Lwt.return (Gas.consume ctxt Interp_costs.wrap) >>=? fun ctxt ->
logged_return (Item (L v, rest), ctxt)
| Right, Item (v, rest) ->
Lwt.return (Gas.consume ctxt Interp_costs.wrap) >>=? fun ctxt ->
logged_return (Item (R v, rest), ctxt)
| If_left (bt, _), Item (L v, rest) ->
Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt ->
step_same ctxt bt (Item (v, rest))
| If_left (_, bf), Item (R v, rest) ->
Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt ->
step_same ctxt bf (Item (v, rest))
(* lists *)
| Cons_list, Item (hd, Item (tl, rest)) ->
Lwt.return (Gas.consume ctxt Interp_costs.cons) >>=? fun ctxt ->
logged_return (Item (hd :: tl, rest), ctxt)
| Nil, rest ->
Lwt.return (Gas.consume ctxt Interp_costs.variant_no_data) >>=? fun ctxt ->
logged_return (Item ([], rest), ctxt)
| If_cons (_, bf), Item ([], rest) ->
Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt ->
step_same ctxt bf rest
| If_cons (bt, _), Item (hd :: tl, rest) ->
Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt ->
step_same ctxt bt (Item (hd, Item (tl, rest)))
| List_map body, Item (l, rest) ->
let rec loop rest ctxt l acc =
Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt ->
match l with
| [] -> return (Item (List.rev acc, rest), ctxt)
| hd :: tl ->
step_same ctxt body (Item (hd, rest))
>>=? fun (Item (hd, rest), ctxt) ->
loop rest ctxt tl (hd :: acc)
in loop rest ctxt l [] >>=? fun (res, ctxt) ->
logged_return (res, ctxt)
| List_size, Item (list, rest) ->
Lwt.return
(List.fold_left
(fun acc _ ->
acc >>? fun (size, ctxt) ->
Gas.consume ctxt Interp_costs.list_size >>? fun ctxt ->
ok (size + 1 (* FIXME: overflow *), ctxt))
(ok (0, ctxt)) list) >>=? fun (len, ctxt) ->
logged_return (Item (Script_int.(abs (of_int len)), rest), ctxt)
| List_iter body, Item (l, init) ->
let rec loop ctxt l stack =
Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt ->
match l with
| [] -> return (stack, ctxt)
| hd :: tl ->
step_same ctxt body (Item (hd, stack))
>>=? fun (stack, ctxt) ->
loop ctxt tl stack
in loop ctxt l init >>=? fun (res, ctxt) ->
logged_return (res, ctxt)
(* sets *)
| Empty_set t, rest ->
Lwt.return (Gas.consume ctxt Interp_costs.empty_set) >>=? fun ctxt ->
logged_return (Item (empty_set t, rest), ctxt)
| Set_iter body, Item (set, init) ->
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 rec loop ctxt l stack =
Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt ->
match l with
| [] -> return (stack, ctxt)
| hd :: tl ->
step_same ctxt body (Item (hd, stack))
>>=? fun (stack, ctxt) ->
loop ctxt tl stack
in loop ctxt l init >>=? fun (res, ctxt) ->
logged_return (res, ctxt)
| Set_mem, Item (v, Item (set, rest)) ->
consume_gas_binop descr (set_mem, v, set) Interp_costs.set_mem rest ctxt
| Set_update, Item (v, Item (presence, Item (set, rest))) ->
consume_gas_terop descr (set_update, v, presence, set) Interp_costs.set_update rest
| Set_size, Item (set, rest) ->
consume_gas_unop descr (set_size, set) (fun _ -> Interp_costs.set_size) rest ctxt
(* maps *)
| Empty_map (t, _), rest ->
Lwt.return (Gas.consume ctxt Interp_costs.empty_map) >>=? fun ctxt ->
logged_return (Item (empty_map t, rest), ctxt)
| Map_map body, Item (map, rest) ->
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 rec loop rest ctxt l acc =
Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt ->
match l with
| [] -> return (acc, ctxt)
| (k, _) as hd :: tl ->
step_same ctxt body (Item (hd, rest))
>>=? fun (Item (hd, rest), ctxt) ->
loop rest ctxt tl (map_update k (Some hd) acc)
in loop rest ctxt l (empty_map (map_key_ty map)) >>=? fun (res, ctxt) ->
logged_return (Item (res, rest), ctxt)
| Map_iter body, Item (map, init) ->
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 rec loop ctxt l stack =
Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt ->
match l with
| [] -> return (stack, ctxt)
| hd :: tl ->
step_same ctxt body (Item (hd, stack))
>>=? fun (stack, ctxt) ->
loop ctxt tl stack
in loop ctxt l init >>=? fun (res, ctxt) ->
logged_return (res, ctxt)
| Map_mem, Item (v, Item (map, rest)) ->
consume_gas_binop descr (map_mem, v, map) Interp_costs.map_mem rest ctxt
| Map_get, Item (v, Item (map, rest)) ->
consume_gas_binop descr (map_get, v, map) Interp_costs.map_get rest ctxt
| Map_update, Item (k, Item (v, Item (map, rest))) ->
consume_gas_terop descr (map_update, k, v, map) Interp_costs.map_update rest
| Map_size, Item (map, rest) ->
consume_gas_unop descr (map_size, map) (fun _ -> Interp_costs.map_size) rest ctxt
(* Big map operations *)
| Big_map_mem, Item (key, Item (map, rest)) ->
Lwt.return (Gas.consume ctxt (Interp_costs.big_map_mem key map)) >>=? fun ctxt ->
Script_ir_translator.big_map_mem ctxt self key map >>=? fun (res, ctxt) ->
logged_return (Item (res, rest), ctxt)
| Big_map_get, Item (key, Item (map, rest)) ->
Lwt.return (Gas.consume ctxt (Interp_costs.big_map_get key map)) >>=? fun ctxt ->
Script_ir_translator.big_map_get ctxt self key map >>=? fun (res, ctxt) ->
logged_return (Item (res, rest), ctxt)
| Big_map_update, Item (key, Item (maybe_value, Item (map, rest))) ->
consume_gas_terop descr
(Script_ir_translator.big_map_update, key, maybe_value, map)
Interp_costs.big_map_update rest
(* timestamp operations *)
| Add_seconds_to_timestamp, Item (n, Item (t, rest)) ->
consume_gas_binop descr
(Script_timestamp.add_delta, t, n)
Interp_costs.add_timestamp rest ctxt
| Add_timestamp_to_seconds, Item (t, Item (n, rest)) ->
consume_gas_binop descr (Script_timestamp.add_delta, t, n)
Interp_costs.add_timestamp rest ctxt
| Sub_timestamp_seconds, Item (t, Item (s, rest)) ->
consume_gas_binop descr (Script_timestamp.sub_delta, t, s)
Interp_costs.sub_timestamp rest ctxt
| Diff_timestamps, Item (t1, Item (t2, rest)) ->
consume_gas_binop descr (Script_timestamp.diff, t1, t2)
Interp_costs.diff_timestamps rest ctxt
(* string operations *)
| Concat_string_pair, Item (x, Item (y, rest)) ->
Lwt.return (Gas.consume ctxt (Interp_costs.concat_string [x; y])) >>=? fun ctxt ->
let s = String.concat "" [x; y] in
logged_return (Item (s, rest), ctxt)
| Concat_string, Item (ss, rest) ->
Lwt.return (Gas.consume ctxt (Interp_costs.concat_string ss)) >>=? fun ctxt ->
let s = String.concat "" ss in
logged_return (Item (s, rest), ctxt)
| Slice_string, Item (offset, Item (length, Item (s, rest))) ->
let s_length = Z.of_int (String.length s) in
let offset = Script_int.to_zint offset in
let length = Script_int.to_zint length in
if Compare.Z.(offset < s_length && Z.add offset length <= s_length) then
Lwt.return (Gas.consume ctxt (Interp_costs.slice_string (Z.to_int length))) >>=? fun ctxt ->
logged_return (Item (Some (String.sub s (Z.to_int offset) (Z.to_int length)), rest), ctxt)
else
Lwt.return (Gas.consume ctxt (Interp_costs.slice_string 0)) >>=? fun ctxt ->
logged_return (Item (None, rest), ctxt)
| String_size, Item (s, rest) ->
Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt ->
logged_return (Item (Script_int.(abs (of_int (String.length s))), rest), ctxt)
(* bytes operations *)
| Concat_bytes_pair, Item (x, Item (y, rest)) ->
Lwt.return (Gas.consume ctxt (Interp_costs.concat_bytes [x; y])) >>=? fun ctxt ->
let s = MBytes.concat "" [x; y] in
logged_return (Item (s, rest), ctxt)
| Concat_bytes, Item (ss, rest) ->
Lwt.return (Gas.consume ctxt (Interp_costs.concat_bytes ss)) >>=? fun ctxt ->
let s = MBytes.concat "" ss in
logged_return (Item (s, rest), ctxt)
| Slice_bytes, Item (offset, Item (length, Item (s, rest))) ->
let s_length = Z.of_int (MBytes.length s) in
let offset = Script_int.to_zint offset in
let length = Script_int.to_zint length in
if Compare.Z.(offset < s_length && Z.add offset length <= s_length) then
Lwt.return (Gas.consume ctxt (Interp_costs.slice_string (Z.to_int length))) >>=? fun ctxt ->
logged_return (Item (Some (MBytes.sub s (Z.to_int offset) (Z.to_int length)), rest), ctxt)
else
Lwt.return (Gas.consume ctxt (Interp_costs.slice_string 0)) >>=? fun ctxt ->
logged_return (Item (None, rest), ctxt)
| Bytes_size, Item (s, rest) ->
Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt ->
logged_return (Item (Script_int.(abs (of_int (MBytes.length s))), rest), ctxt)
(* currency operations *)
| Add_tez, Item (x, Item (y, rest)) ->
Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt ->
Lwt.return Tez.(x +? y) >>=? fun res ->
logged_return (Item (res, rest), ctxt)
| Sub_tez, Item (x, Item (y, rest)) ->
Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt ->
Lwt.return Tez.(x -? y) >>=? fun res ->
logged_return (Item (res, rest), ctxt)
| Mul_teznat, Item (x, Item (y, rest)) ->
Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt ->
Lwt.return (Gas.consume ctxt Interp_costs.z_to_int64) >>=? fun ctxt ->
begin
match Script_int.to_int64 y with
| None -> fail (Overflow (loc, get_log log))
| Some y ->
Lwt.return Tez.(x *? y) >>=? fun res ->
logged_return (Item (res, rest), ctxt)
end
| Mul_nattez, Item (y, Item (x, rest)) ->
Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt ->
Lwt.return (Gas.consume ctxt Interp_costs.z_to_int64) >>=? fun ctxt ->
begin
match Script_int.to_int64 y with
| None -> fail (Overflow (loc, get_log log))
| Some y ->
Lwt.return Tez.(x *? y) >>=? fun res ->
logged_return (Item (res, rest), ctxt)
end
(* boolean operations *)
| Or, Item (x, Item (y, rest)) ->
consume_gas_binop descr ((||), x, y) Interp_costs.bool_binop rest ctxt
| And, Item (x, Item (y, rest)) ->
consume_gas_binop descr ((&&), x, y) Interp_costs.bool_binop rest ctxt
| Xor, Item (x, Item (y, rest)) ->
consume_gas_binop descr (Compare.Bool.(<>), x, y) Interp_costs.bool_binop rest ctxt
| Not, Item (x, rest) ->
consume_gas_unop descr (not, x) Interp_costs.bool_unop rest ctxt
(* integer operations *)
| Is_nat, Item (x, rest) ->
consume_gas_unop descr (Script_int.is_nat, x) Interp_costs.abs rest ctxt
| Abs_int, Item (x, rest) ->
consume_gas_unop descr (Script_int.abs, x) Interp_costs.abs rest ctxt
| Int_nat, Item (x, rest) ->
consume_gas_unop descr (Script_int.int, x) Interp_costs.int rest ctxt
| Neg_int, Item (x, rest) ->
consume_gas_unop descr (Script_int.neg, x) Interp_costs.neg rest ctxt
| Neg_nat, Item (x, rest) ->
consume_gas_unop descr (Script_int.neg, x) Interp_costs.neg rest ctxt
| Add_intint, Item (x, Item (y, rest)) ->
consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt
| Add_intnat, Item (x, Item (y, rest)) ->
consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt
| Add_natint, Item (x, Item (y, rest)) ->
consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt
| Add_natnat, Item (x, Item (y, rest)) ->
consume_gas_binop descr (Script_int.add_n, x, y) Interp_costs.add rest ctxt
| Sub_int, Item (x, Item (y, rest)) ->
consume_gas_binop descr (Script_int.sub, x, y) Interp_costs.sub rest ctxt
| Mul_intint, Item (x, Item (y, rest)) ->
consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt
| Mul_intnat, Item (x, Item (y, rest)) ->
consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt
| Mul_natint, Item (x, Item (y, rest)) ->
consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt
| Mul_natnat, Item (x, Item (y, rest)) ->
consume_gas_binop descr (Script_int.mul_n, x, y) Interp_costs.mul rest ctxt
| Ediv_teznat, Item (x, Item (y, rest)) ->
Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z) >>=? fun ctxt ->
let x = Script_int.of_int64 (Tez.to_mutez x) in
consume_gas_binop descr
((fun x y ->
match Script_int.ediv x y with
| None -> None
| Some (q, r) ->
match Script_int.to_int64 q,
Script_int.to_int64 r with
| Some q, Some r ->
begin
match Tez.of_mutez q, Tez.of_mutez r with
| Some q, Some r -> Some (q,r)
(* Cannot overflow *)
| _ -> assert false
end
(* Cannot overflow *)
| _ -> assert false),
x, y)
Interp_costs.div
rest
ctxt
| Ediv_tez, Item (x, Item (y, rest)) ->
Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z) >>=? fun ctxt ->
Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z) >>=? fun ctxt ->
let x = Script_int.abs (Script_int.of_int64 (Tez.to_mutez x)) in
let y = Script_int.abs (Script_int.of_int64 (Tez.to_mutez y)) in
consume_gas_binop descr
((fun x y -> match Script_int.ediv_n x y with
| None -> None
| Some (q, r) ->
match Script_int.to_int64 r with
| None -> assert false (* Cannot overflow *)
| Some r ->
match Tez.of_mutez r with
| None -> assert false (* Cannot overflow *)
| Some r -> Some (q, r)),
x, y)
Interp_costs.div
rest
ctxt
| Ediv_intint, Item (x, Item (y, rest)) ->
consume_gas_binop descr (Script_int.ediv, x, y) Interp_costs.div rest ctxt
| Ediv_intnat, Item (x, Item (y, rest)) ->
consume_gas_binop descr (Script_int.ediv, x, y) Interp_costs.div rest ctxt
| Ediv_natint, Item (x, Item (y, rest)) ->
consume_gas_binop descr (Script_int.ediv, x, y) Interp_costs.div rest ctxt
| Ediv_natnat, Item (x, Item (y, rest)) ->
consume_gas_binop descr (Script_int.ediv_n, x, y) Interp_costs.div rest ctxt
| Lsl_nat, Item (x, Item (y, rest)) ->
Lwt.return (Gas.consume ctxt (Interp_costs.shift_left x y)) >>=? fun ctxt ->
begin
match Script_int.shift_left_n x y with
| None -> fail (Overflow (loc, get_log log))
| Some x -> logged_return (Item (x, rest), ctxt)
end
| Lsr_nat, Item (x, Item (y, rest)) ->
Lwt.return (Gas.consume ctxt (Interp_costs.shift_right x y)) >>=? fun ctxt ->
begin
match Script_int.shift_right_n x y with
| None -> fail (Overflow (loc, get_log log))
| Some r -> logged_return (Item (r, rest), ctxt)
end
| Or_nat, Item (x, Item (y, rest)) ->
consume_gas_binop descr (Script_int.logor, x, y) Interp_costs.logor rest ctxt
| And_nat, Item (x, Item (y, rest)) ->
consume_gas_binop descr (Script_int.logand, x, y) Interp_costs.logand rest ctxt
| And_int_nat, Item (x, Item (y, rest)) ->
consume_gas_binop descr (Script_int.logand, x, y) Interp_costs.logand rest ctxt
| Xor_nat, Item (x, Item (y, rest)) ->
consume_gas_binop descr (Script_int.logxor, x, y) Interp_costs.logxor rest ctxt
| Not_int, Item (x, rest) ->
consume_gas_unop descr (Script_int.lognot, x) Interp_costs.lognot rest ctxt
| Not_nat, Item (x, rest) ->
consume_gas_unop descr (Script_int.lognot, x) Interp_costs.lognot rest ctxt
(* control *)
| Seq (hd, tl), stack ->
step_same ctxt hd stack >>=? fun (trans, ctxt) ->
step_same ctxt tl trans
| If (bt, _), Item (true, rest) ->
Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt ->
step_same ctxt bt rest
| If (_, bf), Item (false, rest) ->
Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt ->
step_same ctxt bf rest
| Loop body, Item (true, rest) ->
Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt ->
step_same ctxt body rest >>=? fun (trans, ctxt) ->
step_same ctxt descr trans
| Loop _, Item (false, rest) ->
logged_return (rest, ctxt)
| Loop_left body, Item (L v, rest) ->
Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt ->
step_same ctxt body (Item (v, rest)) >>=? fun (trans, ctxt) ->
step_same ctxt descr trans
| Loop_left _, Item (R v, rest) ->
Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt ->
logged_return (Item (v, rest), ctxt)
| Dip b, Item (ign, rest) ->
Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt ->
step_same ctxt b rest >>=? fun (res, ctxt) ->
logged_return (Item (ign, res), ctxt)
| Exec, Item (arg, Item (lam, rest)) ->
Lwt.return (Gas.consume ctxt Interp_costs.exec) >>=? fun ctxt ->
interp ?log ctxt ~source ~payer ~self amount lam arg >>=? fun (res, ctxt) ->
logged_return (Item (res, rest), ctxt)
| Lambda lam, rest ->
Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt ->
logged_return (Item (lam, rest), ctxt)
| Failwith tv, Item (v, _) ->
trace Cannot_serialize_failure
(unparse_data ctxt Optimized tv v) >>=? fun (v, _ctxt) ->
let v = Micheline.strip_locations v in
fail (Reject (loc, v, get_log log))
| Nop, stack ->
logged_return (stack, ctxt)
(* comparison *)
| Compare (Bool_key _), Item (a, Item (b, rest)) ->
consume_gaz_comparison descr Compare.Bool.compare Interp_costs.compare_bool a b rest
| Compare (String_key _), Item (a, Item (b, rest)) ->
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 *)
| Eq, Item (cmpres, rest) ->
let cmpres = Script_int.compare cmpres Script_int.zero in
let cmpres = Compare.Int.(cmpres = 0) in
Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt ->
logged_return (Item (cmpres, rest), ctxt)
| Neq, Item (cmpres, rest) ->
let cmpres = Script_int.compare cmpres Script_int.zero in
let cmpres = Compare.Int.(cmpres <> 0) in
Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt ->
logged_return (Item (cmpres, rest), ctxt)
| Lt, Item (cmpres, rest) ->
let cmpres = Script_int.compare cmpres Script_int.zero in
let cmpres = Compare.Int.(cmpres < 0) in
Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt ->
logged_return (Item (cmpres, rest), ctxt)
| Le, Item (cmpres, rest) ->
let cmpres = Script_int.compare cmpres Script_int.zero in
let cmpres = Compare.Int.(cmpres <= 0) in
Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt ->
logged_return (Item (cmpres, rest), ctxt)
| Gt, Item (cmpres, rest) ->
let cmpres = Script_int.compare cmpres Script_int.zero in
let cmpres = Compare.Int.(cmpres > 0) in
Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt ->
logged_return (Item (cmpres, rest), ctxt)
| Ge, Item (cmpres, rest) ->
let cmpres = Script_int.compare cmpres Script_int.zero in
let cmpres = Compare.Int.(cmpres >= 0) in
Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt ->
logged_return (Item (cmpres, rest), ctxt)
(* packing *)
| Pack t, Item (value, rest) ->
Script_ir_translator.pack_data ctxt t value >>=? fun (bytes, ctxt) ->
logged_return (Item (bytes, rest), ctxt)
| Unpack t, Item (bytes, rest) ->
Lwt.return (Gas.check_enough ctxt (Script.serialized_cost bytes)) >>=? fun () ->
if Compare.Int.(MBytes.length bytes >= 1) &&
Compare.Int.(MBytes.get_uint8 bytes 0 = 0x05) then
let bytes = MBytes.sub bytes 1 (MBytes.length bytes - 1) in
match Data_encoding.Binary.of_bytes Script.expr_encoding bytes with
| None ->
Lwt.return (Gas.consume ctxt (Interp_costs.unpack_failed bytes)) >>=? fun ctxt ->
logged_return (Item (None, rest), ctxt)
| Some expr ->
Lwt.return (Gas.consume ctxt (Script.deserialized_cost expr)) >>=? fun ctxt ->
parse_data ctxt t (Micheline.root expr) >>= function
| Ok (value, ctxt) ->
logged_return (Item (Some value, rest), ctxt)
| Error _ignored ->
Lwt.return (Gas.consume ctxt (Interp_costs.unpack_failed bytes)) >>=? fun ctxt ->
logged_return (Item (None, rest), ctxt)
else
logged_return (Item (None, rest), ctxt)
(* protocol *)
| Address, Item ((_, contract), rest) ->
Lwt.return (Gas.consume ctxt Interp_costs.address) >>=? fun ctxt ->
logged_return (Item (contract, rest), ctxt)
| Contract t, Item (contract, rest) ->
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) ->
logged_return (Item (maybe_contract, rest), ctxt)
| Transfer_tokens,
Item (p, Item (amount, Item ((tp, destination), rest))) ->
Lwt.return (Gas.consume ctxt Interp_costs.transfer) >>=? fun ctxt ->
unparse_data ctxt Optimized tp p >>=? fun (p, ctxt) ->
let operation =
Transaction
{ amount ; destination ;
parameters = Some (Script.lazy_expr (Micheline.strip_locations p)) } in
Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) ->
logged_return (Item (Internal_operation { source = self ; operation ; nonce }, rest), ctxt)
| Create_account,
Item (manager, Item (delegate, Item (delegatable, Item (credit, rest)))) ->
Lwt.return (Gas.consume ctxt Interp_costs.create_account) >>=? fun ctxt ->
Contract.fresh_contract_from_current_nonce ctxt >>=? fun (ctxt, contract) ->
let operation =
Origination
{ credit ; manager ; delegate ; preorigination = Some contract ;
delegatable ; script = None ; spendable = true } in
Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) ->
logged_return (Item (Internal_operation { source = self ; operation ; nonce },
Item (contract, rest)), ctxt)
| Implicit_account, Item (key, rest) ->
Lwt.return (Gas.consume ctxt Interp_costs.implicit_account) >>=? fun ctxt ->
let contract = Contract.implicit_contract key in
logged_return (Item ((Unit_t None, contract), rest), ctxt)
| Create_contract (storage_type, param_type, Lam (_, code)),
Item (manager, Item
(delegate, Item
(spendable, Item
(delegatable, 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) ->
unparse_ty ctxt storage_type >>=? fun (unparsed_storage_type, ctxt) ->
let code =
Micheline.strip_locations
(Seq (0, [ Prim (0, K_parameter, [ unparsed_param_type ], []) ;
Prim (0, K_storage, [ unparsed_storage_type ], []) ;
Prim (0, K_code, [ Micheline.root code ], []) ])) in
unparse_data ctxt Optimized storage_type init >>=? fun (storage, ctxt) ->
let storage = Micheline.strip_locations storage in
Contract.fresh_contract_from_current_nonce ctxt >>=? fun (ctxt, contract) ->
let operation =
Origination
{ credit ; manager ; delegate ; preorigination = Some contract ;
delegatable ; spendable ;
script = Some { code = Script.lazy_expr code ;
storage = Script.lazy_expr storage } } in
Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) ->
logged_return
(Item (Internal_operation { source = self ; operation ; nonce },
Item (contract, rest)), ctxt)
| Set_delegate,
Item (delegate, rest) ->
Lwt.return (Gas.consume ctxt Interp_costs.create_account) >>=? fun ctxt ->
let operation = Delegation delegate in
Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) ->
logged_return (Item (Internal_operation { source = self ; operation ; nonce }, rest), ctxt)
| Balance, rest ->
Lwt.return (Gas.consume ctxt Interp_costs.balance) >>=? fun ctxt ->
Contract.get_balance ctxt self >>=? fun balance ->
logged_return (Item (balance, rest), ctxt)
| Now, rest ->
Lwt.return (Gas.consume ctxt Interp_costs.now) >>=? fun ctxt ->
let now = Script_timestamp.now ctxt in
logged_return (Item (now, rest), ctxt)
| Check_signature, Item (key, Item (signature, Item (message, rest))) ->
Lwt.return (Gas.consume ctxt Interp_costs.check_signature) >>=? fun ctxt ->
let res = Signature.check key signature message in
logged_return (Item (res, rest), ctxt)
| Hash_key, Item (key, rest) ->
Lwt.return (Gas.consume ctxt Interp_costs.hash_key) >>=? fun ctxt ->
logged_return (Item (Signature.Public_key.hash key, rest), ctxt)
| Blake2b, Item (bytes, rest) ->
Lwt.return (Gas.consume ctxt (Interp_costs.hash bytes 32)) >>=? fun ctxt ->
let hash = Raw_hashes.blake2b bytes in
logged_return (Item (hash, rest), ctxt)
| Sha256, Item (bytes, rest) ->
Lwt.return (Gas.consume ctxt (Interp_costs.hash bytes 32)) >>=? fun ctxt ->
let hash = Raw_hashes.sha256 bytes in
logged_return (Item (hash, rest), ctxt)
| Sha512, Item (bytes, rest) ->
Lwt.return (Gas.consume ctxt (Interp_costs.hash bytes 64)) >>=? fun ctxt ->
let hash = Raw_hashes.sha512 bytes in
logged_return (Item (hash, rest), ctxt)
| Steps_to_quota, rest ->
Lwt.return (Gas.consume ctxt Interp_costs.steps_to_quota) >>=? fun ctxt ->
let steps = match Gas.level ctxt with
| Limited { remaining } -> remaining
| Unaccounted -> Z.of_string "99999999" in
logged_return (Item (Script_int.(abs (of_zint steps)), rest), ctxt)
| Source, rest ->
Lwt.return (Gas.consume ctxt Interp_costs.source) >>=? fun ctxt ->
logged_return (Item (payer, rest), ctxt)
| Sender, rest ->
Lwt.return (Gas.consume ctxt Interp_costs.source) >>=? fun ctxt ->
logged_return (Item (source, rest), ctxt)
| Self t, rest ->
Lwt.return (Gas.consume ctxt Interp_costs.self) >>=? fun ctxt ->
logged_return (Item ((t,self), rest), ctxt)
| Amount, rest ->
Lwt.return (Gas.consume ctxt Interp_costs.amount) >>=? fun ctxt ->
logged_return (Item (amount, rest), ctxt)
and interp
: type p r.
(?log: execution_trace ref ->
context ->
source: Contract.t -> payer:Contract.t -> self: Contract.t -> Tez.t ->
(p, r) lambda -> p ->
(r * context) tzresult Lwt.t)
= fun ?log ctxt ~source ~payer ~self amount (Lam (code, _)) arg ->
let stack = (Item (arg, Empty)) in
begin match log with
| None -> return_unit
| Some log ->
trace Cannot_serialize_log
(unparse_stack ctxt (stack, code.bef)) >>=? fun stack ->
log := (code.loc, Gas.level ctxt, stack) :: !log ;
return_unit
end >>=? fun () ->
step ctxt ~source ~payer ~self amount code stack >>=? fun (Item (ret, Empty), ctxt) ->
return (ret, ctxt)
end
open X_error_monad
let stack_ty_eq (type a b) let stack_ty_eq (type a b)
?(tezos_context = dummy_environment.tezos_context) ?(tezos_context = dummy_environment.tezos_context)
(a:a stack_ty) (b:b stack_ty) = (a:a stack_ty) (b:b stack_ty) =
alpha_wrap (Script_ir_translator.stack_ty_eq tezos_context 0 a b) >>? fun (Eq, _) -> alpha_wrap (X.stack_ty_eq tezos_context 0 a b) >>? fun (Eq, _) ->
ok Eq ok Eq
let ty_eq (type a b) let ty_eq (type a b)
@ -37,7 +962,7 @@ let parse_michelson (type aft)
match j with match j with
| Typed descr -> ( | Typed descr -> (
Lwt.return ( Lwt.return (
alpha_wrap (Script_ir_translator.stack_ty_eq tezos_context 0 descr.aft aft) >>? fun (Eq, _) -> alpha_wrap (X.stack_ty_eq tezos_context 0 descr.aft aft) >>? fun (Eq, _) ->
let descr : (_, aft) Script_typed_ir.descr = {descr with aft} in let descr : (_, aft) Script_typed_ir.descr = {descr with aft} in
Ok descr Ok descr
) )
@ -59,7 +984,7 @@ let parse_michelson_fail (type aft)
match j with match j with
| Typed descr -> ( | Typed descr -> (
Lwt.return ( Lwt.return (
alpha_wrap (Script_ir_translator.stack_ty_eq tezos_context 0 descr.aft aft) >>? fun (Eq, _) -> alpha_wrap (X.stack_ty_eq tezos_context 0 descr.aft aft) >>? fun (Eq, _) ->
let descr : (_, aft) Script_typed_ir.descr = {descr with aft} in let descr : (_, aft) Script_typed_ir.descr = {descr with aft} in
Ok descr Ok descr
) )
@ -87,7 +1012,7 @@ let parse_michelson_ty
let unparse_michelson_data let unparse_michelson_data
?(tezos_context = dummy_environment.tezos_context) ?(tezos_context = dummy_environment.tezos_context)
?mapper ty value : Michelson.t tzresult Lwt.t = ?mapper ty value : Michelson.t tzresult Lwt.t =
Script_ir_translator.unparse_data tezos_context ?mapper X.unparse_data_generic tezos_context ?mapper
Readable ty value >>=?? fun (michelson, _) -> Readable ty value >>=?? fun (michelson, _) ->
return michelson return michelson
@ -129,5 +1054,5 @@ let interpret ?(options = default_options) ?visitor (instr:('a, 'b) descr) (bef:
payer ; payer ;
amount ; amount ;
} = options in } = options in
Script_interpreter.step tezos_context ~source ~self ~payer ?visitor amount instr bef >>=?? X.step tezos_context ~source ~self ~payer ?visitor amount instr bef >>=??
fun (stack, _) -> return stack fun (stack, _) -> return stack

1
vendors/ligo-utils/simple-utils/simple-utils.opam vendored
View File

@ -11,6 +11,7 @@ depends: [
"dune" "dune"
"base" "base"
"yojson" "yojson"
"ppx_let"
# from ppx_let: # from ppx_let:
"ocaml" {>= "4.04.2" & < "4.08.0"} "ocaml" {>= "4.04.2" & < "4.08.0"}
"dune" {build & >= "1.5.1"} "dune" {build & >= "1.5.1"}

11
vendors/ligo-utils/tezos-protocol-alpha-parameters/.ocamlformat vendored Normal file
View File

@ -0,0 +1,11 @@
wrap-fun-args=false
let-binding-spacing=compact
field-space=loose
break-separators=after-and-docked
sequence-style=separator
doc-comments=before
margin=80
module-item-spacing=sparse
parens-tuple=always
parens-tuple-patterns=always
break-string-literals=newlines-and-wrap

146
vendors/ligo-utils/tezos-protocol-alpha-parameters/default_parameters.ml vendored Normal file
View File

@ -0,0 +1,146 @@
(*****************************************************************************)
(* *)
(* 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 constants_mainnet =
Constants_repr.
{
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 =
(match Tez_repr.(one /? 8L) with Ok c -> c | Error _ -> assert false);
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 constants_sandbox =
Constants_repr.
{
constants_mainnet with
preserved_cycles = 2;
blocks_per_cycle = 8l;
blocks_per_commitment = 4l;
blocks_per_roll_snapshot = 4l;
blocks_per_voting_period = 64l;
time_between_blocks = List.map Period_repr.of_seconds_exn [1L; 0L];
proof_of_work_threshold = Int64.of_int (-1);
}
let constants_test =
Constants_repr.
{
constants_mainnet with
blocks_per_cycle = 128l;
blocks_per_commitment = 4l;
blocks_per_roll_snapshot = 32l;
blocks_per_voting_period = 256l;
time_between_blocks = List.map Period_repr.of_seconds_exn [1L; 0L];
proof_of_work_threshold = Int64.of_int (-1);
}
let bootstrap_accounts_strings =
[ "edpkuBknW28nW72KG6RoHtYW7p12T6GKc7nAbwYX5m8Wd9sDVC9yav";
"edpktzNbDAUjUk697W7gYg2CRuBQjyPxbEg8dLccYYwKSKvkPvjtV9";
"edpkuTXkJDGcFd5nh6VvMz8phXxU3Bi7h6hqgywNFi1vZTfQNnS1RV";
"edpkuFrRoDSEbJYgxRtLx2ps82UdaYc1WwfS9sE11yhauZt5DgCHbU";
"edpkv8EUUH68jmo3f7Um5PezmfGrRF24gnfLpH3sVNwJnV5bVCxL2n" ]
let boostrap_balance = Tez_repr.of_mutez_exn 4_000_000_000_000L
let bootstrap_accounts =
List.map
(fun s ->
let public_key = Signature.Public_key.of_b58check_exn s in
let public_key_hash = Signature.Public_key.hash public_key in
Parameters_repr.
{
public_key_hash;
public_key = Some public_key;
amount = boostrap_balance;
})
bootstrap_accounts_strings
(* TODO this could be generated from OCaml together with the faucet
for now these are harcoded values in the tests *)
let commitments =
let json_result =
Data_encoding.Json.from_string
{json|
[
[ "btz1bRL4X5BWo2Fj4EsBdUwexXqgTf75uf1qa", "23932454669343" ],
[ "btz1SxjV1syBgftgKy721czKi3arVkVwYUFSv", "72954577464032" ],
[ "btz1LtoNCjiW23txBTenALaf5H6NKF1L3c1gw", "217487035428348" ],
[ "btz1SUd3mMhEBcWudrn8u361MVAec4WYCcFoy", "4092742372031" ],
[ "btz1MvBXf4orko1tsGmzkjLbpYSgnwUjEe81r", "17590039016550" ],
[ "btz1LoDZ3zsjgG3k3cqTpUMc9bsXbchu9qMXT", "26322312350555" ],
[ "btz1RMfq456hFV5AeDiZcQuZhoMv2dMpb9hpP", "244951387881443" ],
[ "btz1Y9roTh4A7PsMBkp8AgdVFrqUDNaBE59y1", "80065050465525" ],
[ "btz1Q1N2ePwhVw5ED3aaRVek6EBzYs1GDkSVD", "3569618927693" ],
[ "btz1VFFVsVMYHd5WfaDTAt92BeQYGK8Ri4eLy", "9034781424478" ]
]|json}
in
match json_result with
| Error err ->
raise (Failure err)
| Ok json ->
Data_encoding.Json.destruct
(Data_encoding.list Commitment_repr.encoding)
json
let make_bootstrap_account (pkh, pk, amount) =
Parameters_repr.{public_key_hash = pkh; public_key = Some pk; amount}
let parameters_of_constants ?(bootstrap_accounts = bootstrap_accounts)
?(bootstrap_contracts = []) ?(with_commitments = false) constants =
let commitments = if with_commitments then commitments else [] in
Parameters_repr.
{
bootstrap_accounts;
bootstrap_contracts;
commitments;
constants;
security_deposit_ramp_up_cycles = None;
no_reward_cycles = None;
}
let json_of_parameters parameters =
Data_encoding.Json.construct Parameters_repr.encoding parameters

45
vendors/ligo-utils/tezos-protocol-alpha-parameters/default_parameters.mli vendored Normal file
View File

@ -0,0 +1,45 @@
(*****************************************************************************)
(* *)
(* 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
val constants_mainnet : Constants_repr.parametric
val constants_sandbox : Constants_repr.parametric
val constants_test : Constants_repr.parametric
val make_bootstrap_account :
Signature.public_key_hash * Signature.public_key * Tez_repr.t ->
Parameters_repr.bootstrap_account
val parameters_of_constants :
?bootstrap_accounts:Parameters_repr.bootstrap_account list ->
?bootstrap_contracts:Parameters_repr.bootstrap_contract list ->
?with_commitments:bool ->
Constants_repr.parametric ->
Parameters_repr.t
val json_of_parameters : Parameters_repr.t -> Data_encoding.json

44
vendors/ligo-utils/tezos-protocol-alpha-parameters/dune vendored Normal file
View File

@ -0,0 +1,44 @@
(library
(name tezos_protocol_alpha_parameters)
(public_name tezos-protocol-alpha-parameters)
(modules :standard \ gen)
(libraries tezos-base
tezos-protocol-environment
tezos-protocol-alpha)
(flags (:standard -open Tezos_base__TzPervasives
-open Tezos_protocol_alpha
-linkall))
)
(executable
(name gen)
(libraries tezos-base
tezos-protocol-alpha-parameters)
(modules gen)
(flags (:standard -open Tezos_base__TzPervasives
-open Tezos_protocol_alpha_parameters
-linkall)))
(rule
(targets sandbox-parameters.json)
(deps gen.exe)
(action (run %{deps} --sandbox)))
(rule
(targets test-parameters.json)
(deps gen.exe)
(action (run %{deps} --test)))
(rule
(targets mainnet-parameters.json)
(deps gen.exe)
(action (run %{deps} --mainnet)))
(install
(section lib)
(files sandbox-parameters.json test-parameters.json mainnet-parameters.json))
(alias
(name runtest_lint)
(deps (glob_files *.ml{,i}))
(action (run %{lib:tezos-tooling:lint.sh} %{deps})))

2
vendors/ligo-utils/tezos-protocol-alpha-parameters/dune-project vendored Normal file
View File

@ -0,0 +1,2 @@
(lang dune 1.10)
(name tezos-protocol-alpha-parameters)

61
vendors/ligo-utils/tezos-protocol-alpha-parameters/gen.ml vendored Normal file
View File

@ -0,0 +1,61 @@
(*****************************************************************************)
(* *)
(* 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. *)
(* *)
(*****************************************************************************)
(* Prints the json encoding of the parametric constants of protocol alpha.
$ dune utop src/proto_alpha/lib_protocol/test/helpers/ constants.ml
*)
let () =
let print_usage_and_fail s =
Printf.eprintf "Usage: %s [ --sandbox | --test | --mainnet ]" Sys.argv.(0) ;
raise (Invalid_argument s)
in
let dump parameters file =
let str =
Data_encoding.Json.to_string
(Default_parameters.json_of_parameters parameters)
in
let fd = open_out file in
output_string fd str ; close_out fd
in
if Array.length Sys.argv < 2 then print_usage_and_fail ""
else
match Sys.argv.(1) with
| "--sandbox" ->
dump
Default_parameters.(parameters_of_constants constants_sandbox)
"sandbox-parameters.json"
| "--test" ->
dump
Default_parameters.(
parameters_of_constants ~with_commitments:true constants_sandbox)
"test-parameters.json"
| "--mainnet" ->
dump
Default_parameters.(
parameters_of_constants ~with_commitments:true constants_mainnet)
"mainnet-parameters.json"
| s ->
print_usage_and_fail s

21
vendors/ligo-utils/tezos-protocol-alpha-parameters/tezos-protocol-alpha-parameters.opam vendored Normal file
View File

@ -0,0 +1,21 @@
opam-version: "2.0"
version: "dev"
maintainer: "contact@tezos.com"
authors: [ "Tezos devteam" ]
homepage: "https://www.tezos.com/"
bug-reports: "https://gitlab.com/tezos/tezos/issues"
dev-repo: "git+https://gitlab.com/tezos/tezos.git"
license: "MIT"
depends: [
"tezos-tooling" { with-test }
"ocamlfind" { build }
"dune" { build & >= "1.7" }
"tezos-base"
"tezos-protocol-environment"
"tezos-protocol-alpha"
]
build: [
["dune" "build" "-p" name "-j" jobs]
["dune" "runtest" "-p" name "-j" jobs] {with-test}
]
synopsis: "Tezos/Protocol: parameters"

11
vendors/ligo-utils/tezos-protocol-alpha/.ocamlformat vendored Normal file
View File

@ -0,0 +1,11 @@
wrap-fun-args=false
let-binding-spacing=compact
field-space=loose
break-separators=after-and-docked
sequence-style=separator
doc-comments=before
margin=80
module-item-spacing=sparse
parens-tuple=always
parens-tuple-patterns=always
break-string-literals=newlines-and-wrap

120
vendors/ligo-utils/tezos-protocol-alpha/.ocamlformat-ignore vendored Normal file
View File

@ -0,0 +1,120 @@
alpha_context.ml
alpha_context.mli
alpha_services.ml
alpha_services.mli
amendment.ml
amendment.mli
apply.ml
apply_results.ml
apply_results.mli
baking.ml
baking.mli
blinded_public_key_hash.ml
blinded_public_key_hash.mli
block_header_repr.ml
block_header_repr.mli
bootstrap_storage.ml
bootstrap_storage.mli
commitment_repr.ml
commitment_repr.mli
commitment_storage.ml
commitment_storage.mli
constants_repr.ml
constants_services.ml
constants_services.mli
constants_storage.ml
contract_hash.ml
contract_repr.ml
contract_repr.mli
contract_services.ml
contract_services.mli
contract_storage.ml
contract_storage.mli
cycle_repr.ml
cycle_repr.mli
delegate_services.ml
delegate_services.mli
delegate_storage.ml
delegate_storage.mli
fees_storage.ml
fees_storage.mli
fitness_repr.ml
fitness_storage.ml
gas_limit_repr.ml
gas_limit_repr.mli
helpers_services.ml
helpers_services.mli
init_storage.ml
level_repr.ml
level_repr.mli
level_storage.ml
level_storage.mli
main.ml
main.mli
manager_repr.ml
manager_repr.mli
michelson_v1_gas.ml
michelson_v1_gas.mli
michelson_v1_primitives.ml
michelson_v1_primitives.mli
misc.ml
misc.mli
nonce_hash.ml
nonce_storage.ml
nonce_storage.mli
operation_repr.ml
operation_repr.mli
parameters_repr.ml
parameters_repr.mli
period_repr.ml
period_repr.mli
qty_repr.ml
raw_context.ml
raw_context.mli
raw_level_repr.ml
raw_level_repr.mli
roll_repr.ml
roll_repr.mli
roll_storage.ml
roll_storage.mli
script_expr_hash.ml
script_interpreter.ml
script_interpreter.mli
script_int_repr.ml
script_int_repr.mli
script_ir_annot.ml
script_ir_annot.mli
script_ir_translator.ml
script_ir_translator.mli
script_repr.ml
script_repr.mli
script_tc_errors.ml
script_tc_errors_registration.ml
script_timestamp_repr.ml
script_timestamp_repr.mli
script_typed_ir.ml
seed_repr.ml
seed_repr.mli
seed_storage.ml
seed_storage.mli
services_registration.ml
state_hash.ml
storage_description.ml
storage_description.mli
storage_functors.ml
storage_functors.mli
storage.ml
storage.mli
storage_sigs.ml
tez_repr.ml
tez_repr.mli
time_repr.ml
time_repr.mli
vote_repr.ml
vote_repr.mli
vote_storage.ml
vote_storage.mli
voting_period_repr.ml
voting_period_repr.mli
voting_services.ml
voting_services.mli

81
vendors/ligo-utils/tezos-protocol-alpha/TEZOS_PROTOCOL vendored Normal file
View File

@ -0,0 +1,81 @@
{
"hash": "ProtoALphaALphaALphaALphaALphaALphaALphaALphaDdp3zK",
"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"
]
}

186
vendors/ligo-utils/tezos-protocol-alpha/alpha_context.ml vendored Normal file
View File

@ -0,0 +1,186 @@
(*****************************************************************************)
(* *)
(* 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. *)
(* *)
(*****************************************************************************)
type t = Raw_context.t
type context = t
module type BASIC_DATA = sig
type t
include Compare.S with type t := t
val encoding: t Data_encoding.t
val pp: Format.formatter -> t -> unit
end
module Tez = Tez_repr
module Period = Period_repr
module Timestamp = struct
include Time_repr
let current = Raw_context.current_timestamp
end
include Operation_repr
module Operation = struct
type 'kind t = 'kind operation = {
shell: Operation.shell_header ;
protocol_data: 'kind protocol_data ;
}
type packed = packed_operation
let unsigned_encoding = unsigned_operation_encoding
include Operation_repr
end
module Block_header = Block_header_repr
module Vote = struct
include Vote_repr
include Vote_storage
end
module Raw_level = Raw_level_repr
module Cycle = Cycle_repr
module Script_int = Script_int_repr
module Script_timestamp = struct
include Script_timestamp_repr
let now ctxt =
Raw_context.current_timestamp ctxt
|> Timestamp.to_seconds
|> of_int64
end
module Script = struct
include Michelson_v1_primitives
include Script_repr
let force_decode ctxt lexpr =
Lwt.return
(Script_repr.force_decode lexpr >>? fun (v, cost) ->
Raw_context.consume_gas ctxt cost >|? fun ctxt ->
(v, ctxt))
let force_bytes ctxt lexpr =
Lwt.return
(Script_repr.force_bytes lexpr >>? fun (b, cost) ->
Raw_context.consume_gas ctxt cost >|? fun ctxt ->
(b, ctxt))
end
module Fees = Fees_storage
type public_key = Signature.Public_key.t
type public_key_hash = Signature.Public_key_hash.t
type signature = Signature.t
module Constants = struct
include Constants_repr
include Constants_storage
end
module Voting_period = Voting_period_repr
module Gas = struct
include Gas_limit_repr
type error += Gas_limit_too_high = Raw_context.Gas_limit_too_high
let check_limit = Raw_context.check_gas_limit
let set_limit = Raw_context.set_gas_limit
let set_unlimited = Raw_context.set_gas_unlimited
let consume = Raw_context.consume_gas
let check_enough = Raw_context.check_enough_gas
let level = Raw_context.gas_level
let consumed = Raw_context.gas_consumed
let block_level = Raw_context.block_gas_level
end
module Level = struct
include Level_repr
include Level_storage
end
module Contract = struct
include Contract_repr
include Contract_storage
let originate c contract ~balance ~manager ?script ~delegate
~spendable ~delegatable =
originate c contract ~balance ~manager ?script ~delegate
~spendable ~delegatable
let init_origination_nonce = Raw_context.init_origination_nonce
let unset_origination_nonce = Raw_context.unset_origination_nonce
end
module Delegate = Delegate_storage
module Roll = struct
include Roll_repr
include Roll_storage
end
module Nonce = Nonce_storage
module Seed = struct
include Seed_repr
include Seed_storage
end
module Fitness = struct
include Fitness_repr
include Fitness
type fitness = t
include Fitness_storage
end
module Bootstrap = Bootstrap_storage
module Commitment = struct
include Commitment_repr
include Commitment_storage
end
module Global = struct
let get_last_block_priority = Storage.Last_block_priority.get
let set_last_block_priority = Storage.Last_block_priority.set
end
let prepare_first_block = Init_storage.prepare_first_block
let prepare = Init_storage.prepare
let finalize ?commit_message:message c =
let fitness = Fitness.from_int64 (Fitness.current c) in
let context = Raw_context.recover c in
{ Updater.context ; fitness ; message ; max_operations_ttl = 60 ;
last_allowed_fork_level =
Raw_level.to_int32 @@ Level.last_allowed_fork_level c;
}
let activate = Raw_context.activate
let fork_test_chain = Raw_context.fork_test_chain
let record_endorsement = Raw_context.record_endorsement
let allowed_endorsements = Raw_context.allowed_endorsements
let init_endorsements = Raw_context.init_endorsements
let reset_internal_nonce = Raw_context.reset_internal_nonce
let fresh_internal_nonce = Raw_context.fresh_internal_nonce
let record_internal_nonce = Raw_context.record_internal_nonce
let internal_nonce_already_recorded = Raw_context.internal_nonce_already_recorded
let add_deposit = Raw_context.add_deposit
let add_fees = Raw_context.add_fees
let add_rewards = Raw_context.add_rewards
let get_deposits = Raw_context.get_deposits
let get_fees = Raw_context.get_fees
let get_rewards = Raw_context.get_rewards
let description = Raw_context.description

1164
vendors/ligo-utils/tezos-protocol-alpha/alpha_context.mli vendored Normal file
View File

File diff suppressed because it is too large Load Diff

127
vendors/ligo-utils/tezos-protocol-alpha/alpha_services.ml vendored Normal file
View File

@ -0,0 +1,127 @@
(*****************************************************************************)
(* *)
(* 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 Alpha_context
let custom_root = RPC_path.open_root
module Seed = struct
module S = struct
open Data_encoding
let seed =
RPC_service.post_service
~description: "Seed of the cycle to which the block belongs."
~query: RPC_query.empty
~input: empty
~output: Seed.seed_encoding
RPC_path.(custom_root / "context" / "seed")
end
let () =
let open Services_registration in
register0 S.seed begin fun ctxt () () ->
let l = Level.current ctxt in
Seed.for_cycle ctxt l.cycle
end
let get ctxt block =
RPC_context.make_call0 S.seed ctxt block () ()
end
module Nonce = struct
type info =
| Revealed of Nonce.t
| Missing of Nonce_hash.t
| Forgotten
let info_encoding =
let open Data_encoding in
union [
case (Tag 0)
~title:"Revealed"
(obj1 (req "nonce" Nonce.encoding))
(function Revealed nonce -> Some nonce | _ -> None)
(fun nonce -> Revealed nonce) ;
case (Tag 1)
~title:"Missing"
(obj1 (req "hash" Nonce_hash.encoding))
(function Missing nonce -> Some nonce | _ -> None)
(fun nonce -> Missing nonce) ;
case (Tag 2)
~title:"Forgotten"
empty
(function Forgotten -> Some () | _ -> None)
(fun () -> Forgotten) ;
]
module S = struct
let get =
RPC_service.get_service
~description: "Info about the nonce of a previous block."
~query: RPC_query.empty
~output: info_encoding
RPC_path.(custom_root / "context" / "nonces" /: Raw_level.rpc_arg)
end
let register () =
let open Services_registration in
register1 S.get begin fun ctxt raw_level () () ->
let level = Level.from_raw ctxt raw_level in
Nonce.get ctxt level >>= function
| Ok (Revealed nonce) -> return (Revealed nonce)
| Ok (Unrevealed { nonce_hash ; _ }) ->
return (Missing nonce_hash)
| Error _ -> return Forgotten
end
let get ctxt block level =
RPC_context.make_call1 S.get ctxt block level () ()
end
module Contract = Contract_services
module Constants = Constants_services
module Delegate = Delegate_services
module Helpers = Helpers_services
module Forge = Helpers_services.Forge
module Parse = Helpers_services.Parse
module Voting = Voting_services
let register () =
Contract.register () ;
Constants.register () ;
Delegate.register () ;
Helpers.register () ;
Nonce.register () ;
Voting.register ()

55
vendors/ligo-utils/tezos-protocol-alpha/alpha_services.mli vendored Normal file
View File

@ -0,0 +1,55 @@
(*****************************************************************************)
(* *)
(* 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 Alpha_context
module Seed : sig
val get: 'a #RPC_context.simple -> 'a -> Seed.seed shell_tzresult Lwt.t
end
module Nonce : sig
type info =
| Revealed of Nonce.t
| Missing of Nonce_hash.t
| Forgotten
val get:
'a #RPC_context.simple ->
'a -> Raw_level.t -> info shell_tzresult Lwt.t
end
module Contract = Contract_services
module Constants = Constants_services
module Delegate = Delegate_services
module Helpers = Helpers_services
module Forge = Helpers_services.Forge
module Parse = Helpers_services.Parse
module Voting = Voting_services
val register: unit -> unit

275
vendors/ligo-utils/tezos-protocol-alpha/amendment.ml vendored Normal file
View File

@ -0,0 +1,275 @@
(*****************************************************************************)
(* *)
(* 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 Alpha_context
(** Returns the proposal submitted by the most delegates.
Returns None in case of a tie or if there are no proposals. *)
let select_winning_proposal proposals =
let merge proposal vote winners =
match winners with
| None -> Some ([proposal], vote)
| Some (winners, winners_vote) as previous ->
if Compare.Int32.(vote = winners_vote) then
Some (proposal :: winners, winners_vote)
else if Compare.Int32.(vote >= winners_vote) then
Some ([proposal], vote)
else
previous in
match Protocol_hash.Map.fold merge proposals None with
| None -> None
| Some ([proposal], _) -> Some proposal
| Some _ -> None (* in case of a tie, lets do nothing. *)
(** A proposal is approved if it has supermajority and the participation reaches
the current quorum.
Supermajority means the yays are more 8/10 of casted votes.
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
each vote is updated using the last expected quorum and the current
participation with the following weights:
newQ = oldQ * 8/10 + participation * 2/10 *)
let check_approval_and_update_quorum ctxt =
Vote.get_ballots ctxt >>=? fun ballots ->
Vote.listing_size ctxt >>=? fun maximum_vote ->
Vote.get_current_quorum ctxt >>=? fun expected_quorum ->
(* 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.
In 'participation' an Int64 is used because in the worst case 'all_votes is
8e5 and after the multiplication is 8e9, making it potentially overflow a
signed Int32 which is 2e9. *)
let casted_votes = Int32.add ballots.yay ballots.nay in
let all_votes = Int32.add casted_votes ballots.pass in
let supermajority = Int32.div (Int32.mul 8l casted_votes) 10l in
let participation = (* in centile of percentage *)
Int64.to_int32
(Int64.div
(Int64.mul (Int64.of_int32 all_votes) 100_00L)
(Int64.of_int32 maximum_vote)) in
let outcome = Compare.Int32.(participation >= expected_quorum &&
ballots.yay >= supermajority) in
let updated_quorum =
Int32.div (Int32.add (Int32.mul 8l expected_quorum) (Int32.mul 2l participation)) 10l in
Vote.set_current_quorum ctxt updated_quorum >>=? fun ctxt ->
return (ctxt, outcome)
(** Implements the state machine of the amendment procedure.
Note that [freeze_listings], that computes the vote weight of each delegate,
is run at the beginning of each voting period.
*)
let start_new_voting_period ctxt =
Vote.get_current_period_kind ctxt >>=? function
| Proposal -> begin
Vote.get_proposals ctxt >>=? fun proposals ->
Vote.clear_proposals ctxt >>= fun ctxt ->
Vote.clear_listings ctxt >>=? fun ctxt ->
match select_winning_proposal proposals with
| None ->
Vote.freeze_listings ctxt >>=? fun ctxt ->
return ctxt
| Some proposal ->
Vote.init_current_proposal ctxt proposal >>=? fun ctxt ->
Vote.freeze_listings ctxt >>=? fun ctxt ->
Vote.set_current_period_kind ctxt Testing_vote >>=? fun ctxt ->
return ctxt
end
| Testing_vote ->
check_approval_and_update_quorum ctxt >>=? fun (ctxt, approved) ->
Vote.clear_ballots ctxt >>= fun ctxt ->
Vote.clear_listings ctxt >>=? fun ctxt ->
if approved then
let expiration = (* in two days maximum... *)
Time.add (Timestamp.current ctxt) (Constants.test_chain_duration ctxt) in
Vote.get_current_proposal ctxt >>=? fun proposal ->
fork_test_chain ctxt proposal expiration >>= fun ctxt ->
Vote.set_current_period_kind ctxt Testing >>=? fun ctxt ->
return ctxt
else
Vote.clear_current_proposal ctxt >>=? fun ctxt ->
Vote.freeze_listings ctxt >>=? fun ctxt ->
Vote.set_current_period_kind ctxt Proposal >>=? fun ctxt ->
return ctxt
| Testing ->
Vote.freeze_listings ctxt >>=? fun ctxt ->
Vote.set_current_period_kind ctxt Promotion_vote >>=? fun ctxt ->
return ctxt
| Promotion_vote ->
check_approval_and_update_quorum ctxt >>=? fun (ctxt, approved) ->
begin
if approved then
Vote.get_current_proposal ctxt >>=? fun proposal ->
activate ctxt proposal >>= fun ctxt ->
return ctxt
else
return ctxt
end >>=? fun ctxt ->
Vote.clear_ballots ctxt >>= fun ctxt ->
Vote.clear_listings ctxt >>=? fun ctxt ->
Vote.clear_current_proposal ctxt >>=? fun ctxt ->
Vote.freeze_listings ctxt >>=? fun ctxt ->
Vote.set_current_period_kind ctxt Proposal >>=? fun ctxt ->
return ctxt
type error += (* `Branch *)
| Invalid_proposal
| Unexpected_proposal
| Unauthorized_proposal
| Too_many_proposals
| Empty_proposal
| Unexpected_ballot
| Unauthorized_ballot
let () =
let open Data_encoding in
(* Invalid proposal *)
register_error_kind
`Branch
~id:"invalid_proposal"
~title:"Invalid proposal"
~description:"Ballot provided for a proposal that is not the current one."
~pp:(fun ppf () -> Format.fprintf ppf "Invalid proposal")
empty
(function Invalid_proposal -> Some () | _ -> None)
(fun () -> Invalid_proposal) ;
(* Unexpected proposal *)
register_error_kind
`Branch
~id:"unexpected_proposal"
~title:"Unexpected proposal"
~description:"Proposal recorded outside of a proposal period."
~pp:(fun ppf () -> Format.fprintf ppf "Unexpected proposal")
empty
(function Unexpected_proposal -> Some () | _ -> None)
(fun () -> Unexpected_proposal) ;
(* Unauthorized proposal *)
register_error_kind
`Branch
~id:"unauthorized_proposal"
~title:"Unauthorized proposal"
~description:"The delegate provided for the proposal is not in the voting listings."
~pp:(fun ppf () -> Format.fprintf ppf "Unauthorized proposal")
empty
(function Unauthorized_proposal -> Some () | _ -> None)
(fun () -> Unauthorized_proposal) ;
(* Unexpected ballot *)
register_error_kind
`Branch
~id:"unexpected_ballot"
~title:"Unexpected ballot"
~description:"Ballot recorded outside of a voting period."
~pp:(fun ppf () -> Format.fprintf ppf "Unexpected ballot")
empty
(function Unexpected_ballot -> Some () | _ -> None)
(fun () -> Unexpected_ballot) ;
(* Unauthorized ballot *)
register_error_kind
`Branch
~id:"unauthorized_ballot"
~title:"Unauthorized ballot"
~description:"The delegate provided for the ballot is not in the voting listings."
~pp:(fun ppf () -> Format.fprintf ppf "Unauthorized ballot")
empty
(function Unauthorized_ballot -> Some () | _ -> None)
(fun () -> Unauthorized_ballot) ;
(* Too many proposals *)
register_error_kind
`Branch
~id:"too_many_proposals"
~title:"Too many proposals"
~description:"The delegate reached the maximum number of allowed proposals."
~pp:(fun ppf () -> Format.fprintf ppf "Too many proposals")
empty
(function Too_many_proposals -> Some () | _ -> None)
(fun () -> Too_many_proposals) ;
(* Empty proposal *)
register_error_kind
`Branch
~id:"empty_proposal"
~title:"Empty proposal"
~description:"Proposal lists cannot be empty."
~pp:(fun ppf () -> Format.fprintf ppf "Empty proposal")
empty
(function Empty_proposal -> Some () | _ -> None)
(fun () -> Empty_proposal)
(* @return [true] if [List.length l] > [n] w/o computing length *)
let rec longer_than l n =
if Compare.Int.(n < 0) then assert false else
match l with
| [] -> false
| _ :: rest ->
if Compare.Int.(n = 0) then true
else (* n > 0 *)
longer_than rest (n-1)
let record_proposals ctxt delegate proposals =
begin match proposals with
| [] -> fail Empty_proposal
| _ :: _ -> return_unit
end >>=? fun () ->
Vote.get_current_period_kind ctxt >>=? function
| Proposal ->
Vote.in_listings ctxt delegate >>= fun in_listings ->
if in_listings then
Vote.recorded_proposal_count_for_delegate ctxt delegate >>=? fun count ->
fail_when
(longer_than proposals (Constants.max_proposals_per_delegate - count))
Too_many_proposals >>=? fun () ->
fold_left_s
(fun ctxt proposal ->
Vote.record_proposal ctxt proposal delegate)
ctxt proposals >>=? fun ctxt ->
return ctxt
else
fail Unauthorized_proposal
| Testing_vote | Testing | Promotion_vote ->
fail Unexpected_proposal
let record_ballot ctxt delegate proposal ballot =
Vote.get_current_period_kind ctxt >>=? function
| Testing_vote | Promotion_vote ->
Vote.get_current_proposal ctxt >>=? fun current_proposal ->
fail_unless (Protocol_hash.equal proposal current_proposal)
Invalid_proposal >>=? fun () ->
Vote.has_recorded_ballot ctxt delegate >>= fun has_ballot ->
fail_when has_ballot Unauthorized_ballot >>=? fun () ->
Vote.in_listings ctxt delegate >>= fun in_listings ->
if in_listings then
Vote.record_ballot ctxt delegate ballot
else
fail Unauthorized_ballot
| Testing | Proposal ->
fail Unexpected_ballot
let last_of_a_voting_period ctxt l =
Compare.Int32.(Int32.succ l.Level.voting_period_position =
Constants.blocks_per_voting_period ctxt )
let may_start_new_voting_period ctxt =
let level = Level.current ctxt in
if last_of_a_voting_period ctxt level then
start_new_voting_period ctxt
else
return ctxt

79
vendors/ligo-utils/tezos-protocol-alpha/amendment.mli vendored Normal file
View File

@ -0,0 +1,79 @@
(*****************************************************************************)
(* *)
(* 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. *)
(* *)
(*****************************************************************************)
(**
Only delegates with at least one roll take part in the amendment procedure.
It works as follows:
- Proposal period: delegates can submit protocol amendment proposals using
the proposal operation. At the end of a proposal period, the proposal with
most supporters is selected and we move to a testing_vote period.
If there are no proposals, or a tie between proposals, a new proposal
period starts.
- Testing_vote period: delegates can cast votes to test or not the winning
proposal using the ballot operation.
At the end of a testing_vote period if participation reaches the quorum
and the proposal has a supermajority in favor, we proceed to a testing
period. Otherwise we go back to a proposal period.
In any case, if there is enough participation the quorum is updated.
- Testing period: a test chain is forked for the lengh of the period.
At the end of a testing period we move to a promotion_vote period.
- Promotion_vote period: delegates can cast votes to promote or not the
tested proposal using the ballot operation.
At the end of a promotion_vote period if participation reaches the quorum
and the tested proposal has a supermajority in favor, it is activated as
the new protocol. Otherwise we go back to a proposal period.
In any case, if there is enough participation the quorum is updated.
*)
open Alpha_context
(** If at the end of a voting period, moves to the next one following
the state machine of the amendment procedure. *)
val may_start_new_voting_period:
context -> context tzresult Lwt.t
type error +=
| Unexpected_proposal
| Unauthorized_proposal
| Too_many_proposals
| Empty_proposal
(** Records a list of proposals for a delegate.
@raise Unexpected_proposal if [ctxt] is not in a proposal period.
@raise Unauthorized_proposal if [delegate] is not in the listing. *)
val record_proposals:
context ->
public_key_hash -> Protocol_hash.t list ->
context tzresult Lwt.t
type error +=
| Invalid_proposal
| Unexpected_ballot
| Unauthorized_ballot
val record_ballot:
context ->
public_key_hash -> Protocol_hash.t -> Vote.ballot ->
context tzresult Lwt.t

1072
vendors/ligo-utils/tezos-protocol-alpha/apply.ml vendored Normal file
View File

File diff suppressed because it is too large Load Diff

988
vendors/ligo-utils/tezos-protocol-alpha/apply_results.ml vendored Normal file
View File

@ -0,0 +1,988 @@
(*****************************************************************************)
(* *)
(* 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 Alpha_context
open Data_encoding
let error_encoding =
def "error"
~description:
"The full list of RPC errors would be too long to include.\n\
It is available at RPC `/errors` (GET).\n\
Errors specific to protocol Alpha have an id that starts with `proto.alpha`." @@
splitted
~json:(conv
(fun err ->
Data_encoding.Json.construct Error_monad.error_encoding err)
(fun json ->
Data_encoding.Json.destruct Error_monad.error_encoding json)
json)
~binary:Error_monad.error_encoding
type _ successful_manager_operation_result =
| Reveal_result :
{ consumed_gas : Z.t
} -> Kind.reveal successful_manager_operation_result
| Transaction_result :
{ storage : Script.expr option ;
big_map_diff : Contract.big_map_diff option ;
balance_updates : Delegate.balance_updates ;
originated_contracts : Contract.t list ;
consumed_gas : Z.t ;
storage_size : Z.t ;
paid_storage_size_diff : Z.t ;
allocated_destination_contract : bool ;
} -> Kind.transaction successful_manager_operation_result
| Origination_result :
{ balance_updates : Delegate.balance_updates ;
originated_contracts : Contract.t list ;
consumed_gas : Z.t ;
storage_size : Z.t ;
paid_storage_size_diff : Z.t ;
} -> Kind.origination successful_manager_operation_result
| Delegation_result :
{ consumed_gas : Z.t
} -> Kind.delegation successful_manager_operation_result
type packed_successful_manager_operation_result =
| Successful_manager_result :
'kind successful_manager_operation_result -> packed_successful_manager_operation_result
type 'kind manager_operation_result =
| Applied of 'kind successful_manager_operation_result
| Backtracked of 'kind successful_manager_operation_result * error list option
| Failed : 'kind Kind.manager * error list -> 'kind manager_operation_result
| Skipped : 'kind Kind.manager -> 'kind manager_operation_result
type packed_internal_operation_result =
| Internal_operation_result :
'kind internal_operation * 'kind manager_operation_result -> packed_internal_operation_result
module Manager_result = struct
type 'kind case =
MCase : {
op_case: 'kind Operation.Encoding.Manager_operations.case ;
encoding: 'a Data_encoding.t ;
kind: 'kind Kind.manager ;
iselect:
packed_internal_operation_result ->
('kind internal_operation * 'kind manager_operation_result) option;
select:
packed_successful_manager_operation_result ->
'kind successful_manager_operation_result option ;
proj: 'kind successful_manager_operation_result -> 'a ;
inj: 'a -> 'kind successful_manager_operation_result ;
t: 'kind manager_operation_result Data_encoding.t ;
} -> 'kind case
let make ~op_case ~encoding ~kind ~iselect ~select ~proj ~inj =
let Operation.Encoding.Manager_operations.MCase { name ; _ } = op_case in
let t =
def (Format.asprintf "operation.alpha.operation_result.%s" name) @@
union ~tag_size:`Uint8 [
case (Tag 0)
~title:"Applied"
(merge_objs
(obj1
(req "status" (constant "applied")))
encoding)
(fun o ->
match o with
| Skipped _ | Failed _ | Backtracked _ -> None
| Applied o ->
match select (Successful_manager_result o) with
| None -> None
| Some o -> Some ((), proj o))
(fun ((), x) -> (Applied (inj x))) ;
case (Tag 1)
~title:"Failed"
(obj2
(req "status" (constant "failed"))
(req "errors" (list error_encoding)))
(function (Failed (_, errs)) -> Some ((), errs) | _ -> None)
(fun ((), errs) -> Failed (kind, errs)) ;
case (Tag 2)
~title:"Skipped"
(obj1 (req "status" (constant "skipped")))
(function Skipped _ -> Some () | _ -> None)
(fun () -> Skipped kind) ;
case (Tag 3)
~title:"Backtracked"
(merge_objs
(obj2
(req "status" (constant "backtracked"))
(opt "errors" (list error_encoding)))
encoding)
(fun o ->
match o with
| Skipped _ | Failed _ | Applied _ -> None
| Backtracked (o, errs) ->
match select (Successful_manager_result o) with
| None -> None
| Some o -> Some (((), errs), proj o))
(fun (((), errs), x) -> (Backtracked (inj x, errs))) ;
] in
MCase { op_case ; encoding ; kind ; iselect ; select ; proj ; inj ; t }
let reveal_case =
make
~op_case: Operation.Encoding.Manager_operations.reveal_case
~encoding: Data_encoding.(obj1 (dft "consumed_gas" z Z.zero))
~iselect:
(function
| Internal_operation_result
({ operation = Reveal _ ; _} as op, res) ->
Some (op, res)
| _ -> None)
~select:
(function
| Successful_manager_result (Reveal_result _ as op) -> Some op
| _ -> None)
~kind: Kind.Reveal_manager_kind
~proj: (function Reveal_result { consumed_gas } -> consumed_gas)
~inj: (fun consumed_gas -> Reveal_result { consumed_gas })
let transaction_case =
make
~op_case: Operation.Encoding.Manager_operations.transaction_case
~encoding:
(obj8
(opt "storage" Script.expr_encoding)
(opt "big_map_diff" Contract.big_map_diff_encoding)
(dft "balance_updates" Delegate.balance_updates_encoding [])
(dft "originated_contracts" (list Contract.encoding) [])
(dft "consumed_gas" z Z.zero)
(dft "storage_size" z Z.zero)
(dft "paid_storage_size_diff" z Z.zero)
(dft "allocated_destination_contract" bool false))
~iselect:
(function
| Internal_operation_result
({ operation = Transaction _ ; _} as op, res) ->
Some (op, res)
| _ -> None)
~select:
(function
| Successful_manager_result (Transaction_result _ as op) -> Some op
| _ -> None)
~kind: Kind.Transaction_manager_kind
~proj:
(function
| Transaction_result
{ storage ; big_map_diff ; balance_updates ;
originated_contracts ; consumed_gas ;
storage_size ; paid_storage_size_diff ;
allocated_destination_contract } ->
(storage, big_map_diff, balance_updates,
originated_contracts, consumed_gas,
storage_size, paid_storage_size_diff,
allocated_destination_contract))
~inj:
(fun (storage, big_map_diff, balance_updates,
originated_contracts, consumed_gas,
storage_size, paid_storage_size_diff,
allocated_destination_contract) ->
Transaction_result { storage ; big_map_diff ; balance_updates ;
originated_contracts ; consumed_gas ;
storage_size ; paid_storage_size_diff ;
allocated_destination_contract })
let origination_case =
make
~op_case: Operation.Encoding.Manager_operations.origination_case
~encoding:
(obj5
(dft "balance_updates" Delegate.balance_updates_encoding [])
(dft "originated_contracts" (list Contract.encoding) [])
(dft "consumed_gas" z Z.zero)
(dft "storage_size" z Z.zero)
(dft "paid_storage_size_diff" z Z.zero))
~iselect:
(function
| Internal_operation_result
({ operation = Origination _ ; _} as op, res) ->
Some (op, res)
| _ -> None)
~select:
(function
| Successful_manager_result (Origination_result _ as op) -> Some op
| _ -> None)
~proj:
(function
| Origination_result
{ balance_updates ;
originated_contracts ; consumed_gas ;
storage_size ; paid_storage_size_diff } ->
(balance_updates,
originated_contracts, consumed_gas,
storage_size, paid_storage_size_diff))
~kind: Kind.Origination_manager_kind
~inj:
(fun (balance_updates,
originated_contracts, consumed_gas,
storage_size, paid_storage_size_diff) ->
Origination_result
{ balance_updates ;
originated_contracts ; consumed_gas ;
storage_size ; paid_storage_size_diff })
let delegation_case =
make
~op_case: Operation.Encoding.Manager_operations.delegation_case
~encoding: Data_encoding.(obj1 (dft "consumed_gas" z Z.zero))
~iselect:
(function
| Internal_operation_result
({ operation = Delegation _ ; _} as op, res) ->
Some (op, res)
| _ -> None)
~select:
(function
| Successful_manager_result (Delegation_result _ as op) -> Some op
| _ -> None)
~kind: Kind.Delegation_manager_kind
~proj: (function Delegation_result { consumed_gas } -> consumed_gas)
~inj: (fun consumed_gas -> Delegation_result { consumed_gas })
end
let internal_operation_result_encoding :
packed_internal_operation_result Data_encoding.t =
let make (type kind)
(Manager_result.MCase res_case : kind Manager_result.case) =
let Operation.Encoding.Manager_operations.MCase op_case = res_case.op_case in
case (Tag op_case.tag)
~title:op_case.name
(merge_objs
(obj3
(req "kind" (constant op_case.name))
(req "source" Contract.encoding)
(req "nonce" uint16))
(merge_objs
op_case.encoding
(obj1 (req "result" res_case.t))))
(fun op ->
match res_case.iselect op with
| Some (op, res) ->
Some (((), op.source, op.nonce),
(op_case.proj op.operation, res))
| None -> None)
(fun (((), source, nonce), (op, res)) ->
let op = { source ; operation = op_case.inj op ; nonce } in
Internal_operation_result (op, res)) in
def "operation.alpha.internal_operation_result" @@
union [
make Manager_result.reveal_case ;
make Manager_result.transaction_case ;
make Manager_result.origination_case ;
make Manager_result.delegation_case ;
]
type 'kind contents_result =
| Endorsement_result :
{ balance_updates : Delegate.balance_updates ;
delegate : Signature.Public_key_hash.t ;
slots: int list ;
} -> Kind.endorsement contents_result
| Seed_nonce_revelation_result :
Delegate.balance_updates -> Kind.seed_nonce_revelation contents_result
| Double_endorsement_evidence_result :
Delegate.balance_updates -> Kind.double_endorsement_evidence contents_result
| Double_baking_evidence_result :
Delegate.balance_updates -> Kind.double_baking_evidence contents_result
| Activate_account_result :
Delegate.balance_updates -> Kind.activate_account contents_result
| Proposals_result : Kind.proposals contents_result
| Ballot_result : Kind.ballot contents_result
| Manager_operation_result :
{ balance_updates : Delegate.balance_updates ;
operation_result : 'kind manager_operation_result ;
internal_operation_results : packed_internal_operation_result list ;
} -> 'kind Kind.manager contents_result
type packed_contents_result =
| Contents_result : 'kind contents_result -> packed_contents_result
type packed_contents_and_result =
| Contents_and_result :
'kind Operation.contents * 'kind contents_result -> packed_contents_and_result
type ('a, 'b) eq = Eq : ('a, 'a) eq
let equal_manager_kind
: type a b. a Kind.manager -> b Kind.manager -> (a, b) eq option
= fun ka kb -> match ka, kb with
| Kind.Reveal_manager_kind, Kind.Reveal_manager_kind -> Some Eq
| Kind.Reveal_manager_kind, _ -> None
| Kind.Transaction_manager_kind, Kind.Transaction_manager_kind -> Some Eq
| Kind.Transaction_manager_kind, _ -> None
| Kind.Origination_manager_kind, Kind.Origination_manager_kind -> Some Eq
| Kind.Origination_manager_kind, _ -> None
| Kind.Delegation_manager_kind, Kind.Delegation_manager_kind -> Some Eq
| Kind.Delegation_manager_kind, _ -> None
module Encoding = struct
type 'kind case =
Case : { op_case: 'kind Operation.Encoding.case ;
encoding: 'a Data_encoding.t ;
select: packed_contents_result -> 'kind contents_result option ;
mselect: packed_contents_and_result -> ('kind contents * 'kind contents_result) option ;
proj: 'kind contents_result -> 'a ;
inj: 'a -> 'kind contents_result ;
} -> 'kind case
let tagged_case tag name args proj inj =
let open Data_encoding in
case tag
~title:(String.capitalize_ascii name)
(merge_objs
(obj1 (req "kind" (constant name)))
args)
(fun x -> match proj x with None -> None | Some x -> Some ((), x))
(fun ((), x) -> inj x)
let endorsement_case =
Case {
op_case = Operation.Encoding.endorsement_case ;
encoding =
(obj3
(req "balance_updates" Delegate.balance_updates_encoding)
(req "delegate" Signature.Public_key_hash.encoding)
(req "slots" (list uint8)));
select =
(function
| Contents_result (Endorsement_result _ as op) -> Some op
| _ -> None) ;
mselect =
(function
| Contents_and_result (Endorsement _ as op, res) -> Some (op, res)
| _ -> None) ;
proj =
(function
| Endorsement_result { balance_updates ; delegate ; slots }
-> (balance_updates, delegate, slots)) ;
inj =
(fun (balance_updates, delegate, slots) ->
Endorsement_result { balance_updates ; delegate ; slots })
}
let seed_nonce_revelation_case =
Case {
op_case = Operation.Encoding.seed_nonce_revelation_case ;
encoding =
(obj1
(req "balance_updates" Delegate.balance_updates_encoding)) ;
select =
(function
| Contents_result (Seed_nonce_revelation_result _ as op) -> Some op
| _ -> None) ;
mselect =
(function
| Contents_and_result (Seed_nonce_revelation _ as op, res) -> Some (op, res)
| _ -> None) ;
proj = (fun (Seed_nonce_revelation_result bus) -> bus) ;
inj = (fun bus -> Seed_nonce_revelation_result bus) ;
}
let double_endorsement_evidence_case =
Case {
op_case = Operation.Encoding.double_endorsement_evidence_case ;
encoding =
(obj1
(req "balance_updates" Delegate.balance_updates_encoding)) ;
select =
(function
| Contents_result (Double_endorsement_evidence_result _ as op) -> Some op
| _ -> None) ;
mselect =
(function
| Contents_and_result (Double_endorsement_evidence _ as op, res) -> Some (op, res)
| _ -> None) ;
proj =
(fun (Double_endorsement_evidence_result bus) -> bus) ;
inj = (fun bus -> Double_endorsement_evidence_result bus)
}
let double_baking_evidence_case =
Case {
op_case = Operation.Encoding.double_baking_evidence_case ;
encoding =
(obj1
(req "balance_updates" Delegate.balance_updates_encoding)) ;
select =
(function
| Contents_result (Double_baking_evidence_result _ as op) -> Some op
| _ -> None) ;
mselect =
(function
| Contents_and_result (Double_baking_evidence _ as op, res) -> Some (op, res)
| _ -> None) ;
proj =
(fun (Double_baking_evidence_result bus) -> bus) ;
inj = (fun bus -> Double_baking_evidence_result bus) ;
}
let activate_account_case =
Case {
op_case = Operation.Encoding.activate_account_case ;
encoding =
(obj1
(req "balance_updates" Delegate.balance_updates_encoding)) ;
select =
(function
| Contents_result (Activate_account_result _ as op) -> Some op
| _ -> None) ;
mselect =
(function
| Contents_and_result (Activate_account _ as op, res) -> Some (op, res)
| _ -> None) ;
proj = (fun (Activate_account_result bus) -> bus) ;
inj = (fun bus -> Activate_account_result bus) ;
}
let proposals_case =
Case {
op_case = Operation.Encoding.proposals_case ;
encoding = Data_encoding.empty ;
select =
(function
| Contents_result (Proposals_result as op) -> Some op
| _ -> None) ;
mselect =
(function
| Contents_and_result (Proposals _ as op, res) -> Some (op, res)
| _ -> None) ;
proj = (fun Proposals_result -> ()) ;
inj = (fun () -> Proposals_result) ;
}
let ballot_case =
Case {
op_case = Operation.Encoding.ballot_case ;
encoding = Data_encoding.empty ;
select =
(function
| Contents_result (Ballot_result as op) -> Some op
| _ -> None) ;
mselect =
(function
| Contents_and_result (Ballot _ as op, res) -> Some (op, res)
| _ -> None) ;
proj = (fun Ballot_result -> ()) ;
inj = (fun () -> Ballot_result) ;
}
let make_manager_case
(type kind)
(Operation.Encoding.Case op_case : kind Kind.manager Operation.Encoding.case)
(Manager_result.MCase res_case : kind Manager_result.case)
mselect =
Case {
op_case = Operation.Encoding.Case op_case ;
encoding =
(obj3
(req "balance_updates" Delegate.balance_updates_encoding)
(req "operation_result" res_case.t)
(dft "internal_operation_results"
(list internal_operation_result_encoding) [])) ;
select =
(function
| Contents_result
(Manager_operation_result
({ operation_result = Applied res ; _ } as op)) -> begin
match res_case.select (Successful_manager_result res) with
| Some res ->
Some (Manager_operation_result
{ op with operation_result = Applied res })
| None -> None
end
| Contents_result
(Manager_operation_result
({ operation_result = Backtracked (res, errs) ; _ } as op)) -> begin
match res_case.select (Successful_manager_result res) with
| Some res ->
Some (Manager_operation_result
{ op with operation_result = Backtracked (res, errs) })
| None -> None
end
| Contents_result
(Manager_operation_result
({ operation_result = Skipped kind ; _ } as op)) ->
begin match equal_manager_kind kind res_case.kind with
| None -> None
| Some Eq ->
Some (Manager_operation_result
{ op with operation_result = Skipped kind })
end
| Contents_result
(Manager_operation_result
({ operation_result = Failed (kind, errs) ; _ } as op)) ->
begin match equal_manager_kind kind res_case.kind with
| None -> None
| Some Eq ->
Some (Manager_operation_result
{ op with operation_result = Failed (kind, errs) })
end
| Contents_result Ballot_result -> None
| Contents_result (Endorsement_result _) -> None
| Contents_result (Seed_nonce_revelation_result _) -> None
| Contents_result (Double_endorsement_evidence_result _) -> None
| Contents_result (Double_baking_evidence_result _) -> None
| Contents_result (Activate_account_result _) -> None
| Contents_result Proposals_result -> None) ;
mselect ;
proj =
(fun (Manager_operation_result
{ balance_updates = bus ; operation_result = r ;
internal_operation_results = rs }) ->
(bus, r, rs)) ;
inj =
(fun (bus, r, rs) ->
Manager_operation_result
{ balance_updates = bus ; operation_result = r ;
internal_operation_results = rs }) ;
}
let reveal_case =
make_manager_case
Operation.Encoding.reveal_case
Manager_result.reveal_case
(function
| Contents_and_result
(Manager_operation
{ operation = Reveal _ ; _ } as op, res) ->
Some (op, res)
| _ -> None)
let transaction_case =
make_manager_case
Operation.Encoding.transaction_case
Manager_result.transaction_case
(function
| Contents_and_result
(Manager_operation
{ operation = Transaction _ ; _ } as op, res) ->
Some (op, res)
| _ -> None)
let origination_case =
make_manager_case
Operation.Encoding.origination_case
Manager_result.origination_case
(function
| Contents_and_result
(Manager_operation
{ operation = Origination _ ; _ } as op, res) ->
Some (op, res)
| _ -> None)
let delegation_case =
make_manager_case
Operation.Encoding.delegation_case
Manager_result.delegation_case
(function
| Contents_and_result
(Manager_operation
{ operation = Delegation _ ; _ } as op, res) ->
Some (op, res)
| _ -> None)
end
let contents_result_encoding =
let open Encoding in
let make (Case { op_case = Operation.Encoding.Case { tag ; name ; _ } ;
encoding ; mselect = _ ; select ; proj ; inj }) =
let proj x =
match select x with
| None -> None
| Some x -> Some (proj x) in
let inj x = Contents_result (inj x) in
tagged_case (Tag tag) name encoding proj inj in
def "operation.alpha.contents_result" @@
union [
make endorsement_case ;
make seed_nonce_revelation_case ;
make double_endorsement_evidence_case ;
make double_baking_evidence_case ;
make activate_account_case ;
make proposals_case ;
make ballot_case ;
make reveal_case ;
make transaction_case ;
make origination_case ;
make delegation_case ;
]
let contents_and_result_encoding =
let open Encoding in
let make
(Case { op_case = Operation.Encoding.Case { tag ; name ; encoding ; proj ; inj ; _ } ;
mselect ; encoding = meta_encoding ; proj = meta_proj ; inj = meta_inj ; _ }) =
let proj c =
match mselect c with
| Some (op, res) -> Some (proj op, meta_proj res)
| _ -> None in
let inj (op, res) = Contents_and_result (inj op, meta_inj res) in
let encoding =
merge_objs
encoding
(obj1
(req "metadata" meta_encoding)) in
tagged_case (Tag tag) name encoding proj inj in
def "operation.alpha.operation_contents_and_result" @@
union [
make endorsement_case ;
make seed_nonce_revelation_case ;
make double_endorsement_evidence_case ;
make double_baking_evidence_case ;
make activate_account_case ;
make proposals_case ;
make ballot_case ;
make reveal_case ;
make transaction_case ;
make origination_case ;
make delegation_case ;
]
type 'kind contents_result_list =
| Single_result : 'kind contents_result -> 'kind contents_result_list
| Cons_result :
'kind Kind.manager contents_result * 'rest Kind.manager contents_result_list ->
(('kind * 'rest) Kind.manager ) contents_result_list
type packed_contents_result_list =
Contents_result_list : 'kind contents_result_list -> packed_contents_result_list
let contents_result_list_encoding =
let rec to_list = function
| Contents_result_list (Single_result o) -> [Contents_result o]
| Contents_result_list (Cons_result (o, os)) ->
Contents_result o :: to_list (Contents_result_list os) in
let rec of_list = function
| [] -> Pervasives.failwith "cannot decode empty operation result"
| [Contents_result o] -> Contents_result_list (Single_result o)
| (Contents_result o) :: os ->
let Contents_result_list os = of_list os in
match o, os with
| Manager_operation_result _, Single_result (Manager_operation_result _) ->
Contents_result_list (Cons_result (o, os))
| Manager_operation_result _, Cons_result _ ->
Contents_result_list (Cons_result (o, os))
| _ -> Pervasives.failwith "cannot decode ill-formed operation result" in
def "operation.alpha.contents_list_result" @@
conv to_list of_list (list contents_result_encoding)
type 'kind contents_and_result_list =
| Single_and_result : 'kind Alpha_context.contents * 'kind contents_result -> 'kind contents_and_result_list
| Cons_and_result : 'kind Kind.manager Alpha_context.contents * 'kind Kind.manager contents_result * 'rest Kind.manager contents_and_result_list -> ('kind * 'rest) Kind.manager contents_and_result_list
type packed_contents_and_result_list =
| Contents_and_result_list : 'kind contents_and_result_list -> packed_contents_and_result_list
let contents_and_result_list_encoding =
let rec to_list = function
| Contents_and_result_list (Single_and_result (op, res)) ->
[Contents_and_result (op, res)]
| Contents_and_result_list (Cons_and_result (op, res, rest)) ->
Contents_and_result (op, res) ::
to_list (Contents_and_result_list rest) in
let rec of_list = function
| [] -> Pervasives.failwith "cannot decode empty combined operation result"
| [Contents_and_result (op, res)] ->
Contents_and_result_list (Single_and_result (op, res))
| (Contents_and_result (op, res)) :: rest ->
let Contents_and_result_list rest = of_list rest in
match op, rest with
| Manager_operation _, Single_and_result (Manager_operation _, _) ->
Contents_and_result_list (Cons_and_result (op, res, rest))
| Manager_operation _, Cons_and_result (_, _, _) ->
Contents_and_result_list (Cons_and_result (op, res, rest))
| _ -> Pervasives.failwith "cannot decode ill-formed combined operation result" in
conv to_list of_list (Variable.list contents_and_result_encoding)
type 'kind operation_metadata = {
contents: 'kind contents_result_list ;
}
type packed_operation_metadata =
| Operation_metadata : 'kind operation_metadata -> packed_operation_metadata
| No_operation_metadata : packed_operation_metadata
let operation_metadata_encoding =
def "operation.alpha.result" @@
union [
case (Tag 0)
~title:"Operation_metadata"
contents_result_list_encoding
(function
| Operation_metadata { contents } ->
Some (Contents_result_list contents)
| _ -> None)
(fun (Contents_result_list contents) -> Operation_metadata { contents }) ;
case (Tag 1)
~title:"No_operation_metadata"
empty
(function
| No_operation_metadata -> Some ()
| _ -> None)
(fun () -> No_operation_metadata) ;
]
let kind_equal
: type kind kind2. kind contents -> kind2 contents_result -> (kind, kind2) eq option =
fun op res ->
match op, res with
| Endorsement _, Endorsement_result _ -> Some Eq
| Endorsement _, _ -> None
| Seed_nonce_revelation _, Seed_nonce_revelation_result _ -> Some Eq
| Seed_nonce_revelation _, _ -> None
| Double_endorsement_evidence _, Double_endorsement_evidence_result _ -> Some Eq
| Double_endorsement_evidence _, _ -> None
| Double_baking_evidence _, Double_baking_evidence_result _ -> Some Eq
| Double_baking_evidence _, _ -> None
| Activate_account _, Activate_account_result _ -> Some Eq
| Activate_account _, _ -> None
| Proposals _, Proposals_result -> Some Eq
| Proposals _, _ -> None
| Ballot _, Ballot_result -> Some Eq
| Ballot _, _ -> None
| Manager_operation
{ operation = Reveal _ ; _ },
Manager_operation_result
{ operation_result = Applied (Reveal_result _); _ } -> Some Eq
| Manager_operation
{ operation = Reveal _ ; _ },
Manager_operation_result
{ operation_result = Backtracked (Reveal_result _, _) ; _ } -> Some Eq
| Manager_operation
{ operation = Reveal _ ; _ },
Manager_operation_result
{ operation_result =
Failed (Alpha_context.Kind.Reveal_manager_kind, _); _ } -> Some Eq
| Manager_operation
{ operation = Reveal _ ; _ },
Manager_operation_result
{ operation_result =
Skipped (Alpha_context.Kind.Reveal_manager_kind); _ } -> Some Eq
| Manager_operation { operation = Reveal _ ; _ }, _ -> None
| Manager_operation
{ operation = Transaction _ ; _ },
Manager_operation_result
{ operation_result = Applied (Transaction_result _); _ } -> Some Eq
| Manager_operation
{ operation = Transaction _ ; _ },
Manager_operation_result
{ operation_result = Backtracked (Transaction_result _, _); _ } -> Some Eq
| Manager_operation
{ operation = Transaction _ ; _ },
Manager_operation_result
{ operation_result =
Failed (Alpha_context.Kind.Transaction_manager_kind, _); _ } -> Some Eq
| Manager_operation
{ operation = Transaction _ ; _ },
Manager_operation_result
{ operation_result =
Skipped (Alpha_context.Kind.Transaction_manager_kind); _ } -> Some Eq
| Manager_operation { operation = Transaction _ ; _ }, _ -> None
| Manager_operation
{ operation = Origination _ ; _ },
Manager_operation_result
{ operation_result = Applied (Origination_result _); _ } -> Some Eq
| Manager_operation
{ operation = Origination _ ; _ },
Manager_operation_result
{ operation_result = Backtracked (Origination_result _, _); _ } -> Some Eq
| Manager_operation
{ operation = Origination _ ; _ },
Manager_operation_result
{ operation_result =
Failed (Alpha_context.Kind.Origination_manager_kind, _); _ } -> Some Eq
| Manager_operation
{ operation = Origination _ ; _ },
Manager_operation_result
{ operation_result =
Skipped (Alpha_context.Kind.Origination_manager_kind); _ } -> Some Eq
| Manager_operation { operation = Origination _ ; _ }, _ -> None
| Manager_operation
{ operation = Delegation _ ; _ },
Manager_operation_result
{ operation_result = Applied (Delegation_result _) ; _ } -> Some Eq
| Manager_operation
{ operation = Delegation _ ; _ },
Manager_operation_result
{ operation_result = Backtracked (Delegation_result _, _) ; _ } -> Some Eq
| Manager_operation
{ operation = Delegation _ ; _ },
Manager_operation_result
{ operation_result =
Failed (Alpha_context.Kind.Delegation_manager_kind, _); _ } -> Some Eq
| Manager_operation
{ operation = Delegation _ ; _ },
Manager_operation_result
{ operation_result =
Skipped (Alpha_context.Kind.Delegation_manager_kind); _ } -> Some Eq
| Manager_operation { operation = Delegation _ ; _ }, _ -> None
let rec kind_equal_list
: type kind kind2. kind contents_list -> kind2 contents_result_list -> (kind, kind2) eq option =
fun contents res ->
match contents, res with
| Single op, Single_result res -> begin
match kind_equal op res with
| None -> None
| Some Eq -> Some Eq
end
| Cons (op, ops), Cons_result (res, ress) -> begin
match kind_equal op res with
| None -> None
| Some Eq ->
match kind_equal_list ops ress with
| None -> None
| Some Eq -> Some Eq
end
| _ -> None
let rec pack_contents_list :
type kind. kind contents_list -> kind contents_result_list -> kind contents_and_result_list =
fun contents res -> begin
match contents, res with
| Single op, Single_result res -> Single_and_result (op, res)
| Cons (op, ops), Cons_result (res, ress) ->
Cons_and_result (op, res, pack_contents_list ops ress)
| Single (Manager_operation _),
Cons_result (Manager_operation_result _, Single_result _) -> .
| Cons (_, _),
Single_result (Manager_operation_result
{ operation_result = Failed _ ; _}) -> .
| Cons (_, _),
Single_result (Manager_operation_result
{ operation_result = Skipped _ ; _}) -> .
| Cons (_, _),
Single_result (Manager_operation_result
{ operation_result = Applied _ ; _}) -> .
| Cons (_, _),
Single_result (Manager_operation_result
{ operation_result = Backtracked _ ; _}) -> .
| Single _, Cons_result _ -> .
end
let rec unpack_contents_list :
type kind. kind contents_and_result_list ->
(kind contents_list * kind contents_result_list) =
function
| Single_and_result (op, res) -> Single op, Single_result res
| Cons_and_result (op, res, rest) ->
let ops, ress = unpack_contents_list rest in
Cons (op, ops), Cons_result (res, ress)
let rec to_list = function
| Contents_result_list (Single_result o) -> [Contents_result o]
| Contents_result_list (Cons_result (o, os)) ->
Contents_result o :: to_list (Contents_result_list os)
let rec of_list = function
| [] -> assert false
| [Contents_result o] -> Contents_result_list (Single_result o)
| (Contents_result o) :: os ->
let Contents_result_list os = of_list os in
match o, os with
| Manager_operation_result _, Single_result (Manager_operation_result _) ->
Contents_result_list (Cons_result (o, os))
| Manager_operation_result _, Cons_result _ ->
Contents_result_list (Cons_result (o, os))
| _ ->
Pervasives.failwith "Operation result list of length > 1 \
should only contains manager operations result."
let operation_data_and_metadata_encoding =
def "operation.alpha.operation_with_metadata" @@
union [
case (Tag 0)
~title:"Operation_with_metadata"
(obj2
(req "contents" (dynamic_size contents_and_result_list_encoding))
(opt "signature" Signature.encoding))
(function
| (Operation_data _, No_operation_metadata) -> None
| (Operation_data op, Operation_metadata res) ->
match kind_equal_list op.contents res.contents with
| None -> Pervasives.failwith "cannot decode inconsistent combined operation result"
| Some Eq ->
Some
(Contents_and_result_list
(pack_contents_list op.contents res.contents),
op.signature))
(fun (Contents_and_result_list contents, signature) ->
let op_contents, res_contents = unpack_contents_list contents in
(Operation_data { contents = op_contents ; signature },
Operation_metadata { contents = res_contents })) ;
case (Tag 1)
~title:"Operation_without_metadata"
(obj2
(req "contents" (dynamic_size Operation.contents_list_encoding))
(opt "signature" Signature.encoding))
(function
| (Operation_data op, No_operation_metadata) ->
Some (Contents_list op.contents, op.signature)
| (Operation_data _, Operation_metadata _) ->
None)
(fun (Contents_list contents, signature) ->
(Operation_data { contents ; signature }, No_operation_metadata))
]
type block_metadata = {
baker: Signature.Public_key_hash.t ;
level: Level.t ;
voting_period_kind: Voting_period.kind ;
nonce_hash: Nonce_hash.t option ;
consumed_gas: Z.t ;
deactivated: Signature.Public_key_hash.t list ;
balance_updates: Delegate.balance_updates ;
}
let block_metadata_encoding =
let open Data_encoding in
def "block_header.alpha.metadata" @@
conv
(fun { baker ; level ; voting_period_kind ; nonce_hash ;
consumed_gas ; deactivated ; balance_updates } ->
( baker, level, voting_period_kind, nonce_hash,
consumed_gas, deactivated, balance_updates ))
(fun ( baker, level, voting_period_kind, nonce_hash,
consumed_gas, deactivated, balance_updates ) ->
{ baker ; level ; voting_period_kind ; nonce_hash ;
consumed_gas ; deactivated ; balance_updates })
(obj7
(req "baker" Signature.Public_key_hash.encoding)
(req "level" Level.encoding)
(req "voting_period_kind" Voting_period.kind_encoding)
(req "nonce_hash" (option Nonce_hash.encoding))
(req "consumed_gas" (check_size 10 n))
(req "deactivated" (list Signature.Public_key_hash.encoding))
(req "balance_updates" Delegate.balance_updates_encoding))

167
vendors/ligo-utils/tezos-protocol-alpha/apply_results.mli vendored Normal file
View File

@ -0,0 +1,167 @@
(*****************************************************************************)
(* *)
(* 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. *)
(* *)
(*****************************************************************************)
(** Result of applying an operation, can be used for experimenting
with protocol updates, by clients to print out a summary of the
operation at pre-injection simulation and at confirmation time,
and by block explorers. *)
open Alpha_context
(** Result of applying a {!Operation.t}. Follows the same structure. *)
type 'kind operation_metadata = {
contents: 'kind contents_result_list ;
}
and packed_operation_metadata =
| Operation_metadata : 'kind operation_metadata -> packed_operation_metadata
| No_operation_metadata : packed_operation_metadata
(** Result of applying a {!Operation.contents_list}. Follows the same structure. *)
and 'kind contents_result_list =
| Single_result : 'kind contents_result -> 'kind contents_result_list
| Cons_result :
'kind Kind.manager contents_result * 'rest Kind.manager contents_result_list ->
(('kind * 'rest) Kind.manager ) contents_result_list
and packed_contents_result_list =
| Contents_result_list : 'kind contents_result_list -> packed_contents_result_list
(** Result of applying an {!Operation.contents}. Follows the same structure. *)
and 'kind contents_result =
| Endorsement_result :
{ balance_updates : Delegate.balance_updates ;
delegate : Signature.Public_key_hash.t ;
slots: int list ;
} -> Kind.endorsement contents_result
| Seed_nonce_revelation_result :
Delegate.balance_updates -> Kind.seed_nonce_revelation contents_result
| Double_endorsement_evidence_result :
Delegate.balance_updates -> Kind.double_endorsement_evidence contents_result
| Double_baking_evidence_result :
Delegate.balance_updates -> Kind.double_baking_evidence contents_result
| Activate_account_result :
Delegate.balance_updates -> Kind.activate_account contents_result
| Proposals_result : Kind.proposals contents_result
| Ballot_result : Kind.ballot contents_result
| Manager_operation_result :
{ balance_updates : Delegate.balance_updates ;
operation_result : 'kind manager_operation_result ;
internal_operation_results : packed_internal_operation_result list ;
} -> 'kind Kind.manager contents_result
and packed_contents_result =
| Contents_result : 'kind contents_result -> packed_contents_result
(** The result of an operation in the queue. [Skipped] ones should
always be at the tail, and after a single [Failed]. *)
and 'kind manager_operation_result =
| Applied of 'kind successful_manager_operation_result
| Backtracked of 'kind successful_manager_operation_result * error list option
| Failed : 'kind Kind.manager * error list -> 'kind manager_operation_result
| Skipped : 'kind Kind.manager -> 'kind manager_operation_result
(** Result of applying a {!manager_operation_content}, either internal
or external. *)
and _ successful_manager_operation_result =
| Reveal_result :
{ consumed_gas : Z.t
} -> Kind.reveal successful_manager_operation_result
| Transaction_result :
{ storage : Script.expr option ;
big_map_diff : Contract.big_map_diff option ;
balance_updates : Delegate.balance_updates ;
originated_contracts : Contract.t list ;
consumed_gas : Z.t ;
storage_size : Z.t ;
paid_storage_size_diff : Z.t ;
allocated_destination_contract : bool ;
} -> Kind.transaction successful_manager_operation_result
| Origination_result :
{ balance_updates : Delegate.balance_updates ;
originated_contracts : Contract.t list ;
consumed_gas : Z.t ;
storage_size : Z.t ;
paid_storage_size_diff : Z.t ;
} -> Kind.origination successful_manager_operation_result
| Delegation_result :
{ consumed_gas : Z.t
} -> Kind.delegation successful_manager_operation_result
and packed_successful_manager_operation_result =
| Successful_manager_result :
'kind successful_manager_operation_result -> packed_successful_manager_operation_result
and packed_internal_operation_result =
| Internal_operation_result :
'kind internal_operation * 'kind manager_operation_result ->
packed_internal_operation_result
(** Serializer for {!packed_operation_result}. *)
val operation_metadata_encoding : packed_operation_metadata Data_encoding.t
val operation_data_and_metadata_encoding
: (Operation.packed_protocol_data * packed_operation_metadata) Data_encoding.t
type 'kind contents_and_result_list =
| Single_and_result : 'kind Alpha_context.contents * 'kind contents_result -> 'kind contents_and_result_list
| Cons_and_result : 'kind Kind.manager Alpha_context.contents * 'kind Kind.manager contents_result * 'rest Kind.manager contents_and_result_list -> ('kind * 'rest) Kind.manager contents_and_result_list
type packed_contents_and_result_list =
| Contents_and_result_list : 'kind contents_and_result_list -> packed_contents_and_result_list
val contents_and_result_list_encoding :
packed_contents_and_result_list Data_encoding.t
val pack_contents_list :
'kind contents_list -> 'kind contents_result_list ->
'kind contents_and_result_list
val unpack_contents_list :
'kind contents_and_result_list ->
'kind contents_list * 'kind contents_result_list
val to_list :
packed_contents_result_list -> packed_contents_result list
val of_list :
packed_contents_result list -> packed_contents_result_list
type ('a, 'b) eq = Eq : ('a, 'a) eq
val kind_equal_list :
'kind contents_list -> 'kind2 contents_result_list -> ('kind, 'kind2) eq option
type block_metadata = {
baker: Signature.Public_key_hash.t ;
level: Level.t ;
voting_period_kind: Voting_period.kind ;
nonce_hash: Nonce_hash.t option ;
consumed_gas: Z.t ;
deactivated: Signature.Public_key_hash.t list ;
balance_updates: Delegate.balance_updates ;
}
val block_metadata_encoding: block_metadata Data_encoding.encoding

296
vendors/ligo-utils/tezos-protocol-alpha/baking.ml vendored Normal file
View File

@ -0,0 +1,296 @@
(*****************************************************************************)
(* *)
(* 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 Alpha_context
open Misc
type error += Invalid_fitness_gap of int64 * int64 (* `Permanent *)
type error += Timestamp_too_early of Timestamp.t * Timestamp.t (* `Permanent *)
type error += Unexpected_endorsement (* `Permanent *)
type error += Invalid_block_signature of Block_hash.t * Signature.Public_key_hash.t (* `Permanent *)
type error += Invalid_signature (* `Permanent *)
type error += Invalid_stamp (* `Permanent *)
let () =
register_error_kind
`Permanent
~id:"baking.timestamp_too_early"
~title:"Block forged too early"
~description:"The block timestamp is before the first slot \
for this baker at this level"
~pp:(fun ppf (r, p) ->
Format.fprintf ppf "Block forged too early (%a is before %a)"
Time.pp_hum p Time.pp_hum r)
Data_encoding.(obj2
(req "minimum" Time.encoding)
(req "provided" Time.encoding))
(function Timestamp_too_early (r, p) -> Some (r, p) | _ -> None)
(fun (r, p) -> Timestamp_too_early (r, p)) ;
register_error_kind
`Permanent
~id:"baking.invalid_fitness_gap"
~title:"Invalid fitness gap"
~description:"The gap of fitness is out of bounds"
~pp:(fun ppf (m, g) ->
Format.fprintf ppf
"The gap of fitness %Ld is not between 0 and %Ld" g m)
Data_encoding.(obj2
(req "maximum" int64)
(req "provided" int64))
(function Invalid_fitness_gap (m, g) -> Some (m, g) | _ -> None)
(fun (m, g) -> Invalid_fitness_gap (m, g)) ;
register_error_kind
`Permanent
~id:"baking.invalid_block_signature"
~title:"Invalid block signature"
~description:
"A block was not signed with the expected private key."
~pp:(fun ppf (block, pkh) ->
Format.fprintf ppf "Invalid signature for block %a. Expected: %a."
Block_hash.pp_short block
Signature.Public_key_hash.pp_short pkh)
Data_encoding.(obj2
(req "block" Block_hash.encoding)
(req "expected" Signature.Public_key_hash.encoding))
(function Invalid_block_signature (block, pkh) -> Some (block, pkh) | _ -> None)
(fun (block, pkh) -> Invalid_block_signature (block, pkh));
register_error_kind
`Permanent
~id:"baking.invalid_signature"
~title:"Invalid block signature"
~description:"The block's signature is invalid"
~pp:(fun ppf () ->
Format.fprintf ppf "Invalid block signature")
Data_encoding.empty
(function Invalid_signature -> Some () | _ -> None)
(fun () -> Invalid_signature) ;
register_error_kind
`Permanent
~id:"baking.insufficient_proof_of_work"
~title:"Insufficient block proof-of-work stamp"
~description:"The block's proof-of-work stamp is insufficient"
~pp:(fun ppf () ->
Format.fprintf ppf "Insufficient proof-of-work stamp")
Data_encoding.empty
(function Invalid_stamp -> Some () | _ -> None)
(fun () -> Invalid_stamp) ;
register_error_kind
`Permanent
~id:"baking.unexpected_endorsement"
~title:"Endorsement from unexpected delegate"
~description:"The operation is signed by a delegate without endorsement rights."
~pp:(fun ppf () ->
Format.fprintf ppf
"The endorsement is signed by a delegate without endorsement rights.")
Data_encoding.unit
(function Unexpected_endorsement -> Some () | _ -> None)
(fun () -> Unexpected_endorsement)
let minimal_time c priority pred_timestamp =
let priority = Int32.of_int priority in
let rec cumsum_time_between_blocks acc durations p =
if Compare.Int32.(<=) p 0l then
ok acc
else match durations with
| [] -> cumsum_time_between_blocks acc [ Period.one_minute ] p
| [ last ] ->
Period.mult p last >>? fun period ->
Timestamp.(acc +? period)
| first :: durations ->
Timestamp.(acc +? first) >>? fun acc ->
let p = Int32.pred p in
cumsum_time_between_blocks acc durations p in
Lwt.return
(cumsum_time_between_blocks
pred_timestamp (Constants.time_between_blocks c) (Int32.succ priority))
let earlier_predecessor_timestamp ctxt level =
let current = Level.current ctxt in
let current_timestamp = Timestamp.current ctxt in
let gap = Level.diff level current in
let step = List.hd (Constants.time_between_blocks ctxt) in
if Compare.Int32.(gap < 1l) then
failwith "Baking.earlier_block_timestamp: past block."
else
Lwt.return (Period.mult (Int32.pred gap) step) >>=? fun delay ->
Lwt.return Timestamp.(current_timestamp +? delay) >>=? fun result ->
return result
let check_timestamp c priority pred_timestamp =
minimal_time c priority pred_timestamp >>=? fun minimal_time ->
let timestamp = Alpha_context.Timestamp.current c in
fail_unless Timestamp.(minimal_time <= timestamp)
(Timestamp_too_early (minimal_time, timestamp))
let check_baking_rights c { Block_header.priority ; _ }
pred_timestamp =
let level = Level.current c in
Roll.baking_rights_owner c level ~priority >>=? fun delegate ->
check_timestamp c priority pred_timestamp >>=? fun () ->
return delegate
type error += Incorrect_priority (* `Permanent *)
let () =
register_error_kind
`Permanent
~id:"incorrect_priority"
~title:"Incorrect priority"
~description:"Block priority must be non-negative."
~pp:(fun ppf () ->
Format.fprintf ppf "The block priority must be non-negative.")
Data_encoding.unit
(function Incorrect_priority -> Some () | _ -> None)
(fun () -> Incorrect_priority)
let endorsement_reward ctxt ~block_priority:prio n =
if Compare.Int.(prio >= 0)
then
Lwt.return
Tez.(Constants.endorsement_reward ctxt /? (Int64.(succ (of_int prio)))) >>=? fun tez ->
Lwt.return Tez.(tez *? Int64.of_int n)
else fail Incorrect_priority
let baking_priorities c level =
let rec f priority =
Roll.baking_rights_owner c level ~priority >>=? fun delegate ->
return (LCons (delegate, (fun () -> f (succ priority))))
in
f 0
let endorsement_rights c level =
fold_left_s
(fun acc slot ->
Roll.endorsement_rights_owner c level ~slot >>=? fun pk ->
let pkh = Signature.Public_key.hash pk in
let right =
match Signature.Public_key_hash.Map.find_opt pkh acc with
| None -> (pk, [slot], false)
| Some (pk, slots, used) -> (pk, slot :: slots, used) in
return (Signature.Public_key_hash.Map.add pkh right acc))
Signature.Public_key_hash.Map.empty
(0 --> (Constants.endorsers_per_block c - 1))
let check_endorsement_rights ctxt chain_id (op : Kind.endorsement Operation.t) =
let current_level = Level.current ctxt in
let Single (Endorsement { level ; _ }) = op.protocol_data.contents in
begin
if Raw_level.(succ level = current_level.level) then
return (Alpha_context.allowed_endorsements ctxt)
else
endorsement_rights ctxt (Level.from_raw ctxt level)
end >>=? fun endorsements ->
match
Signature.Public_key_hash.Map.fold (* no find_first *)
(fun pkh (pk, slots, used) acc ->
match Operation.check_signature_sync pk chain_id op with
| Error _ -> acc
| Ok () -> Some (pkh, slots, used))
endorsements None
with
| None -> fail Unexpected_endorsement
| Some v -> return v
let select_delegate delegate delegate_list max_priority =
let rec loop acc l n =
if Compare.Int.(n >= max_priority)
then return (List.rev acc)
else
let LCons (pk, t) = l in
let acc =
if Signature.Public_key_hash.equal delegate (Signature.Public_key.hash pk)
then n :: acc
else acc in
t () >>=? fun t ->
loop acc t (succ n)
in
loop [] delegate_list 0
let first_baking_priorities
ctxt
?(max_priority = 32)
delegate level =
baking_priorities ctxt level >>=? fun delegate_list ->
select_delegate delegate delegate_list max_priority
let check_hash hash stamp_threshold =
let bytes = Block_hash.to_bytes hash in
let word = MBytes.get_int64 bytes 0 in
Compare.Uint64.(word <= stamp_threshold)
let check_header_proof_of_work_stamp shell contents stamp_threshold =
let hash =
Block_header.hash
{ shell ; protocol_data = { contents ; signature = Signature.zero } } in
check_hash hash stamp_threshold
let check_proof_of_work_stamp ctxt block =
let proof_of_work_threshold = Constants.proof_of_work_threshold ctxt in
if check_header_proof_of_work_stamp
block.Block_header.shell
block.protocol_data.contents
proof_of_work_threshold then
return_unit
else
fail Invalid_stamp
let check_signature block chain_id key =
let check_signature key
{ Block_header.shell ; protocol_data = { contents ; signature } } =
let unsigned_header =
Data_encoding.Binary.to_bytes_exn
Block_header.unsigned_encoding
(shell, contents) in
Signature.check ~watermark:(Block_header chain_id) key signature unsigned_header in
if check_signature key block then
return_unit
else
fail (Invalid_block_signature (Block_header.hash block,
Signature.Public_key.hash key))
let max_fitness_gap ctxt =
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 current_fitness = Fitness.current ctxt in
Lwt.return (Fitness.to_int64 block.shell.fitness) >>=? fun announced_fitness ->
let gap = Int64.sub announced_fitness current_fitness in
if Compare.Int64.(gap <= 0L || max_fitness_gap ctxt < gap) then
fail (Invalid_fitness_gap (max_fitness_gap ctxt, gap))
else
return_unit
let last_of_a_cycle ctxt l =
Compare.Int32.(Int32.succ l.Level.cycle_position =
Constants.blocks_per_cycle ctxt)
let dawn_of_a_new_cycle ctxt =
let level = Level.current ctxt in
if last_of_a_cycle ctxt level then
return_some level.cycle
else
return_none

108
vendors/ligo-utils/tezos-protocol-alpha/baking.mli vendored Normal file
View File

@ -0,0 +1,108 @@
(*****************************************************************************)
(* *)
(* 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 Alpha_context
open Misc
type error += Invalid_fitness_gap of int64 * int64 (* `Permanent *)
type error += Timestamp_too_early of Timestamp.t * Timestamp.t (* `Permanent *)
type error += Invalid_block_signature of Block_hash.t * Signature.Public_key_hash.t (* `Permanent *)
type error += Unexpected_endorsement
type error += Invalid_signature (* `Permanent *)
type error += Invalid_stamp (* `Permanent *)
(** [minimal_time ctxt priority pred_block_time] returns the minimal
time, given the predecessor block timestamp [pred_block_time],
after which a baker with priority [priority] is allowed to
bake. Fail with [Invalid_time_between_blocks_constant] if the minimal
time cannot be computed. *)
val minimal_time: context -> int -> Time.t -> Time.t tzresult Lwt.t
(** [check_baking_rights ctxt block pred_timestamp] verifies that:
* the contract that owned the roll at cycle start has the block signer as delegate.
* the timestamp is coherent with the announced slot.
*)
val check_baking_rights:
context -> Block_header.contents -> Time.t ->
public_key tzresult Lwt.t
(** For a given level computes who has the right to
include an endorsement in the next block.
The result can be stored in Alpha_context.allowed_endorsements *)
val endorsement_rights:
context ->
Level.t ->
(public_key * int list * bool) Signature.Public_key_hash.Map.t tzresult Lwt.t
(** Check that the operation was signed by a delegate allowed
to endorse at the level specified by the endorsement. *)
val check_endorsement_rights:
context -> Chain_id.t -> Kind.endorsement Operation.t ->
(public_key_hash * int list * bool) tzresult Lwt.t
(** Returns the endorsement reward calculated w.r.t a given priority. *)
val endorsement_reward: context -> block_priority:int -> int -> Tez.t tzresult Lwt.t
(** [baking_priorities ctxt level] is the lazy list of contract's
public key hashes that are allowed to bake for [level]. *)
val baking_priorities:
context -> Level.t -> public_key lazy_list
(** [first_baking_priorities ctxt ?max_priority contract_hash level]
is a list of priorities of max [?max_priority] elements, where the
delegate of [contract_hash] is allowed to bake for [level]. If
[?max_priority] is [None], a sensible number of priorities is
returned. *)
val first_baking_priorities:
context ->
?max_priority:int ->
public_key_hash ->
Level.t ->
int list tzresult Lwt.t
(** [check_signature ctxt chain_id block id] check if the block is
signed with the given key, and belongs to the given [chain_id] *)
val check_signature: Block_header.t -> Chain_id.t -> public_key -> unit tzresult Lwt.t
(** Checks if the header that would be built from the given components
is valid for the given diffculty. The signature is not passed as it
is does not impact the proof-of-work stamp. The stamp is checked on
the hash of a block header whose signature has been zeroed-out. *)
val check_header_proof_of_work_stamp:
Block_header.shell_header -> Block_header.contents -> int64 -> bool
(** verify if the proof of work stamp is valid *)
val check_proof_of_work_stamp:
context -> Block_header.t -> unit tzresult Lwt.t
(** check if the gap between the fitness of the current context
and the given block is within the protocol parameters *)
val check_fitness_gap:
context -> Block_header.t -> unit 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

51
vendors/ligo-utils/tezos-protocol-alpha/blinded_public_key_hash.ml vendored Normal file
View File

@ -0,0 +1,51 @@
(*****************************************************************************)
(* *)
(* 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. *)
(* *)
(*****************************************************************************)
module H = Blake2B.Make(Base58)(struct
let name = "Blinded public key hash"
let title = "A blinded public key hash"
let b58check_prefix = "\001\002\049\223"
let size = Some Ed25519.Public_key_hash.size
end)
include H
let () =
Base58.check_encoded_prefix b58check_encoding "btz1" 37
let of_ed25519_pkh activation_code pkh =
hash_bytes ~key:activation_code [ Ed25519.Public_key_hash.to_bytes pkh ]
type activation_code = MBytes.t
let activation_code_size = Ed25519.Public_key_hash.size
let activation_code_encoding = Data_encoding.Fixed.bytes activation_code_size
let activation_code_of_hex h =
if Compare.Int.(String.length h <> activation_code_size * 2) then
invalid_arg "Blinded_public_key_hash.activation_code_of_hex" ;
MBytes.of_hex (`Hex h)
module Index = H

38
vendors/ligo-utils/tezos-protocol-alpha/blinded_public_key_hash.mli vendored Normal file
View File

@ -0,0 +1,38 @@
(*****************************************************************************)
(* *)
(* 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. *)
(* *)
(*****************************************************************************)
include S.HASH
val encoding : t Data_encoding.t
val rpc_arg : t RPC_arg.t
type activation_code
val activation_code_encoding : activation_code Data_encoding.t
val of_ed25519_pkh : activation_code -> Ed25519.Public_key_hash.t -> t
val activation_code_of_hex : string -> activation_code
module Index : Storage_description.INDEX with type t = t

138
vendors/ligo-utils/tezos-protocol-alpha/block_header_repr.ml vendored Normal file
View File

@ -0,0 +1,138 @@
(*****************************************************************************)
(* *)
(* 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. *)
(* *)
(*****************************************************************************)
(** Block header *)
type t = {
shell: Block_header.shell_header ;
protocol_data: protocol_data ;
}
and protocol_data = {
contents: contents ;
signature: Signature.t ;
}
and contents = {
priority: int ;
seed_nonce_hash: Nonce_hash.t option ;
proof_of_work_nonce: MBytes.t ;
}
type block_header = t
type raw = Block_header.t
type shell_header = Block_header.shell_header
let raw_encoding = Block_header.encoding
let shell_header_encoding = Block_header.shell_header_encoding
let contents_encoding =
let open Data_encoding in
def "block_header.alpha.unsigned_contents" @@
conv
(fun { priority ; seed_nonce_hash ; proof_of_work_nonce } ->
(priority, proof_of_work_nonce, seed_nonce_hash))
(fun (priority, proof_of_work_nonce, seed_nonce_hash) ->
{ priority ; seed_nonce_hash ; proof_of_work_nonce })
(obj3
(req "priority" uint16)
(req "proof_of_work_nonce"
(Fixed.bytes Constants_repr.proof_of_work_nonce_size))
(opt "seed_nonce_hash" Nonce_hash.encoding))
let protocol_data_encoding =
let open Data_encoding in
def "block_header.alpha.signed_contents" @@
conv
(fun { contents ; signature } -> (contents, signature))
(fun (contents, signature) -> { contents ; signature })
(merge_objs
contents_encoding
(obj1 (req "signature" Signature.encoding)))
let raw { shell ; protocol_data ; } =
let protocol_data =
Data_encoding.Binary.to_bytes_exn
protocol_data_encoding
protocol_data in
{ Block_header.shell ; protocol_data }
let unsigned_encoding =
let open Data_encoding in
merge_objs
Block_header.shell_header_encoding
contents_encoding
let encoding =
let open Data_encoding in
def "block_header.alpha.full_header" @@
conv
(fun { shell ; protocol_data } ->
(shell, protocol_data))
(fun (shell, protocol_data) ->
{ shell ; protocol_data })
(merge_objs
Block_header.shell_header_encoding
protocol_data_encoding)
(** Constants *)
let max_header_length =
let fake_shell = {
Block_header.level = 0l ;
proto_level = 0 ;
predecessor = Block_hash.zero ;
timestamp = Time.of_seconds 0L ;
validation_passes = 0 ;
operations_hash = Operation_list_list_hash.zero ;
fitness = Fitness_repr.from_int64 0L ;
context = Context_hash.zero ;
}
and fake_contents =
{ priority = 0 ;
proof_of_work_nonce =
MBytes.create Constants_repr.proof_of_work_nonce_size ;
seed_nonce_hash = Some Nonce_hash.zero
} in
Data_encoding.Binary.length
encoding
{ shell = fake_shell ;
protocol_data = {
contents = fake_contents ;
signature = Signature.zero ;
}
}
(** Header parsing entry point *)
let hash_raw = Block_header.hash
let hash { shell ; protocol_data } =
Block_header.hash
{ shell ;
protocol_data =
Data_encoding.Binary.to_bytes_exn
protocol_data_encoding
protocol_data }

60
vendors/ligo-utils/tezos-protocol-alpha/block_header_repr.mli vendored Normal file
View File

@ -0,0 +1,60 @@
(*****************************************************************************)
(* *)
(* 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. *)
(* *)
(*****************************************************************************)
type t = {
shell: Block_header.shell_header ;
protocol_data: protocol_data ;
}
and protocol_data = {
contents: contents ;
signature: Signature.t ;
}
and contents = {
priority: int ;
seed_nonce_hash: Nonce_hash.t option ;
proof_of_work_nonce: MBytes.t ;
}
type block_header = t
type raw = Block_header.t
type shell_header = Block_header.shell_header
val raw: block_header -> raw
val encoding: block_header Data_encoding.encoding
val raw_encoding: raw Data_encoding.t
val contents_encoding: contents Data_encoding.t
val unsigned_encoding: (Block_header.shell_header * contents) Data_encoding.t
val protocol_data_encoding: protocol_data Data_encoding.encoding
val shell_header_encoding: shell_header Data_encoding.encoding
val max_header_length: int
(** The maximum size of block headers in bytes *)
val hash: block_header -> Block_hash.t
val hash_raw: raw -> Block_hash.t

128
vendors/ligo-utils/tezos-protocol-alpha/bootstrap_storage.ml vendored Normal file
View File

@ -0,0 +1,128 @@
(*****************************************************************************)
(* *)
(* 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 Misc
let init_account ctxt
({ public_key_hash ; public_key ; amount }: Parameters_repr.bootstrap_account) =
let contract = Contract_repr.implicit_contract public_key_hash in
Contract_storage.credit ctxt contract amount >>=? fun ctxt ->
match public_key with
| Some public_key ->
Contract_storage.reveal_manager_key ctxt contract public_key >>=? fun ctxt ->
Delegate_storage.set ctxt contract (Some public_key_hash) >>=? fun ctxt ->
return ctxt
| None -> return ctxt
let init_contract ~typecheck ctxt
({ delegate ; amount ; script }: Parameters_repr.bootstrap_contract) =
Contract_storage.fresh_contract_from_current_nonce ctxt >>=? fun (ctxt, contract) ->
typecheck ctxt script >>=? fun (script, ctxt) ->
Contract_storage.originate ctxt contract
~balance:amount
~prepaid_bootstrap_storage:true
~manager:Signature.Public_key_hash.zero
~script
~delegate:(Some delegate)
~spendable:false
~delegatable:false >>=? fun ctxt ->
return ctxt
let init ctxt ~typecheck ?ramp_up_cycles ?no_reward_cycles accounts contracts =
let nonce =
Operation_hash.hash_bytes
[ MBytes.of_string "Un festival de GADT." ] in
let ctxt = Raw_context.init_origination_nonce ctxt nonce in
fold_left_s init_account ctxt accounts >>=? fun ctxt ->
fold_left_s (init_contract ~typecheck) ctxt contracts >>=? fun ctxt ->
begin
match no_reward_cycles with
| None -> return ctxt
| Some cycles ->
(* Store pending ramp ups. *)
let constants = Raw_context.constants ctxt in
(* Start without reward *)
Raw_context.patch_constants ctxt
(fun c ->
{ c with
block_reward = Tez_repr.zero ;
endorsement_reward = Tez_repr.zero }) >>= fun ctxt ->
(* Store the final reward. *)
Storage.Ramp_up.Rewards.init ctxt
(Cycle_repr.of_int32_exn (Int32.of_int cycles))
(constants.block_reward,
constants.endorsement_reward)
end >>=? fun ctxt ->
match ramp_up_cycles with
| None -> return ctxt
| Some cycles ->
(* Store pending ramp ups. *)
let constants = Raw_context.constants ctxt in
Lwt.return Tez_repr.(constants.block_security_deposit /? Int64.of_int cycles) >>=? fun block_step ->
Lwt.return Tez_repr.(constants.endorsement_security_deposit /? Int64.of_int cycles) >>=? fun endorsement_step ->
(* Start without security_deposit *)
Raw_context.patch_constants ctxt
(fun c ->
{ c with
block_security_deposit = Tez_repr.zero ;
endorsement_security_deposit = Tez_repr.zero }) >>= fun ctxt ->
fold_left_s
(fun ctxt cycle ->
Lwt.return Tez_repr.(block_step *? Int64.of_int cycle) >>=? fun block_security_deposit ->
Lwt.return Tez_repr.(endorsement_step *? Int64.of_int cycle) >>=? fun endorsement_security_deposit ->
let cycle = Cycle_repr.of_int32_exn (Int32.of_int cycle) in
Storage.Ramp_up.Security_deposits.init ctxt cycle
(block_security_deposit, endorsement_security_deposit))
ctxt
(1 --> (cycles - 1)) >>=? fun ctxt ->
(* Store the final security deposits. *)
Storage.Ramp_up.Security_deposits.init ctxt
(Cycle_repr.of_int32_exn (Int32.of_int cycles))
(constants.block_security_deposit,
constants.endorsement_security_deposit) >>=? fun ctxt ->
return ctxt
let cycle_end ctxt last_cycle =
let next_cycle = Cycle_repr.succ last_cycle in
begin
Storage.Ramp_up.Rewards.get_option ctxt next_cycle >>=? function
| None -> return ctxt
| Some (block_reward, endorsement_reward) ->
Storage.Ramp_up.Rewards.delete ctxt next_cycle >>=? fun ctxt ->
Raw_context.patch_constants ctxt
(fun c ->
{ c with block_reward ;
endorsement_reward }) >>= fun ctxt ->
return ctxt
end >>=? fun ctxt ->
Storage.Ramp_up.Security_deposits.get_option ctxt next_cycle >>=? function
| None -> return ctxt
| Some (block_security_deposit, endorsement_security_deposit) ->
Storage.Ramp_up.Security_deposits.delete ctxt next_cycle >>=? fun ctxt ->
Raw_context.patch_constants ctxt
(fun c ->
{ c with block_security_deposit ;
endorsement_security_deposit }) >>= fun ctxt ->
return ctxt

40
vendors/ligo-utils/tezos-protocol-alpha/bootstrap_storage.mli vendored Normal file
View File

@ -0,0 +1,40 @@
(*****************************************************************************)
(* *)
(* 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. *)
(* *)
(*****************************************************************************)
val init:
Raw_context.t ->
typecheck:(Raw_context.t -> Script_repr.t ->
((Script_repr.t * Contract_storage.big_map_diff option) * Raw_context.t)
tzresult Lwt.t) ->
?ramp_up_cycles:int ->
?no_reward_cycles:int ->
Parameters_repr.bootstrap_account list ->
Parameters_repr.bootstrap_contract list ->
Raw_context.t tzresult Lwt.t
val cycle_end:
Raw_context.t ->
Cycle_repr.t ->
Raw_context.t tzresult Lwt.t

40
vendors/ligo-utils/tezos-protocol-alpha/commitment_repr.ml vendored Normal file
View File

@ -0,0 +1,40 @@
(*****************************************************************************)
(* *)
(* 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. *)
(* *)
(*****************************************************************************)
type t = {
blinded_public_key_hash : Blinded_public_key_hash.t ;
amount : Tez_repr.t
}
let encoding =
let open Data_encoding in
conv
(fun { blinded_public_key_hash ; amount } ->
( blinded_public_key_hash, amount ))
(fun ( blinded_public_key_hash, amount) ->
{ blinded_public_key_hash ; amount })
(tup2
Blinded_public_key_hash.encoding
Tez_repr.encoding)

31
vendors/ligo-utils/tezos-protocol-alpha/commitment_repr.mli vendored Normal file
View File

@ -0,0 +1,31 @@
(*****************************************************************************)
(* *)
(* 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. *)
(* *)
(*****************************************************************************)
type t = {
blinded_public_key_hash : Blinded_public_key_hash.t ;
amount : Tez_repr.t ;
}
val encoding : t Data_encoding.t

33
vendors/ligo-utils/tezos-protocol-alpha/commitment_storage.ml vendored Normal file
View File

@ -0,0 +1,33 @@
(*****************************************************************************)
(* *)
(* 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. *)
(* *)
(*****************************************************************************)
let get_opt = Storage.Commitments.get_option
let delete = Storage.Commitments.delete
let init ctxt commitments =
let init_commitment ctxt Commitment_repr.{ blinded_public_key_hash ; amount } =
Storage.Commitments.init ctxt blinded_public_key_hash amount in
fold_left_s init_commitment ctxt commitments >>=? fun ctxt ->
return ctxt

37
vendors/ligo-utils/tezos-protocol-alpha/commitment_storage.mli vendored Normal file
View File

@ -0,0 +1,37 @@
(*****************************************************************************)
(* *)
(* 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. *)
(* *)
(*****************************************************************************)
val init:
Raw_context.t ->
Commitment_repr.t list ->
Raw_context.t tzresult Lwt.t
val get_opt:
Raw_context.t -> Blinded_public_key_hash.t ->
Tez_repr.t option tzresult Lwt.t
val delete:
Raw_context.t -> Blinded_public_key_hash.t ->
Raw_context.t tzresult Lwt.t

236
vendors/ligo-utils/tezos-protocol-alpha/constants_repr.ml vendored Normal file
View File

@ -0,0 +1,236 @@
(*****************************************************************************)
(* *)
(* 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. *)
(* *)
(*****************************************************************************)
let version_number = "\000"
let proof_of_work_nonce_size = 8
let nonce_length = 32
let max_revelations_per_block = 32
let max_proposals_per_delegate = 20
let max_operation_data_length = 16 * 1024 (* 16kB *)
type fixed = {
proof_of_work_nonce_size : int ;
nonce_length : int ;
max_revelations_per_block : int ;
max_operation_data_length : int ;
max_proposals_per_delegate : int ;
}
let fixed_encoding =
let open Data_encoding in
conv
(fun c ->
(c.proof_of_work_nonce_size,
c.nonce_length,
c.max_revelations_per_block,
c.max_operation_data_length,
c.max_proposals_per_delegate))
(fun (proof_of_work_nonce_size,
nonce_length,
max_revelations_per_block,
max_operation_data_length,
max_proposals_per_delegate) ->
{ proof_of_work_nonce_size ;
nonce_length ;
max_revelations_per_block ;
max_operation_data_length ;
max_proposals_per_delegate ;
} )
(obj5
(req "proof_of_work_nonce_size" uint8)
(req "nonce_length" uint8)
(req "max_revelations_per_block" uint8)
(req "max_operation_data_length" int31)
(req "max_proposals_per_delegate" uint8))
let fixed = {
proof_of_work_nonce_size ;
nonce_length ;
max_revelations_per_block ;
max_operation_data_length ;
max_proposals_per_delegate ;
}
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;
}
let parametric_encoding =
let open Data_encoding in
conv
(fun c ->
(( c.preserved_cycles,
c.blocks_per_cycle,
c.blocks_per_commitment,
c.blocks_per_roll_snapshot,
c.blocks_per_voting_period,
c.time_between_blocks,
c.endorsers_per_block,
c.hard_gas_limit_per_operation,
c.hard_gas_limit_per_block),
((c.proof_of_work_threshold,
c.tokens_per_roll,
c.michelson_maximum_type_size,
c.seed_nonce_revelation_tip,
c.origination_size,
c.block_security_deposit,
c.endorsement_security_deposit,
c.block_reward),
(c.endorsement_reward,
c.cost_per_byte,
c.hard_storage_limit_per_operation,
c.test_chain_duration))) )
(fun (( 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))) ->
{ 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 ;
} )
(merge_objs
(obj9
(req "preserved_cycles" uint8)
(req "blocks_per_cycle" int32)
(req "blocks_per_commitment" int32)
(req "blocks_per_roll_snapshot" int32)
(req "blocks_per_voting_period" int32)
(req "time_between_blocks" (list Period_repr.encoding))
(req "endorsers_per_block" uint16)
(req "hard_gas_limit_per_operation" z)
(req "hard_gas_limit_per_block" z))
(merge_objs
(obj8
(req "proof_of_work_threshold" int64)
(req "tokens_per_roll" Tez_repr.encoding)
(req "michelson_maximum_type_size" uint16)
(req "seed_nonce_revelation_tip" Tez_repr.encoding)
(req "origination_size" int31)
(req "block_security_deposit" Tez_repr.encoding)
(req "endorsement_security_deposit" Tez_repr.encoding)
(req "block_reward" Tez_repr.encoding))
(obj4
(req "endorsement_reward" Tez_repr.encoding)
(req "cost_per_byte" Tez_repr.encoding)
(req "hard_storage_limit_per_operation" z)
(req "test_chain_duration" int64))))
type t = {
fixed : fixed ;
parametric : parametric ;
}
let encoding =
let open Data_encoding in
conv
(fun { fixed ; parametric } -> (fixed, parametric))
(fun (fixed , parametric) -> { fixed ; parametric })
(merge_objs fixed_encoding parametric_encoding)

65
vendors/ligo-utils/tezos-protocol-alpha/constants_services.ml vendored Normal file
View File

@ -0,0 +1,65 @@
(*****************************************************************************)
(* *)
(* 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 Alpha_context
let custom_root =
(RPC_path.(open_root / "context" / "constants") : RPC_context.t RPC_path.context)
module S = struct
open Data_encoding
let errors =
RPC_service.get_service
~description: "Schema for all the RPC errors from this protocol version"
~query: RPC_query.empty
~output: json_schema
RPC_path.(custom_root / "errors")
let all =
RPC_service.get_service
~description: "All constants"
~query: RPC_query.empty
~output: Alpha_context.Constants.encoding
custom_root
end
let register () =
let open Services_registration in
register0_noctxt S.errors begin fun () () ->
return (Data_encoding.Json.(schema error_encoding))
end ;
register0 S.all begin fun ctxt () () ->
let open Constants in
return { fixed = fixed ;
parametric = parametric ctxt }
end
let errors ctxt block =
RPC_context.make_call0 S.errors ctxt block () ()
let all ctxt block =
RPC_context.make_call0 S.all ctxt block () ()

35
vendors/ligo-utils/tezos-protocol-alpha/constants_services.mli vendored Normal file
View File

@ -0,0 +1,35 @@
(*****************************************************************************)
(* *)
(* 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 Alpha_context
val errors:
'a #RPC_context.simple -> 'a -> Data_encoding.json_schema shell_tzresult Lwt.t
(** Returns all the constants of the protocol *)
val all:
'a #RPC_context.simple -> 'a -> Constants.t shell_tzresult Lwt.t
val register: unit -> unit

90
vendors/ligo-utils/tezos-protocol-alpha/constants_storage.ml vendored Normal file
View File

@ -0,0 +1,90 @@
(*****************************************************************************)
(* *)
(* 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. *)
(* *)
(*****************************************************************************)
let preserved_cycles c =
let constants = Raw_context.constants c in
constants.preserved_cycles
let blocks_per_cycle c =
let constants = Raw_context.constants c in
constants.blocks_per_cycle
let blocks_per_commitment c =
let constants = Raw_context.constants c in
constants.blocks_per_commitment
let blocks_per_roll_snapshot c =
let constants = Raw_context.constants c in
constants.blocks_per_roll_snapshot
let blocks_per_voting_period c =
let constants = Raw_context.constants c in
constants.blocks_per_voting_period
let time_between_blocks c =
let constants = Raw_context.constants c in
constants.time_between_blocks
let endorsers_per_block c =
let constants = Raw_context.constants c in
constants.endorsers_per_block
let hard_gas_limit_per_operation c =
let constants = Raw_context.constants c in
constants.hard_gas_limit_per_operation
let hard_gas_limit_per_block c =
let constants = Raw_context.constants c in
constants.hard_gas_limit_per_block
let cost_per_byte c =
let constants = Raw_context.constants c in
constants.cost_per_byte
let hard_storage_limit_per_operation c =
let constants = Raw_context.constants c in
constants.hard_storage_limit_per_operation
let proof_of_work_threshold c =
let constants = Raw_context.constants c in
constants.proof_of_work_threshold
let tokens_per_roll c =
let constants = Raw_context.constants c in
constants.tokens_per_roll
let michelson_maximum_type_size c =
let constants = Raw_context.constants c in
constants.michelson_maximum_type_size
let seed_nonce_revelation_tip c =
let constants = Raw_context.constants c in
constants.seed_nonce_revelation_tip
let origination_size c =
let constants = Raw_context.constants c in
constants.origination_size
let block_security_deposit c =
let constants = Raw_context.constants c in
constants.block_security_deposit
let endorsement_security_deposit c =
let constants = Raw_context.constants c in
constants.endorsement_security_deposit
let block_reward c =
let constants = Raw_context.constants c in
constants.block_reward
let endorsement_reward c =
let constants = Raw_context.constants c in
constants.endorsement_reward
let test_chain_duration c =
let constants = Raw_context.constants c in
constants.test_chain_duration
let parametric c =
Raw_context.constants c

37
vendors/ligo-utils/tezos-protocol-alpha/contract_hash.ml vendored Normal file
View File

@ -0,0 +1,37 @@
(*****************************************************************************)
(* *)
(* 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. *)
(* *)
(*****************************************************************************)
(* 20 *)
let contract_hash = "\002\090\121" (* KT1(36) *)
include Blake2B.Make(Base58)(struct
let name = "Contract_hash"
let title = "A contract ID"
let b58check_prefix = contract_hash
let size = Some 20
end)
let () =
Base58.check_encoded_prefix b58check_encoding "KT1" 36

212
vendors/ligo-utils/tezos-protocol-alpha/contract_repr.ml vendored Normal file
View File

@ -0,0 +1,212 @@
(*****************************************************************************)
(* *)
(* 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. *)
(* *)
(*****************************************************************************)
type t =
| Implicit of Signature.Public_key_hash.t
| Originated of Contract_hash.t
include Compare.Make(struct
type nonrec t = t
let compare l1 l2 =
match l1, l2 with
| Implicit pkh1, Implicit pkh2 ->
Signature.Public_key_hash.compare pkh1 pkh2
| Originated h1, Originated h2 ->
Contract_hash.compare h1 h2
| Implicit _, Originated _ -> -1
| Originated _, Implicit _ -> 1
end)
type contract = t
type error += Invalid_contract_notation of string (* `Permanent *)
let to_b58check = function
| Implicit pbk -> Signature.Public_key_hash.to_b58check pbk
| Originated h -> Contract_hash.to_b58check h
let of_b58check s =
match Base58.decode s with
| Some (Ed25519.Public_key_hash.Data h) -> ok (Implicit (Signature.Ed25519 h))
| Some (Secp256k1.Public_key_hash.Data h) -> ok (Implicit (Signature.Secp256k1 h))
| Some (P256.Public_key_hash.Data h) -> ok (Implicit (Signature.P256 h))
| Some (Contract_hash.Data h) -> ok (Originated h)
| _ -> error (Invalid_contract_notation s)
let pp ppf = function
| Implicit pbk -> Signature.Public_key_hash.pp ppf pbk
| Originated h -> Contract_hash.pp ppf h
let pp_short ppf = function
| Implicit pbk -> Signature.Public_key_hash.pp_short ppf pbk
| Originated h -> Contract_hash.pp_short ppf h
let encoding =
let open Data_encoding in
def "contract_id"
~title:
"A contract handle"
~description:
"A contract notation as given to an RPC or inside scripts. \
Can be a base58 implicit contract hash \
or a base58 originated contract hash." @@
splitted
~binary:
(union ~tag_size:`Uint8 [
case (Tag 0)
~title:"Implicit"
Signature.Public_key_hash.encoding
(function Implicit k -> Some k | _ -> None)
(fun k -> Implicit k) ;
case (Tag 1) (Fixed.add_padding Contract_hash.encoding 1)
~title:"Originated"
(function Originated k -> Some k | _ -> None)
(fun k -> Originated k) ;
])
~json:
(conv
to_b58check
(fun s ->
match of_b58check s with
| Ok s -> s
| Error _ -> Json.cannot_destruct "Invalid contract notation.")
string)
let () =
let open Data_encoding in
register_error_kind
`Permanent
~id:"contract.invalid_contract_notation"
~title: "Invalid contract notation"
~pp: (fun ppf x -> Format.fprintf ppf "Invalid contract notation %S" x)
~description:
"A malformed contract notation was given to an RPC or in a script."
(obj1 (req "notation" string))
(function Invalid_contract_notation loc -> Some loc | _ -> None)
(fun loc -> Invalid_contract_notation loc)
let implicit_contract id = Implicit id
let is_implicit = function
| Implicit m -> Some m
| Originated _ -> None
let is_originated = function
| Implicit _ -> None
| Originated h -> Some h
type origination_nonce =
{ operation_hash: Operation_hash.t ;
origination_index: int32 }
let origination_nonce_encoding =
let open Data_encoding in
conv
(fun { operation_hash ; origination_index } ->
(operation_hash, origination_index))
(fun (operation_hash, origination_index) ->
{ operation_hash ; origination_index }) @@
obj2
(req "operation" Operation_hash.encoding)
(dft "index" int32 0l)
let originated_contract nonce =
let data =
Data_encoding.Binary.to_bytes_exn origination_nonce_encoding nonce in
Originated (Contract_hash.hash_bytes [data])
let originated_contracts
~since: { origination_index = first ; operation_hash = first_hash }
~until: ({ origination_index = last ; operation_hash = last_hash } as origination_nonce) =
assert (Operation_hash.equal first_hash last_hash) ;
let rec contracts acc origination_index =
if Compare.Int32.(origination_index < first) then
acc
else
let origination_nonce =
{ origination_nonce with origination_index } in
let acc = originated_contract origination_nonce :: acc in
contracts acc (Int32.pred origination_index) in
contracts [] (Int32.pred last)
let initial_origination_nonce operation_hash =
{ operation_hash ; origination_index = 0l }
let incr_origination_nonce nonce =
let origination_index = Int32.succ nonce.origination_index in
{ nonce with origination_index }
let rpc_arg =
let construct = to_b58check in
let destruct hash =
match of_b58check hash with
| Error _ -> Error "Cannot parse contract id"
| Ok contract -> Ok contract in
RPC_arg.make
~descr: "A contract identifier encoded in b58check."
~name: "contract_id"
~construct
~destruct
()
module Index = struct
type t = contract
let path_length = 7
let to_path c l =
let raw_key = Data_encoding.Binary.to_bytes_exn encoding c in
let `Hex key = MBytes.to_hex raw_key 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 ::
key ::
l
let of_path = function
| [] | [_] | [_;_] | [_;_;_] | [_;_;_;_] | [_;_;_;_;_] | [_;_;_;_;_;_]
| _::_::_::_::_::_::_::_::_ ->
None
| [ index1 ; index2 ; index3 ; index4 ; index5 ; index6 ; key ] ->
let raw_key = MBytes.of_hex (`Hex key) 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) ;
Data_encoding.Binary.of_bytes encoding raw_key
let rpc_arg = rpc_arg
let encoding = encoding
let compare = compare
end

79
vendors/ligo-utils/tezos-protocol-alpha/contract_repr.mli vendored Normal file
View File

@ -0,0 +1,79 @@
(*****************************************************************************)
(* *)
(* 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. *)
(* *)
(*****************************************************************************)
type t = private
| Implicit of Signature.Public_key_hash.t
| Originated of Contract_hash.t
type contract = t
include Compare.S with type t := contract
(** {2 Implicit contracts} *****************************************************)
val implicit_contract : Signature.Public_key_hash.t -> contract
val is_implicit : contract -> Signature.Public_key_hash.t option
(** {2 Originated contracts} **************************************************)
(** Originated contracts handles are crafted from the hash of the
operation that triggered their origination (and nothing else).
As a single operation can trigger several originations, the
corresponding handles are forged from a deterministic sequence of
nonces, initialized with the hash of the operation. *)
type origination_nonce
val originated_contract : origination_nonce -> contract
val originated_contracts : since: origination_nonce -> until: origination_nonce -> contract list
val initial_origination_nonce : Operation_hash.t -> origination_nonce
val incr_origination_nonce : origination_nonce -> origination_nonce
val is_originated : contract -> Contract_hash.t option
(** {2 Human readable notation} ***********************************************)
type error += Invalid_contract_notation of string (* `Permanent *)
val to_b58check: contract -> string
val of_b58check: string -> contract tzresult
val pp: Format.formatter -> contract -> unit
val pp_short: Format.formatter -> contract -> unit
(** {2 Serializers} ***********************************************************)
val encoding : contract Data_encoding.t
val origination_nonce_encoding : origination_nonce Data_encoding.t
val rpc_arg : contract RPC_arg.arg
module Index : Storage_description.INDEX with type t = t

273
vendors/ligo-utils/tezos-protocol-alpha/contract_services.ml vendored Normal file
View File

@ -0,0 +1,273 @@
(*****************************************************************************)
(* *)
(* 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 Alpha_context
let custom_root =
(RPC_path.(open_root / "context" / "contracts") : RPC_context.t RPC_path.context)
type info = {
manager: public_key_hash ;
balance: Tez.t ;
spendable: bool ;
delegate: bool * public_key_hash option ;
counter: counter ;
script: Script.t option ;
}
let info_encoding =
let open Data_encoding in
conv
(fun {manager ; balance ; spendable ; delegate ;
script ; counter } ->
(manager, balance, spendable, delegate,
script, counter))
(fun (manager, balance, spendable, delegate,
script, counter) ->
{manager ; balance ; spendable ; delegate ;
script ; counter}) @@
obj6
(req "manager" Signature.Public_key_hash.encoding)
(req "balance" Tez.encoding)
(req "spendable" bool)
(req "delegate" @@ obj2
(req "setable" bool)
(opt "value" Signature.Public_key_hash.encoding))
(opt "script" Script.encoding)
(req "counter" n)
module S = struct
open Data_encoding
let balance =
RPC_service.get_service
~description: "Access the balance of a contract."
~query: RPC_query.empty
~output: Tez.encoding
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 =
RPC_service.get_service
~description: "Access the manager of a contract."
~query: RPC_query.empty
~output: (obj2
(req "manager" Signature.Public_key_hash.encoding)
(opt "key" Signature.Public_key.encoding))
RPC_path.(custom_root /: Contract.rpc_arg / "manager_key")
let delegate =
RPC_service.get_service
~description: "Access the delegate of a contract, if any."
~query: RPC_query.empty
~output: Signature.Public_key_hash.encoding
RPC_path.(custom_root /: Contract.rpc_arg / "delegate")
let counter =
RPC_service.get_service
~description: "Access the counter of a contract, if any."
~query: RPC_query.empty
~output: z
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 =
RPC_service.get_service
~description: "Access the code and data of the contract."
~query: RPC_query.empty
~output: Script.encoding
RPC_path.(custom_root /: Contract.rpc_arg / "script")
let storage =
RPC_service.get_service
~description: "Access the data of the contract."
~query: RPC_query.empty
~output: Script.expr_encoding
RPC_path.(custom_root /: Contract.rpc_arg / "storage")
let big_map_get =
RPC_service.post_service
~description: "Access the value associated with a key in the big map storage of the contract."
~query: RPC_query.empty
~input: (obj2
(req "key" Script.expr_encoding)
(req "type" Script.expr_encoding))
~output: (option Script.expr_encoding)
RPC_path.(custom_root /: Contract.rpc_arg / "big_map_get")
let info =
RPC_service.get_service
~description: "Access the complete status of a contract."
~query: RPC_query.empty
~output: info_encoding
RPC_path.(custom_root /: Contract.rpc_arg)
let list =
RPC_service.get_service
~description:
"All existing contracts (including non-empty default contracts)."
~query: RPC_query.empty
~output: (list Contract.encoding)
custom_root
end
let register () =
let open Services_registration in
register0 S.list begin fun ctxt () () ->
Contract.list ctxt >>= return
end ;
let register_field s f =
register1 s (fun ctxt contract () () ->
Contract.exists ctxt contract >>=? function
| true -> f ctxt contract
| false -> raise Not_found) in
let register_opt_field s f =
register_field s
(fun ctxt a1 ->
f ctxt a1 >>=? function
| None -> raise Not_found
| Some v -> return v) in
register_field S.balance Contract.get_balance ;
register_field S.manager Contract.get_manager ;
register_field S.manager_key
(fun ctxt c ->
Contract.get_manager ctxt c >>=? fun mgr ->
Contract.is_manager_key_revealed ctxt c >>=? fun revealed ->
if revealed then
Contract.get_manager_key ctxt c >>=? fun key ->
return (mgr, Some key)
else return (mgr, None)) ;
register_opt_field S.delegate Delegate.get ;
register_field S.counter Contract.get_counter ;
register_field S.spendable Contract.is_spendable ;
register_field S.delegatable Contract.is_delegatable ;
register_opt_field S.script
(fun c v -> Contract.get_script c v >>=? fun (_, v) -> return v) ;
register_opt_field S.storage (fun ctxt contract ->
Contract.get_script ctxt contract >>=? fun (ctxt, script) ->
match script with
| None -> return_none
| Some script ->
let ctxt = Gas.set_unlimited ctxt in
let open Script_ir_translator in
parse_script ctxt script >>=? fun (Ex_script script, ctxt) ->
unparse_script ctxt Readable script >>=? fun (script, ctxt) ->
Script.force_decode ctxt script.storage >>=? fun (storage, _ctxt) ->
return_some storage) ;
register1 S.big_map_get (fun ctxt contract () (key, key_type) ->
let open Script_ir_translator in
let ctxt = Gas.set_unlimited ctxt in
Lwt.return (parse_ty ctxt ~allow_big_map:false ~allow_operation:false (Micheline.root key_type))
>>=? fun (Ex_ty key_type, ctxt) ->
parse_data ctxt key_type (Micheline.root key) >>=? fun (key, ctxt) ->
hash_data ctxt key_type key >>=? fun (key_hash, ctxt) ->
Contract.Big_map.get_opt ctxt contract key_hash >>=? fun (_ctxt, value) ->
return value) ;
register_field S.info (fun ctxt contract ->
Contract.get_balance ctxt contract >>=? fun balance ->
Contract.get_manager ctxt contract >>=? fun manager ->
Delegate.get ctxt contract >>=? fun delegate ->
Contract.get_counter ctxt contract >>=? fun counter ->
Contract.is_delegatable ctxt contract >>=? fun delegatable ->
Contract.is_spendable ctxt contract >>=? fun spendable ->
Contract.get_script ctxt contract >>=? fun (ctxt, script) ->
begin match script with
| None -> return (None, ctxt)
| Some script ->
let ctxt = Gas.set_unlimited ctxt in
let open Script_ir_translator in
parse_script ctxt script >>=? fun (Ex_script script, ctxt) ->
unparse_script ctxt Readable script >>=? fun (script, ctxt) ->
return (Some script, ctxt)
end >>=? fun (script, _ctxt) ->
return { manager ; balance ;
spendable ; delegate = (delegatable, delegate) ;
script ; counter })
let list ctxt block =
RPC_context.make_call0 S.list ctxt block () ()
let info ctxt block contract =
RPC_context.make_call1 S.info ctxt block contract () ()
let balance ctxt block contract =
RPC_context.make_call1 S.balance ctxt block contract () ()
let manager ctxt block contract =
RPC_context.make_call1 S.manager ctxt block contract () ()
let manager_key ctxt block contract =
RPC_context.make_call1 S.manager_key ctxt block contract () ()
let delegate ctxt block contract =
RPC_context.make_call1 S.delegate ctxt block contract () ()
let delegate_opt ctxt block contract =
RPC_context.make_opt_call1 S.delegate ctxt block contract () ()
let counter ctxt block contract =
RPC_context.make_call1 S.counter ctxt block contract () ()
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 =
RPC_context.make_call1 S.script ctxt block contract () ()
let script_opt ctxt block contract =
RPC_context.make_opt_call1 S.script ctxt block contract () ()
let storage ctxt block contract =
RPC_context.make_call1 S.storage ctxt block contract () ()
let storage_opt ctxt block contract =
RPC_context.make_opt_call1 S.storage ctxt block contract () ()
let big_map_get_opt ctxt block contract key =
RPC_context.make_call1 S.big_map_get ctxt block contract () key

86
vendors/ligo-utils/tezos-protocol-alpha/contract_services.mli vendored Normal file
View File

@ -0,0 +1,86 @@
(*****************************************************************************)
(* *)
(* 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 Alpha_context
val list:
'a #RPC_context.simple -> 'a -> Contract.t list shell_tzresult Lwt.t
type info = {
manager: public_key_hash ;
balance: Tez.t ;
spendable: bool ;
delegate: bool * public_key_hash option ;
counter: counter ;
script: Script.t option ;
}
val info_encoding: info Data_encoding.t
val info:
'a #RPC_context.simple -> 'a -> Contract.t -> info shell_tzresult Lwt.t
val balance:
'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:
'a #RPC_context.simple -> 'a -> Contract.t -> (public_key_hash * public_key option) shell_tzresult Lwt.t
val delegate:
'a #RPC_context.simple -> 'a -> Contract.t -> public_key_hash shell_tzresult Lwt.t
val delegate_opt:
'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:
'a #RPC_context.simple -> 'a -> Contract.t -> counter shell_tzresult Lwt.t
val script:
'a #RPC_context.simple -> 'a -> Contract.t -> Script.t shell_tzresult Lwt.t
val script_opt:
'a #RPC_context.simple -> 'a -> Contract.t -> Script.t option shell_tzresult Lwt.t
val storage:
'a #RPC_context.simple -> 'a -> Contract.t -> Script.expr shell_tzresult Lwt.t
val storage_opt:
'a #RPC_context.simple -> 'a -> Contract.t -> Script.expr option shell_tzresult Lwt.t
val 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

526
vendors/ligo-utils/tezos-protocol-alpha/contract_storage.ml vendored Normal file
View File

@ -0,0 +1,526 @@
(*****************************************************************************)
(* *)
(* 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. *)
(* *)
(*****************************************************************************)
type error +=
| Balance_too_low of Contract_repr.contract * Tez_repr.t * Tez_repr.t (* `Temporary *)
| Counter_in_the_past of Contract_repr.contract * Z.t * Z.t (* `Branch *)
| Counter_in_the_future of Contract_repr.contract * Z.t * Z.t (* `Temporary *)
| Unspendable_contract of Contract_repr.contract (* `Permanent *)
| Non_existing_contract of Contract_repr.contract (* `Temporary *)
| Empty_implicit_contract of Signature.Public_key_hash.t (* `Temporary *)
| Empty_transaction of Contract_repr.t (* `Temporary *)
| Inconsistent_hash of Signature.Public_key.t * Signature.Public_key_hash.t * Signature.Public_key_hash.t (* `Permanent *)
| Inconsistent_public_key of Signature.Public_key.t * Signature.Public_key.t (* `Permanent *)
| Failure of string (* `Permanent *)
| Previously_revealed_key of Contract_repr.t (* `Permanent *)
| Unrevealed_manager_key of Contract_repr.t (* `Permanent *)
let () =
register_error_kind
`Permanent
~id:"contract.unspendable_contract"
~title:"Unspendable contract"
~description:"An operation tried to spend tokens from an unspendable contract"
~pp:(fun ppf c ->
Format.fprintf ppf "The tokens of contract %a can only be spent by its script"
Contract_repr.pp c)
Data_encoding.(obj1 (req "contract" Contract_repr.encoding))
(function Unspendable_contract c -> Some c | _ -> None)
(fun c -> Unspendable_contract c) ;
register_error_kind
`Temporary
~id:"contract.balance_too_low"
~title:"Balance too low"
~description:"An operation tried to spend more tokens than the contract has"
~pp:(fun ppf (c, b, a) ->
Format.fprintf ppf "Balance of contract %a too low (%a) to spend %a"
Contract_repr.pp c Tez_repr.pp b Tez_repr.pp a)
Data_encoding.(obj3
(req "contract" Contract_repr.encoding)
(req "balance" Tez_repr.encoding)
(req "amount" Tez_repr.encoding))
(function Balance_too_low (c, b, a) -> Some (c, b, a) | _ -> None)
(fun (c, b, a) -> Balance_too_low (c, b, a)) ;
register_error_kind
`Temporary
~id:"contract.counter_in_the_future"
~title:"Invalid counter (not yet reached) in a manager operation"
~description:"An operation assumed a contract counter in the future"
~pp:(fun ppf (contract, exp, found) ->
Format.fprintf ppf
"Counter %s not yet reached for contract %a (expected %s)"
(Z.to_string found)
Contract_repr.pp contract
(Z.to_string exp))
Data_encoding.
(obj3
(req "contract" Contract_repr.encoding)
(req "expected" z)
(req "found" z))
(function Counter_in_the_future (c, x, y) -> Some (c, x, y) | _ -> None)
(fun (c, x, y) -> Counter_in_the_future (c, x, y)) ;
register_error_kind
`Branch
~id:"contract.counter_in_the_past"
~title:"Invalid counter (already used) in a manager operation"
~description:"An operation assumed a contract counter in the past"
~pp:(fun ppf (contract, exp, found) ->
Format.fprintf ppf
"Counter %s already used for contract %a (expected %s)"
(Z.to_string found)
Contract_repr.pp contract
(Z.to_string exp))
Data_encoding.
(obj3
(req "contract" Contract_repr.encoding)
(req "expected" z)
(req "found" z))
(function Counter_in_the_past (c, x, y) -> Some (c, x, y) | _ -> None)
(fun (c, x, y) -> Counter_in_the_past (c, x, y)) ;
register_error_kind
`Temporary
~id:"contract.non_existing_contract"
~title:"Non existing contract"
~description:"A contract handle is not present in the context \
(either it never was or it has been destroyed)"
~pp:(fun ppf contract ->
Format.fprintf ppf "Contract %a does not exist"
Contract_repr.pp contract)
Data_encoding.(obj1 (req "contract" Contract_repr.encoding))
(function Non_existing_contract c -> Some c | _ -> None)
(fun c -> Non_existing_contract c) ;
register_error_kind
`Permanent
~id:"contract.manager.inconsistent_hash"
~title:"Inconsistent public key hash"
~description:"A revealed manager public key is inconsistent with the announced hash"
~pp:(fun ppf (k, eh, ph) ->
Format.fprintf ppf "The hash of the manager public key %s is not %a as announced but %a"
(Signature.Public_key.to_b58check k)
Signature.Public_key_hash.pp ph
Signature.Public_key_hash.pp eh)
Data_encoding.(obj3
(req "public_key" Signature.Public_key.encoding)
(req "expected_hash" Signature.Public_key_hash.encoding)
(req "provided_hash" Signature.Public_key_hash.encoding))
(function Inconsistent_hash (k, eh, ph) -> Some (k, eh, ph) | _ -> None)
(fun (k, eh, ph) -> Inconsistent_hash (k, eh, ph)) ;
register_error_kind
`Permanent
~id:"contract.manager.inconsistent_public_key"
~title:"Inconsistent public key"
~description:"A provided manager public key is different with the public key stored in the contract"
~pp:(fun ppf (eh, ph) ->
Format.fprintf ppf "Expected manager public key %s but %s was provided"
(Signature.Public_key.to_b58check ph)
(Signature.Public_key.to_b58check eh))
Data_encoding.(obj2
(req "public_key" Signature.Public_key.encoding)
(req "expected_public_key" Signature.Public_key.encoding))
(function Inconsistent_public_key (eh, ph) -> Some (eh, ph) | _ -> None)
(fun (eh, ph) -> Inconsistent_public_key (eh, ph)) ;
register_error_kind
`Permanent
~id:"contract.failure"
~title:"Contract storage failure"
~description:"Unexpected contract storage error"
~pp:(fun ppf s -> Format.fprintf ppf "Contract_storage.Failure %S" s)
Data_encoding.(obj1 (req "message" string))
(function Failure s -> Some s | _ -> None)
(fun s -> Failure s) ;
register_error_kind
`Branch
~id:"contract.unrevealed_key"
~title:"Manager operation precedes key revelation"
~description:
"One tried to apply a manager operation \
without revealing the manager public key"
~pp:(fun ppf s ->
Format.fprintf ppf "Unrevealed manager key for contract %a."
Contract_repr.pp s)
Data_encoding.(obj1 (req "contract" Contract_repr.encoding))
(function Unrevealed_manager_key s -> Some s | _ -> None)
(fun s -> Unrevealed_manager_key s) ;
register_error_kind
`Branch
~id:"contract.previously_revealed_key"
~title:"Manager operation already revealed"
~description:
"One tried to revealed twice a manager public key"
~pp:(fun ppf s ->
Format.fprintf ppf "Previously revealed manager key for contract %a."
Contract_repr.pp s)
Data_encoding.(obj1 (req "contract" Contract_repr.encoding))
(function Previously_revealed_key s -> Some s | _ -> None)
(fun s -> Previously_revealed_key s) ;
register_error_kind
`Branch
~id:"implicit.empty_implicit_contract"
~title:"Empty implicit contract"
~description:"No manager operations are allowed on an empty implicit contract."
~pp:(fun ppf implicit ->
Format.fprintf ppf
"Empty implicit contract (%a)"
Signature.Public_key_hash.pp implicit)
Data_encoding.(obj1 (req "implicit" Signature.Public_key_hash.encoding))
(function Empty_implicit_contract c -> Some c | _ -> None)
(fun c -> Empty_implicit_contract c) ;
register_error_kind
`Branch
~id:"contract.empty_transaction"
~title:"Empty transaction"
~description:"Forbidden to credit 0ꜩ to a contract without code."
~pp:(fun ppf contract ->
Format.fprintf ppf
"Transaction of 0ꜩ towards a contract without code are forbidden (%a)."
Contract_repr.pp contract)
Data_encoding.(obj1 (req "contract" Contract_repr.encoding))
(function Empty_transaction c -> Some c | _ -> None)
(fun c -> Empty_transaction c)
let failwith msg = fail (Failure msg)
type big_map_diff_item = {
diff_key : Script_repr.expr;
diff_key_hash : Script_expr_hash.t;
diff_value : Script_repr.expr option;
}
type big_map_diff = big_map_diff_item list
let big_map_diff_item_encoding =
let open Data_encoding in
conv
(fun { diff_key_hash ; diff_key ; diff_value } -> (diff_key_hash, diff_key, diff_value))
(fun (diff_key_hash, diff_key, diff_value) -> { diff_key_hash ; diff_key ; diff_value })
(obj3
(req "key_hash" Script_expr_hash.encoding)
(req "key" Script_repr.expr_encoding)
(opt "value" Script_repr.expr_encoding))
let big_map_diff_encoding =
let open Data_encoding in
def "contract.big_map_diff" @@
list big_map_diff_item_encoding
let update_script_big_map c contract = function
| None -> return (c, Z.zero)
| Some diff ->
fold_left_s (fun (c, total) diff_item ->
match diff_item.diff_value with
| None ->
Storage.Contract.Big_map.remove (c, contract) diff_item.diff_key_hash
>>=? fun (c, freed) ->
return (c, Z.sub total (Z.of_int freed))
| Some v ->
Storage.Contract.Big_map.init_set (c, contract) diff_item.diff_key_hash v
>>=? fun (c, size_diff) ->
return (c, Z.add total (Z.of_int size_diff)))
(c, Z.zero) diff
let create_base c
?(prepaid_bootstrap_storage=false) (* Free space for bootstrap contracts *)
contract
~balance ~manager ~delegate ?script ~spendable ~delegatable =
(match Contract_repr.is_implicit contract with
| None -> return Z.zero
| Some _ -> Storage.Contract.Global_counter.get c) >>=? fun counter ->
Storage.Contract.Balance.init c contract balance >>=? fun c ->
Storage.Contract.Manager.init c contract (Manager_repr.Hash manager) >>=? fun c ->
begin
match delegate with
| None -> return c
| Some delegate ->
Delegate_storage.init c contract delegate
end >>=? fun c ->
Storage.Contract.Spendable.set c contract spendable >>= fun c ->
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) ->
Storage.Contract.Code.init c contract code >>=? fun (c, code_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) ->
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) ;
let prepaid_bootstrap_storage =
if prepaid_bootstrap_storage then
total_size
else
Z.zero
in
Storage.Contract.Paid_storage_space.init c contract prepaid_bootstrap_storage >>=? fun c ->
Storage.Contract.Used_storage_space.init c contract total_size
| None -> begin
match Contract_repr.is_implicit contract with
| 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
let originate c ?prepaid_bootstrap_storage contract
~balance ~manager ?script ~delegate ~spendable ~delegatable =
create_base c ?prepaid_bootstrap_storage contract ~balance ~manager
~delegate ?script ~spendable ~delegatable
let create_implicit c manager ~balance =
create_base c (Contract_repr.implicit_contract manager)
~balance ~manager ?script:None ~delegate:None
~spendable:true ~delegatable:false
let delete c contract =
match Contract_repr.is_implicit contract with
| None ->
(* For non implicit contract Big_map should be cleared *)
failwith "Non implicit contracts cannot be removed"
| Some _ ->
Delegate_storage.remove c contract >>=? fun c ->
Storage.Contract.Balance.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.Code.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.Used_storage_space.remove c contract >>= fun c ->
return c
let allocated c contract =
Storage.Contract.Counter.get_option c contract >>=? function
| None -> return_false
| Some _ -> return_true
let exists c contract =
match Contract_repr.is_implicit contract with
| Some _ -> return_true
| None -> allocated c contract
let must_exist c contract =
exists c contract >>=? function
| true -> return_unit
| false -> fail (Non_existing_contract contract)
let must_be_allocated c contract =
allocated c contract >>=? function
| true -> return_unit
| false ->
match Contract_repr.is_implicit contract with
| Some pkh -> fail (Empty_implicit_contract pkh)
| None -> fail (Non_existing_contract contract)
let list c = Storage.Contract.list c
let fresh_contract_from_current_nonce c =
Lwt.return (Raw_context.increment_origination_nonce c) >>=? fun (c, nonce) ->
return (c, Contract_repr.originated_contract nonce)
let originated_from_current_nonce ~since: ctxt_since ~until: ctxt_until =
Lwt.return (Raw_context.origination_nonce ctxt_since) >>=? fun since ->
Lwt.return (Raw_context.origination_nonce ctxt_until) >>=? fun until ->
filter_map_s
(fun contract -> exists ctxt_until contract >>=? function
| true -> return_some contract
| false -> return_none)
(Contract_repr.originated_contracts ~since ~until)
let check_counter_increment c contract counter =
Storage.Contract.Counter.get c contract >>=? fun contract_counter ->
let expected = Z.succ contract_counter in
if Compare.Z.(expected = counter)
then return_unit
else if Compare.Z.(expected > counter) then
fail (Counter_in_the_past (contract, expected, counter))
else
fail (Counter_in_the_future (contract, expected, counter))
let increment_counter c contract =
Storage.Contract.Global_counter.get c >>=? fun global_counter ->
Storage.Contract.Global_counter.set c (Z.succ global_counter) >>=? fun c ->
Storage.Contract.Counter.get c contract >>=? fun contract_counter ->
Storage.Contract.Counter.set c contract (Z.succ contract_counter)
let get_script c contract =
Storage.Contract.Code.get_option c contract >>=? fun (c, code) ->
Storage.Contract.Storage.get_option c contract >>=? fun (c, storage) ->
match code, storage with
| None, None -> return (c, None)
| Some code, Some storage -> return (c, Some { Script_repr.code ; storage })
| None, Some _ | Some _, None -> failwith "get_script"
let get_storage ctxt contract =
Storage.Contract.Storage.get_option ctxt contract >>=? function
| (ctxt, None) -> return (ctxt, None)
| (ctxt, Some storage) ->
Lwt.return (Script_repr.force_decode storage) >>=? fun (storage, cost) ->
Lwt.return (Raw_context.consume_gas ctxt cost) >>=? fun ctxt ->
return (ctxt, Some storage)
let get_counter c contract =
Storage.Contract.Counter.get_option c contract >>=? function
| None -> begin
match Contract_repr.is_implicit contract with
| Some _ -> Storage.Contract.Global_counter.get c
| None -> failwith "get_counter"
end
| Some v -> return v
let get_manager c contract =
Storage.Contract.Manager.get_option c contract >>=? function
| None -> begin
match Contract_repr.is_implicit contract with
| Some manager -> return manager
| None -> failwith "get_manager"
end
| Some (Manager_repr.Hash v) -> return v
| Some (Manager_repr.Public_key v) -> return (Signature.Public_key.hash v)
let get_manager_key c contract =
Storage.Contract.Manager.get_option c contract >>=? function
| None -> failwith "get_manager_key"
| Some (Manager_repr.Hash _) -> fail (Unrevealed_manager_key contract)
| Some (Manager_repr.Public_key v) -> return v
let is_manager_key_revealed c contract =
Storage.Contract.Manager.get_option c contract >>=? function
| None -> return_false
| Some (Manager_repr.Hash _) -> return_false
| Some (Manager_repr.Public_key _) -> return_true
let reveal_manager_key c contract public_key =
Storage.Contract.Manager.get c contract >>=? function
| Public_key _ -> fail (Previously_revealed_key contract)
| Hash v ->
let actual_hash = Signature.Public_key.hash public_key in
if (Signature.Public_key_hash.equal actual_hash v) then
let v = (Manager_repr.Public_key public_key) in
Storage.Contract.Manager.set c contract v >>=? fun c ->
return c
else fail (Inconsistent_hash (public_key,v,actual_hash))
let get_balance c contract =
Storage.Contract.Balance.get_option c contract >>=? function
| None -> begin
match Contract_repr.is_implicit contract with
| Some _ -> return Tez_repr.zero
| None -> failwith "get_balance"
end
| 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 storage = Script_repr.lazy_expr storage in
update_script_big_map c contract big_map_diff >>=? fun (c, big_map_size_diff) ->
Storage.Contract.Storage.set c contract storage >>=? fun (c, size_diff) ->
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
Storage.Contract.Used_storage_space.set c contract new_size
let spend_from_script c contract amount =
Storage.Contract.Balance.get c contract >>=? fun balance ->
match Tez_repr.(balance -? amount) with
| Error _ ->
fail (Balance_too_low (contract, balance, amount))
| Ok new_balance ->
Storage.Contract.Balance.set c contract new_balance >>=? fun c ->
Roll_storage.Contract.remove_amount c contract amount >>=? fun c ->
if Tez_repr.(new_balance > Tez_repr.zero) then
return c
else match Contract_repr.is_implicit contract with
| None -> return c (* Never delete originated contracts *)
| Some pkh ->
Delegate_storage.get c contract >>=? function
| Some pkh' ->
(* Don't delete "delegate" contract *)
assert (Signature.Public_key_hash.equal pkh pkh') ;
return c
| None ->
(* Delete empty implicit contract *)
delete c contract
let credit c contract amount =
begin
if Tez_repr.(amount <> Tez_repr.zero) then
return c
else
Storage.Contract.Code.mem c contract >>=? fun (c, target_has_code) ->
fail_unless target_has_code (Empty_transaction contract) >>=? fun () ->
return c
end >>=? fun c ->
Storage.Contract.Balance.get_option c contract >>=? function
| None -> begin
match Contract_repr.is_implicit contract with
| None -> fail (Non_existing_contract contract)
| Some manager ->
create_implicit c manager ~balance:amount
end
| Some balance ->
Lwt.return Tez_repr.(amount +? balance) >>=? fun balance ->
Storage.Contract.Balance.set c contract balance >>=? fun c ->
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 =
Storage.Contract.Global_counter.init c Z.zero
let used_storage_space c contract =
Storage.Contract.Used_storage_space.get_option c contract >>=? function
| None -> return Z.zero
| Some fees -> return fees
let paid_storage_space c contract =
Storage.Contract.Paid_storage_space.get_option c contract >>=? function
| None -> return Z.zero
| Some paid_space -> return paid_space
let set_paid_storage_space_and_return_fees_to_pay c contract new_storage_space =
Storage.Contract.Paid_storage_space.get c contract >>=? fun already_paid_space ->
if Compare.Z.(already_paid_space >= new_storage_space) then
return (Z.zero, c)
else
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 ->
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

140
vendors/ligo-utils/tezos-protocol-alpha/contract_storage.mli vendored Normal file
View File

@ -0,0 +1,140 @@
(*****************************************************************************)
(* *)
(* 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. *)
(* *)
(*****************************************************************************)
type error +=
| Balance_too_low of Contract_repr.contract * Tez_repr.t * Tez_repr.t (* `Temporary *)
| Counter_in_the_past of Contract_repr.contract * Z.t * Z.t (* `Branch *)
| Counter_in_the_future of Contract_repr.contract * Z.t * Z.t (* `Temporary *)
| Unspendable_contract of Contract_repr.contract (* `Permanent *)
| Non_existing_contract of Contract_repr.contract (* `Temporary *)
| Empty_implicit_contract of Signature.Public_key_hash.t (* `Temporary *)
| Empty_transaction of Contract_repr.t (* `Temporary *)
| Inconsistent_hash of Signature.Public_key.t * Signature.Public_key_hash.t * Signature.Public_key_hash.t (* `Permanent *)
| Inconsistent_public_key of Signature.Public_key.t * Signature.Public_key.t (* `Permanent *)
| Failure of string (* `Permanent *)
| Previously_revealed_key of Contract_repr.t (* `Permanent *)
| Unrevealed_manager_key of Contract_repr.t (* `Permanent *)
val exists: Raw_context.t -> Contract_repr.t -> bool tzresult Lwt.t
val must_exist: Raw_context.t -> Contract_repr.t -> unit tzresult Lwt.t
val allocated: Raw_context.t -> Contract_repr.t -> bool tzresult Lwt.t
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 check_counter_increment:
Raw_context.t -> Contract_repr.t -> Z.t -> unit tzresult Lwt.t
val increment_counter:
Raw_context.t -> Contract_repr.t -> Raw_context.t tzresult Lwt.t
val is_delegatable:
Raw_context.t -> Contract_repr.t -> bool tzresult Lwt.t
val is_spendable: Raw_context.t -> Contract_repr.t -> bool tzresult Lwt.t
val get_manager:
Raw_context.t -> Contract_repr.t -> Signature.Public_key_hash.t tzresult Lwt.t
val get_manager_key:
Raw_context.t -> Contract_repr.t -> Signature.Public_key.t tzresult Lwt.t
val is_manager_key_revealed:
Raw_context.t -> Contract_repr.t -> bool tzresult Lwt.t
val reveal_manager_key:
Raw_context.t -> Contract_repr.t -> Signature.Public_key.t ->
Raw_context.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_script:
Raw_context.t -> Contract_repr.t -> (Raw_context.t * Script_repr.t option) tzresult Lwt.t
val get_storage:
Raw_context.t -> Contract_repr.t -> (Raw_context.t * Script_repr.expr option) tzresult Lwt.t
type big_map_diff_item = {
diff_key : Script_repr.expr;
diff_key_hash : Script_expr_hash.t;
diff_value : Script_repr.expr option;
}
type big_map_diff = big_map_diff_item list
val big_map_diff_encoding : big_map_diff Data_encoding.t
val update_script_storage:
Raw_context.t -> Contract_repr.t ->
Script_repr.expr -> big_map_diff option ->
Raw_context.t tzresult Lwt.t
val credit:
Raw_context.t -> Contract_repr.t -> Tez_repr.t ->
Raw_context.t tzresult Lwt.t
(** checks that the contract is spendable and decrease_balance *)
val spend:
Raw_context.t -> Contract_repr.t -> Tez_repr.t ->
Raw_context.t tzresult Lwt.t
(** decrease_balance even if the contract is not spendable *)
val spend_from_script:
Raw_context.t -> Contract_repr.t -> Tez_repr.t ->
Raw_context.t tzresult Lwt.t
val originate:
Raw_context.t ->
?prepaid_bootstrap_storage:bool ->
Contract_repr.t ->
balance:Tez_repr.t ->
manager:Signature.Public_key_hash.t ->
?script:(Script_repr.t * big_map_diff option) ->
delegate:Signature.Public_key_hash.t option ->
spendable:bool ->
delegatable:bool ->
Raw_context.t tzresult Lwt.t
val fresh_contract_from_current_nonce :
Raw_context.t -> (Raw_context.t * Contract_repr.t) tzresult Lwt.t
val originated_from_current_nonce :
since: Raw_context.t ->
until: Raw_context.t ->
Contract_repr.t list tzresult Lwt.t
val init:
Raw_context.t -> Raw_context.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 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

85
vendors/ligo-utils/tezos-protocol-alpha/cycle_repr.ml vendored Normal file
View File

@ -0,0 +1,85 @@
(*****************************************************************************)
(* *)
(* 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. *)
(* *)
(*****************************************************************************)
type t = int32
type cycle = t
let encoding = Data_encoding.int32
let rpc_arg =
let construct = Int32.to_string in
let destruct str =
match Int32.of_string str with
| exception _ -> Error "Cannot parse cycle"
| cycle -> Ok cycle in
RPC_arg.make
~descr:"A cycle integer"
~name: "block_cycle"
~construct
~destruct
()
let pp ppf cycle = Format.fprintf ppf "%ld" cycle
include (Compare.Int32 : Compare.S with type t := t)
module Map = Map.Make(Compare.Int32)
let root = 0l
let succ = Int32.succ
let pred = function
| 0l -> None
| i -> Some (Int32.pred i)
let add c i =
assert Compare.Int.(i > 0) ;
Int32.add c (Int32.of_int i)
let sub c i =
assert Compare.Int.(i > 0) ;
let r = Int32.sub c (Int32.of_int i) in
if Compare.Int32.(r < 0l) then None else Some r
let to_int32 i = i
let of_int32_exn l =
if Compare.Int32.(l >= 0l)
then l
else invalid_arg "Level_repr.Cycle.of_int32"
module Index = struct
type t = cycle
let path_length = 1
let to_path c l =
Int32.to_string (to_int32 c) :: l
let of_path = function
| [s] -> begin
try Some (Int32.of_string s)
with _ -> None
end
| _ -> None
let rpc_arg = rpc_arg
let encoding = encoding
let compare = compare
end

44
vendors/ligo-utils/tezos-protocol-alpha/cycle_repr.mli vendored Normal file
View File

@ -0,0 +1,44 @@
(*****************************************************************************)
(* *)
(* 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. *)
(* *)
(*****************************************************************************)
type t
type cycle = t
include Compare.S with type t := t
val encoding: cycle Data_encoding.t
val rpc_arg: cycle RPC_arg.arg
val pp: Format.formatter -> cycle -> unit
val root: cycle
val pred: cycle -> cycle option
val add: cycle -> int -> cycle
val sub: cycle -> int -> cycle option
val succ: cycle -> cycle
val to_int32: cycle -> int32
val of_int32_exn: int32 -> cycle
module Map : S.MAP with type key = cycle
module Index : Storage_description.INDEX with type t = cycle

553
vendors/ligo-utils/tezos-protocol-alpha/delegate_services.ml vendored Normal file
View File

@ -0,0 +1,553 @@
(*****************************************************************************)
(* *)
(* 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 Alpha_context
type 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_hash.t list ;
delegated_balance: Tez.t ;
deactivated: bool ;
grace_period: Cycle.t ;
}
let info_encoding =
let open Data_encoding in
conv
(fun { balance ; frozen_balance ; frozen_balance_by_cycle ;
staking_balance ; delegated_contracts ; delegated_balance ;
deactivated ; grace_period } ->
(balance, frozen_balance, frozen_balance_by_cycle,
staking_balance, delegated_contracts, delegated_balance,
deactivated, grace_period))
(fun (balance, frozen_balance, frozen_balance_by_cycle,
staking_balance, delegated_contracts, delegated_balance,
deactivated, grace_period) ->
{ balance ; frozen_balance ; frozen_balance_by_cycle ;
staking_balance ; delegated_contracts ; delegated_balance ;
deactivated ; grace_period })
(obj8
(req "balance" Tez.encoding)
(req "frozen_balance" Tez.encoding)
(req "frozen_balance_by_cycle" Delegate.frozen_balance_by_cycle_encoding)
(req "staking_balance" Tez.encoding)
(req "delegated_contracts" (list Contract_hash.encoding))
(req "delegated_balance" Tez.encoding)
(req "deactivated" bool)
(req "grace_period" Cycle.encoding))
module S = struct
let path = RPC_path.(open_root / "context" / "delegates")
open Data_encoding
type list_query = {
active: bool ;
inactive: bool ;
}
let list_query :list_query RPC_query.t =
let open RPC_query in
query (fun active inactive -> { active ; inactive })
|+ flag "active" (fun t -> t.active)
|+ flag "inactive" (fun t -> t.inactive)
|> seal
let list_delegate =
RPC_service.get_service
~description:
"Lists all registered delegates."
~query: list_query
~output: (list Signature.Public_key_hash.encoding)
path
let path = RPC_path.(path /: Signature.Public_key_hash.rpc_arg)
let info =
RPC_service.get_service
~description:
"Everything about a delegate."
~query: RPC_query.empty
~output: info_encoding
path
let balance =
RPC_service.get_service
~description:
"Returns the full balance of a given delegate, \
including the frozen balances."
~query: RPC_query.empty
~output: Tez.encoding
RPC_path.(path / "balance")
let frozen_balance =
RPC_service.get_service
~description:
"Returns the total frozen balances of a given delegate, \
this includes the frozen deposits, rewards and fees."
~query: RPC_query.empty
~output: Tez.encoding
RPC_path.(path / "frozen_balance")
let frozen_balance_by_cycle =
RPC_service.get_service
~description:
"Returns the frozen balances of a given delegate, \
indexed by the cycle by which it will be unfrozen"
~query: RPC_query.empty
~output: Delegate.frozen_balance_by_cycle_encoding
RPC_path.(path / "frozen_balance_by_cycle")
let staking_balance =
RPC_service.get_service
~description:
"Returns the total amount of tokens delegated to a given delegate. \
This includes the balances of all the contracts that delegate \
to it, but also the balance of the delegate itself and its frozen \
fees and deposits. The rewards do not count in the delegated balance \
until they are unfrozen."
~query: RPC_query.empty
~output: Tez.encoding
RPC_path.(path / "staking_balance")
let delegated_contracts =
RPC_service.get_service
~description:
"Returns the list of contracts that delegate to a given delegate."
~query: RPC_query.empty
~output: (list Contract_hash.encoding)
RPC_path.(path / "delegated_contracts")
let delegated_balance =
RPC_service.get_service
~description:
"Returns the balances of all the contracts that delegate to a \
given delegate. This excludes the delegate's own balance and \
its frozen balances."
~query: RPC_query.empty
~output: Tez.encoding
RPC_path.(path / "delegated_balance")
let deactivated =
RPC_service.get_service
~description:
"Tells whether the delegate is currently tagged as deactivated or not."
~query: RPC_query.empty
~output: bool
RPC_path.(path / "deactivated")
let grace_period =
RPC_service.get_service
~description:
"Returns the cycle by the end of which the delegate might be \
deactivated if she fails to execute any delegate action. \
A deactivated delegate might be reactivated \
(without loosing any rolls) by simply re-registering as a delegate. \
For deactivated delegates, this value contains the cycle by which \
they were deactivated."
~query: RPC_query.empty
~output: Cycle.encoding
RPC_path.(path / "grace_period")
end
let register () =
let open Services_registration in
register0 S.list_delegate begin fun ctxt q () ->
Delegate.list ctxt >>= fun delegates ->
if q.active && q.inactive then
return delegates
else if q.active then
filter_map_s
(fun pkh ->
Delegate.deactivated ctxt pkh >>=? function
| true -> return_none
| false -> return_some pkh)
delegates
else if q.inactive then
filter_map_s
(fun pkh ->
Delegate.deactivated ctxt pkh >>=? function
| false -> return_none
| true -> return_some pkh)
delegates
else
return_nil
end ;
register1 S.info begin fun ctxt pkh () () ->
Delegate.full_balance ctxt pkh >>=? fun balance ->
Delegate.frozen_balance ctxt pkh >>=? fun frozen_balance ->
Delegate.frozen_balance_by_cycle ctxt pkh >>= fun frozen_balance_by_cycle ->
Delegate.staking_balance ctxt pkh >>=? fun staking_balance ->
Delegate.delegated_contracts ctxt pkh >>= fun delegated_contracts ->
Delegate.delegated_balance ctxt pkh >>=? fun delegated_balance ->
Delegate.deactivated ctxt pkh >>=? fun deactivated ->
Delegate.grace_period ctxt pkh >>=? fun grace_period ->
return {
balance ; frozen_balance ; frozen_balance_by_cycle ;
staking_balance ; delegated_contracts ; delegated_balance ;
deactivated ; grace_period
}
end ;
register1 S.balance begin fun ctxt pkh () () ->
Delegate.full_balance ctxt pkh
end ;
register1 S.frozen_balance begin fun ctxt pkh () () ->
Delegate.frozen_balance ctxt pkh
end ;
register1 S.frozen_balance_by_cycle begin fun ctxt pkh () () ->
Delegate.frozen_balance_by_cycle ctxt pkh >>= return
end ;
register1 S.staking_balance begin fun ctxt pkh () () ->
Delegate.staking_balance ctxt pkh
end ;
register1 S.delegated_contracts begin fun ctxt pkh () () ->
Delegate.delegated_contracts ctxt pkh >>= return
end ;
register1 S.delegated_balance begin fun ctxt pkh () () ->
Delegate.delegated_balance ctxt pkh
end ;
register1 S.deactivated begin fun ctxt pkh () () ->
Delegate.deactivated ctxt pkh
end ;
register1 S.grace_period begin fun ctxt pkh () () ->
Delegate.grace_period ctxt pkh
end
let list ctxt block ?(active = true) ?(inactive = false) () =
RPC_context.make_call0 S.list_delegate ctxt block { active ; inactive } ()
let info ctxt block pkh =
RPC_context.make_call1 S.info ctxt block pkh () ()
let balance ctxt block pkh =
RPC_context.make_call1 S.balance ctxt block pkh () ()
let frozen_balance ctxt block pkh =
RPC_context.make_call1 S.frozen_balance ctxt block pkh () ()
let frozen_balance_by_cycle ctxt block pkh =
RPC_context.make_call1 S.frozen_balance_by_cycle ctxt block pkh () ()
let staking_balance ctxt block pkh =
RPC_context.make_call1 S.staking_balance ctxt block pkh () ()
let delegated_contracts ctxt block pkh =
RPC_context.make_call1 S.delegated_contracts ctxt block pkh () ()
let delegated_balance ctxt block pkh =
RPC_context.make_call1 S.delegated_balance ctxt block pkh () ()
let deactivated ctxt block pkh =
RPC_context.make_call1 S.deactivated ctxt block pkh () ()
let grace_period ctxt block pkh =
RPC_context.make_call1 S.grace_period ctxt block pkh () ()
let requested_levels ~default ctxt cycles levels =
match levels, cycles with
| [], [] ->
return [default]
| levels, cycles ->
(* explicitly fail when requested levels or cycle are in the past...
or too far in the future... *)
let levels =
List.sort_uniq
Level.compare
(List.concat (List.map (Level.from_raw ctxt) levels ::
List.map (Level.levels_in_cycle ctxt) cycles)) in
map_p
(fun level ->
let current_level = Level.current ctxt in
if Level.(level <= current_level) then
return (level, None)
else
Baking.earlier_predecessor_timestamp
ctxt level >>=? fun timestamp ->
return (level, Some timestamp))
levels
module Baking_rights = struct
type t = {
level: Raw_level.t ;
delegate: Signature.Public_key_hash.t ;
priority: int ;
timestamp: Timestamp.t option ;
}
let encoding =
let open Data_encoding in
conv
(fun { level ; delegate ; priority ; timestamp } ->
(level, delegate, priority, timestamp))
(fun (level, delegate, priority, timestamp) ->
{ level ; delegate ; priority ; timestamp })
(obj4
(req "level" Raw_level.encoding)
(req "delegate" Signature.Public_key_hash.encoding)
(req "priority" uint16)
(opt "estimated_time" Timestamp.encoding))
module S = struct
open Data_encoding
let custom_root =
RPC_path.(open_root / "helpers" / "baking_rights")
type baking_rights_query = {
levels: Raw_level.t list ;
cycles: Cycle.t list ;
delegates: Signature.Public_key_hash.t list ;
max_priority: int option ;
all: bool ;
}
let baking_rights_query =
let open RPC_query in
query (fun levels cycles delegates max_priority all ->
{ levels ; cycles ; delegates ; max_priority ; all })
|+ multi_field "level" Raw_level.rpc_arg (fun t -> t.levels)
|+ multi_field "cycle" Cycle.rpc_arg (fun t -> t.cycles)
|+ multi_field "delegate" Signature.Public_key_hash.rpc_arg (fun t -> t.delegates)
|+ opt_field "max_priority" RPC_arg.int (fun t -> t.max_priority)
|+ flag "all" (fun t -> t.all)
|> seal
let baking_rights =
RPC_service.get_service
~description:
"Retrieves the list of delegates allowed to bake a block.\n\
By default, it gives the best baking priorities for bakers \
that have at least one opportunity below the 64th priority \
for the next block.\n\
Parameters `level` and `cycle` can be used to specify the \
(valid) level(s) in the past or future at which the baking \
rights have to be returned. Parameter `delegate` can be \
used to restrict the results to the given delegates. If \
parameter `all` is set, all the baking opportunities for \
each baker at each level are returned, instead of just the \
first one.\n\
Returns the list of baking slots. Also returns the minimal \
timestamps that correspond to these slots. The timestamps \
are omitted for levels in the past, and are only estimates \
for levels later that the next block, based on the \
hypothesis that all predecessor blocks were baked at the \
first priority."
~query: baking_rights_query
~output: (list encoding)
custom_root
end
let baking_priorities ctxt max_prio (level, pred_timestamp) =
Baking.baking_priorities ctxt level >>=? fun contract_list ->
let rec loop l acc priority =
if Compare.Int.(priority >= max_prio) then
return (List.rev acc)
else
let Misc.LCons (pk, next) = l in
let delegate = Signature.Public_key.hash pk in
begin
match pred_timestamp with
| None -> return_none
| Some pred_timestamp ->
Baking.minimal_time ctxt priority pred_timestamp >>=? fun t ->
return_some t
end>>=? fun timestamp ->
let acc =
{ level = level.level ; delegate ; priority ; timestamp } :: acc in
next () >>=? fun l ->
loop l acc (priority+1) in
loop contract_list [] 0
let remove_duplicated_delegates rights =
List.rev @@ fst @@
List.fold_left
(fun (acc, previous) r ->
if Signature.Public_key_hash.Set.mem r.delegate previous then
(acc, previous)
else
(r :: acc,
Signature.Public_key_hash.Set.add r.delegate previous))
([], Signature.Public_key_hash.Set.empty)
rights
let register () =
let open Services_registration in
register0 S.baking_rights begin fun ctxt q () ->
requested_levels
~default:
(Level.succ ctxt (Level.current ctxt), Some (Timestamp.current ctxt))
ctxt q.cycles q.levels >>=? fun levels ->
let max_priority =
match q.max_priority with
| None -> 64
| Some max -> max in
map_p (baking_priorities ctxt max_priority) levels >>=? fun rights ->
let rights =
if q.all then
rights
else
List.map remove_duplicated_delegates rights in
let rights = List.concat rights in
match q.delegates with
| [] -> return rights
| _ :: _ as delegates ->
let is_requested p =
List.exists (Signature.Public_key_hash.equal p.delegate) delegates in
return (List.filter is_requested rights)
end
let get ctxt
?(levels = []) ?(cycles = []) ?(delegates = []) ?(all = false)
?max_priority block =
RPC_context.make_call0 S.baking_rights ctxt block
{ levels ; cycles ; delegates ; max_priority ; all }
()
end
module Endorsing_rights = struct
type t = {
level: Raw_level.t ;
delegate: Signature.Public_key_hash.t ;
slots: int list ;
estimated_time: Time.t option ;
}
let encoding =
let open Data_encoding in
conv
(fun { level ; delegate ; slots ; estimated_time } ->
(level, delegate, slots, estimated_time))
(fun (level, delegate, slots, estimated_time) ->
{ level ; delegate ; slots ; estimated_time })
(obj4
(req "level" Raw_level.encoding)
(req "delegate" Signature.Public_key_hash.encoding)
(req "slots" (list uint16))
(opt "estimated_time" Timestamp.encoding))
module S = struct
open Data_encoding
let custom_root =
RPC_path.(open_root / "helpers" / "endorsing_rights")
type endorsing_rights_query = {
levels: Raw_level.t list ;
cycles: Cycle.t list ;
delegates: Signature.Public_key_hash.t list ;
}
let endorsing_rights_query =
let open RPC_query in
query (fun levels cycles delegates ->
{ levels ; cycles ; delegates })
|+ multi_field "level" Raw_level.rpc_arg (fun t -> t.levels)
|+ multi_field "cycle" Cycle.rpc_arg (fun t -> t.cycles)
|+ multi_field "delegate" Signature.Public_key_hash.rpc_arg (fun t -> t.delegates)
|> seal
let endorsing_rights =
RPC_service.get_service
~description:
"Retrieves the delegates allowed to endorse a block.\n\
By default, it gives the endorsement slots for delegates that \
have at least one in the next block.\n\
Parameters `level` and `cycle` can be used to specify the \
(valid) level(s) in the past or future at which the \
endorsement rights have to be returned. Parameter \
`delegate` can be used to restrict the results to the given \
delegates.\n\
Returns the list of endorsement slots. Also returns the \
minimal timestamps that correspond to these slots. The \
timestamps are omitted for levels in the past, and are only \
estimates for levels later that the next block, based on \
the hypothesis that all predecessor blocks were baked at \
the first priority."
~query: endorsing_rights_query
~output: (list encoding)
custom_root
end
let endorsement_slots ctxt (level, estimated_time) =
Baking.endorsement_rights ctxt level >>=? fun rights ->
return
(Signature.Public_key_hash.Map.fold
(fun delegate (_, slots, _) acc -> {
level = level.level ; delegate ; slots ; estimated_time
} :: acc)
rights [])
let register () =
let open Services_registration in
register0 S.endorsing_rights begin fun ctxt q () ->
requested_levels
~default: (Level.current ctxt, Some (Timestamp.current ctxt))
ctxt q.cycles q.levels >>=? fun levels ->
map_p (endorsement_slots ctxt) levels >>=? fun rights ->
let rights = List.concat rights in
match q.delegates with
| [] -> return rights
| _ :: _ as delegates ->
let is_requested p =
List.exists (Signature.Public_key_hash.equal p.delegate) delegates in
return (List.filter is_requested rights)
end
let get ctxt
?(levels = []) ?(cycles = []) ?(delegates = []) block =
RPC_context.make_call0 S.endorsing_rights ctxt block
{ levels ; cycles ; delegates }
()
end
let register () =
register () ;
Baking_rights.register () ;
Endorsing_rights.register ()
let endorsement_rights ctxt level =
Endorsing_rights.endorsement_slots ctxt (level, None) >>=? fun l ->
return (List.map (fun { Endorsing_rights.delegate ; _ } -> delegate) l)
let baking_rights ctxt max_priority =
let max = match max_priority with None -> 64 | Some m -> m in
let level = Level.current ctxt in
Baking_rights.baking_priorities ctxt max (level, None) >>=? fun l ->
return (level.level,
List.map
(fun { Baking_rights.delegate ; timestamp ; _ } ->
(delegate, timestamp)) l)

176
vendors/ligo-utils/tezos-protocol-alpha/delegate_services.mli vendored Normal file
View File

@ -0,0 +1,176 @@
(*****************************************************************************)
(* *)
(* 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 Alpha_context
val list:
'a #RPC_context.simple -> 'a ->
?active:bool ->
?inactive:bool ->
unit -> Signature.Public_key_hash.t list shell_tzresult Lwt.t
type 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_hash.t list ;
delegated_balance: Tez.t ;
deactivated: bool ;
grace_period: Cycle.t ;
}
val info_encoding: info Data_encoding.t
val info:
'a #RPC_context.simple -> 'a ->
Signature.Public_key_hash.t ->
info shell_tzresult Lwt.t
val balance:
'a #RPC_context.simple -> 'a ->
Signature.Public_key_hash.t ->
Tez.t shell_tzresult Lwt.t
val frozen_balance:
'a #RPC_context.simple -> 'a ->
Signature.Public_key_hash.t ->
Tez.t shell_tzresult Lwt.t
val frozen_balance_by_cycle:
'a #RPC_context.simple -> 'a ->
Signature.Public_key_hash.t ->
Delegate.frozen_balance Cycle.Map.t shell_tzresult Lwt.t
val staking_balance:
'a #RPC_context.simple -> 'a ->
Signature.Public_key_hash.t ->
Tez.t shell_tzresult Lwt.t
val delegated_contracts:
'a #RPC_context.simple -> 'a ->
Signature.Public_key_hash.t ->
Contract_hash.t list shell_tzresult Lwt.t
val delegated_balance:
'a #RPC_context.simple -> 'a ->
Signature.Public_key_hash.t ->
Tez.t shell_tzresult Lwt.t
val deactivated:
'a #RPC_context.simple -> 'a ->
Signature.Public_key_hash.t ->
bool shell_tzresult Lwt.t
val grace_period:
'a #RPC_context.simple -> 'a ->
Signature.Public_key_hash.t ->
Cycle.t shell_tzresult Lwt.t
module Baking_rights : sig
type t = {
level: Raw_level.t ;
delegate: Signature.Public_key_hash.t ;
priority: int ;
timestamp: Timestamp.t option ;
}
(** Retrieves the list of delegates allowed to bake a block.
By default, it gives the best baking priorities for bakers
that have at least one opportunity below the 64th priority for
the next block.
Parameters [levels] and [cycles] can be used to specify the
(valid) level(s) in the past or future at which the baking rights
have to be returned. Parameter [delegates] can be used to
restrict the results to the given delegates. If parameter [all]
is [true], all the baking opportunities for each baker at each level
are returned, instead of just the first one.
Returns the list of baking slots. Also returns the minimal
timestamps that correspond to these slots. The timestamps are
omitted for levels in the past, and are only estimates for levels
later that the next block, based on the hypothesis that all
predecessor blocks were baked at the first priority. *)
val get:
'a #RPC_context.simple ->
?levels: Raw_level.t list ->
?cycles: Cycle.t list ->
?delegates: Signature.public_key_hash list ->
?all: bool ->
?max_priority: int ->
'a -> t list shell_tzresult Lwt.t
end
module Endorsing_rights : sig
type t = {
level: Raw_level.t ;
delegate: Signature.Public_key_hash.t ;
slots: int list ;
estimated_time: Timestamp.t option ;
}
(** Retrieves the delegates allowed to endorse a block.
By default, it gives the endorsement slots for bakers that have
at least one in the next block.
Parameters [levels] and [cycles] can be used to specify the
(valid) level(s) in the past or future at which the endorsement
rights have to be returned. Parameter [delegates] can be used to
restrict the results to the given delegates. Returns the list of
endorsement slots. Also returns the minimal timestamps that
correspond to these slots.
Timestamps are omitted for levels in the past, and are only
estimates for levels later that the next block, based on the
hypothesis that all predecessor blocks were baked at the first
priority. *)
val get:
'a #RPC_context.simple ->
?levels: Raw_level.t list ->
?cycles: Cycle.t list ->
?delegates: Signature.public_key_hash list ->
'a -> t list shell_tzresult Lwt.t
end
(* temporary export for deprecated unit test *)
val endorsement_rights:
Alpha_context.t ->
Level.t ->
public_key_hash list tzresult Lwt.t
val baking_rights:
Alpha_context.t ->
int option ->
(Raw_level.t * (public_key_hash * Time.t option) list) tzresult Lwt.t
val register: unit -> unit

626
vendors/ligo-utils/tezos-protocol-alpha/delegate_storage.ml vendored Normal file
View File

@ -0,0 +1,626 @@
(*****************************************************************************)
(* *)
(* 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. *)
(* *)
(*****************************************************************************)
type balance =
| Contract of Contract_repr.t
| Rewards of Signature.Public_key_hash.t * Cycle_repr.t
| Fees of Signature.Public_key_hash.t * Cycle_repr.t
| Deposits of Signature.Public_key_hash.t * Cycle_repr.t
let balance_encoding =
let open Data_encoding in
def "operation_metadata.alpha.balance" @@
union
[ case (Tag 0)
~title:"Contract"
(obj2
(req "kind" (constant "contract"))
(req "contract" Contract_repr.encoding))
(function Contract c -> Some ((), c) | _ -> None )
(fun ((), c) -> (Contract c)) ;
case (Tag 1)
~title:"Rewards"
(obj4
(req "kind" (constant "freezer"))
(req "category" (constant "rewards"))
(req "delegate" Signature.Public_key_hash.encoding)
(req "cycle" Cycle_repr.encoding))
(function Rewards (d, l) -> Some ((), (), d, l) | _ -> None)
(fun ((), (), d, l) -> Rewards (d, l)) ;
case (Tag 2)
~title:"Fees"
(obj4
(req "kind" (constant "freezer"))
(req "category" (constant "fees"))
(req "delegate" Signature.Public_key_hash.encoding)
(req "cycle" Cycle_repr.encoding))
(function Fees (d, l) -> Some ((), (), d, l) | _ -> None)
(fun ((), (), d, l) -> Fees (d, l)) ;
case (Tag 3)
~title:"Deposits"
(obj4
(req "kind" (constant "freezer"))
(req "category" (constant "deposits"))
(req "delegate" Signature.Public_key_hash.encoding)
(req "cycle" Cycle_repr.encoding))
(function Deposits (d, l) -> Some ((), (), d, l) | _ -> None)
(fun ((), (), d, l) -> Deposits (d, l)) ]
type balance_update =
| Debited of Tez_repr.t
| Credited of Tez_repr.t
let balance_update_encoding =
let open Data_encoding in
def "operation_metadata.alpha.balance_update" @@
obj1
(req "change"
(conv
(function
| Credited v -> Tez_repr.to_mutez v
| Debited v -> Int64.neg (Tez_repr.to_mutez v))
(Json.wrap_error @@
fun v ->
if Compare.Int64.(v < 0L) then
match Tez_repr.of_mutez (Int64.neg v) with
| Some v -> Debited v
| None -> failwith "Qty.of_mutez"
else
match Tez_repr.of_mutez v with
| Some v -> Credited v
| None -> failwith "Qty.of_mutez")
int64))
type balance_updates = (balance * balance_update) list
let balance_updates_encoding =
let open Data_encoding in
def "operation_metadata.alpha.balance_updates" @@
list (merge_objs balance_encoding balance_update_encoding)
let cleanup_balance_updates balance_updates =
List.filter
(fun (_, (Credited update | Debited update)) ->
not (Tez_repr.equal update Tez_repr.zero))
balance_updates
type frozen_balance = {
deposit : Tez_repr.t ;
fees : Tez_repr.t ;
rewards : Tez_repr.t ;
}
let frozen_balance_encoding =
let open Data_encoding in
conv
(fun { deposit ; fees ; rewards } -> (deposit, fees, rewards))
(fun (deposit, fees, rewards) -> { deposit ; fees ; rewards })
(obj3
(req "deposit" Tez_repr.encoding)
(req "fees" Tez_repr.encoding)
(req "rewards" Tez_repr.encoding))
type error +=
| Non_delegatable_contract of Contract_repr.contract (* `Permanent *)
| No_deletion of Signature.Public_key_hash.t (* `Permanent *)
| Active_delegate (* `Temporary *)
| Current_delegate (* `Temporary *)
| Empty_delegate_account of Signature.Public_key_hash.t (* `Temporary *)
| Balance_too_low_for_deposit of
{ delegate : Signature.Public_key_hash.t ;
deposit : Tez_repr.t ;
balance : Tez_repr.t } (* `Temporary *)
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
`Permanent
~id:"delegate.no_deletion"
~title:"Forbidden delegate deletion"
~description:"Tried to unregister a delegate"
~pp:(fun ppf delegate ->
Format.fprintf ppf "Delegate deletion is forbidden (%a)"
Signature.Public_key_hash.pp delegate)
Data_encoding.(obj1 (req "delegate" Signature.Public_key_hash.encoding))
(function No_deletion c -> Some c | _ -> None)
(fun c -> No_deletion c) ;
register_error_kind
`Temporary
~id:"delegate.already_active"
~title:"Delegate already active"
~description:"Useless delegate reactivation"
~pp:(fun ppf () ->
Format.fprintf ppf
"The delegate is still active, no need to refresh it")
Data_encoding.empty
(function Active_delegate -> Some () | _ -> None)
(fun () -> Active_delegate) ;
register_error_kind
`Temporary
~id:"delegate.unchanged"
~title:"Unchanged delegated"
~description:"Contract already delegated to the given delegate"
~pp:(fun ppf () ->
Format.fprintf ppf
"The contract is already delegated to the same delegate")
Data_encoding.empty
(function Current_delegate -> Some () | _ -> None)
(fun () -> Current_delegate) ;
register_error_kind
`Permanent
~id:"delegate.empty_delegate_account"
~title:"Empty delegate account"
~description:"Cannot register a delegate when its implicit account is empty"
~pp:(fun ppf delegate ->
Format.fprintf ppf
"Delegate registration is forbidden when the delegate
implicit account is empty (%a)"
Signature.Public_key_hash.pp delegate)
Data_encoding.(obj1 (req "delegate" Signature.Public_key_hash.encoding))
(function Empty_delegate_account c -> Some c | _ -> None)
(fun c -> Empty_delegate_account c) ;
register_error_kind
`Temporary
~id:"delegate.balance_too_low_for_deposit"
~title:"Balance too low for deposit"
~description:"Cannot freeze deposit when the balance is too low"
~pp:(fun ppf (delegate, balance, deposit) ->
Format.fprintf ppf
"Delegate %a has a too low balance (%a) to deposit %a"
Signature.Public_key_hash.pp delegate
Tez_repr.pp balance
Tez_repr.pp deposit)
Data_encoding.
(obj3
(req "delegate" Signature.Public_key_hash.encoding)
(req "balance" Tez_repr.encoding)
(req "deposit" Tez_repr.encoding))
(function Balance_too_low_for_deposit { delegate ; balance ; deposit } ->
Some (delegate, balance, deposit) | _ -> None)
(fun (delegate, balance, deposit) -> Balance_too_low_for_deposit { delegate ; balance ; deposit } )
let is_delegatable c contract =
match Contract_repr.is_implicit contract with
| 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 ->
match Contract_repr.is_originated contract with
| None -> return c
| Some h ->
Storage.Contract.Delegated.add
(c, Contract_repr.implicit_contract delegate) h >>= fun c ->
return c
let unlink c contract balance =
Storage.Contract.Delegate.get_option c contract >>=? function
| None -> return c
| Some delegate ->
Roll_storage.Delegate.remove_amount c delegate balance >>=? fun c ->
match Contract_repr.is_originated contract with
| None -> return c
| Some h ->
Storage.Contract.Delegated.del
(c, Contract_repr.implicit_contract delegate) h >>= fun c ->
return c
let known c delegate =
Storage.Contract.Manager.get_option
c (Contract_repr.implicit_contract delegate) >>=? function
| None | Some (Manager_repr.Hash _) -> return_false
| Some (Manager_repr.Public_key _) -> return_true
(* A delegate is registered if its "implicit account"
delegates to itself. *)
let registered c delegate =
Storage.Contract.Delegate.mem
c (Contract_repr.implicit_contract delegate)
let init ctxt contract delegate =
known ctxt delegate >>=? fun known_delegate ->
fail_unless
known_delegate
(Roll_storage.Unregistered_delegate delegate) >>=? fun () ->
registered ctxt delegate >>= fun is_registered ->
fail_unless
is_registered
(Roll_storage.Unregistered_delegate delegate) >>=? fun () ->
Storage.Contract.Delegate.init ctxt contract delegate >>=? fun ctxt ->
Storage.Contract.Balance.get ctxt contract >>=? fun balance ->
link ctxt contract delegate balance
let get = Roll_storage.get_contract_delegate
let set_base c is_delegatable contract delegate =
match delegate with
| None -> begin
match Contract_repr.is_implicit contract with
| Some 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
fail (Non_delegatable_contract contract)
end
| Some delegate ->
known c delegate >>=? fun known_delegate ->
registered c delegate >>= fun registered_delegate ->
is_delegatable c contract >>=? fun delegatable ->
let self_delegation =
match Contract_repr.is_implicit contract with
| Some pkh -> Signature.Public_key_hash.equal pkh delegate
| None -> false in
if not known_delegate || not (registered_delegate || self_delegation) then
fail (Roll_storage.Unregistered_delegate delegate)
else if not (delegatable || self_delegation) then
fail (Non_delegatable_contract contract)
else
begin
Storage.Contract.Delegate.get_option c contract >>=? function
| Some current_delegate
when Signature.Public_key_hash.equal delegate current_delegate ->
if self_delegation then
Roll_storage.Delegate.is_inactive c delegate >>=? function
| true -> return_unit
| false -> fail Active_delegate
else
fail Current_delegate
| None | Some _ -> return_unit
end >>=? fun () ->
Storage.Contract.Balance.mem c contract >>= fun exists ->
fail_when
(self_delegation && not exists)
(Empty_delegate_account delegate) >>=? fun () ->
Storage.Contract.Balance.get c contract >>=? fun balance ->
unlink c contract balance >>=? fun c ->
Storage.Contract.Delegate.init_set c contract delegate >>= fun c ->
link c contract delegate balance >>=? fun c ->
begin
if self_delegation then
Storage.Delegates.add c delegate >>= fun c ->
Roll_storage.Delegate.set_active c delegate >>=? fun c ->
return c
else
return c
end >>=? fun 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 =
Storage.Contract.Balance.get ctxt contract >>=? fun balance ->
unlink ctxt contract balance
let delegated_contracts ctxt delegate =
let contract = Contract_repr.implicit_contract delegate in
Storage.Contract.Delegated.elements (ctxt, contract)
let get_frozen_deposit ctxt contract cycle =
Storage.Contract.Frozen_deposits.get_option (ctxt, contract) cycle >>=? function
| None -> return Tez_repr.zero
| Some frozen -> return frozen
let credit_frozen_deposit ctxt delegate cycle amount =
let contract = Contract_repr.implicit_contract delegate in
get_frozen_deposit ctxt contract cycle >>=? fun old_amount ->
Lwt.return Tez_repr.(old_amount +? amount) >>=? fun new_amount ->
Storage.Contract.Frozen_deposits.init_set
(ctxt, contract) cycle new_amount >>= fun ctxt ->
Storage.Delegates_with_frozen_balance.add (ctxt, cycle) delegate >>= fun ctxt ->
return ctxt
let freeze_deposit ctxt delegate amount =
let { Level_repr.cycle ; _ } = Level_storage.current ctxt in
Roll_storage.Delegate.set_active ctxt delegate >>=? fun ctxt ->
let contract = Contract_repr.implicit_contract delegate in
Storage.Contract.Balance.get ctxt contract >>=? fun balance ->
Lwt.return
(record_trace (Balance_too_low_for_deposit { delegate; deposit = amount; balance })
Tez_repr.(balance -? amount)) >>=? fun new_balance ->
Storage.Contract.Balance.set ctxt contract new_balance >>=? fun ctxt ->
credit_frozen_deposit ctxt delegate cycle amount
let get_frozen_fees ctxt contract cycle =
Storage.Contract.Frozen_fees.get_option (ctxt, contract) cycle >>=? function
| None -> return Tez_repr.zero
| Some frozen -> return frozen
let credit_frozen_fees ctxt delegate cycle amount =
let contract = Contract_repr.implicit_contract delegate in
get_frozen_fees ctxt contract cycle >>=? fun old_amount ->
Lwt.return Tez_repr.(old_amount +? amount) >>=? fun new_amount ->
Storage.Contract.Frozen_fees.init_set
(ctxt, contract) cycle new_amount >>= fun ctxt ->
Storage.Delegates_with_frozen_balance.add (ctxt, cycle) delegate >>= fun ctxt ->
return ctxt
let freeze_fees ctxt delegate amount =
let { Level_repr.cycle ; _ } = Level_storage.current ctxt in
Roll_storage.Delegate.add_amount ctxt delegate amount >>=? fun ctxt ->
credit_frozen_fees ctxt delegate cycle amount
let burn_fees ctxt delegate cycle amount =
let contract = Contract_repr.implicit_contract delegate in
get_frozen_fees ctxt contract cycle >>=? fun old_amount ->
begin
match Tez_repr.(old_amount -? amount) with
| Ok new_amount ->
Roll_storage.Delegate.remove_amount
ctxt delegate amount >>=? fun ctxt ->
return (new_amount, ctxt)
| Error _ ->
Roll_storage.Delegate.remove_amount
ctxt delegate old_amount >>=? fun ctxt ->
return (Tez_repr.zero, ctxt)
end >>=? fun (new_amount, ctxt) ->
Storage.Contract.Frozen_fees.init_set (ctxt, contract) cycle new_amount >>= fun ctxt ->
return ctxt
let get_frozen_rewards ctxt contract cycle =
Storage.Contract.Frozen_rewards.get_option (ctxt, contract) cycle >>=? function
| None -> return Tez_repr.zero
| Some frozen -> return frozen
let credit_frozen_rewards ctxt delegate cycle amount =
let contract = Contract_repr.implicit_contract delegate in
get_frozen_rewards ctxt contract cycle >>=? fun old_amount ->
Lwt.return Tez_repr.(old_amount +? amount) >>=? fun new_amount ->
Storage.Contract.Frozen_rewards.init_set
(ctxt, contract) cycle new_amount >>= fun ctxt ->
Storage.Delegates_with_frozen_balance.add (ctxt, cycle) delegate >>= fun ctxt ->
return ctxt
let freeze_rewards ctxt delegate amount =
let { Level_repr.cycle ; _ } = Level_storage.current ctxt in
credit_frozen_rewards ctxt delegate cycle amount
let burn_rewards ctxt delegate cycle amount =
let contract = Contract_repr.implicit_contract delegate in
get_frozen_rewards ctxt contract cycle >>=? fun old_amount ->
let new_amount =
match Tez_repr.(old_amount -? amount) with
| Error _ -> Tez_repr.zero
| Ok new_amount -> new_amount in
Storage.Contract.Frozen_rewards.init_set (ctxt, contract) cycle new_amount >>= fun ctxt ->
return ctxt
let unfreeze ctxt delegate cycle =
let contract = Contract_repr.implicit_contract delegate in
get_frozen_deposit ctxt contract cycle >>=? fun deposit ->
get_frozen_fees ctxt contract cycle >>=? fun fees ->
get_frozen_rewards ctxt contract cycle >>=? fun rewards ->
Storage.Contract.Balance.get ctxt contract >>=? fun balance ->
Lwt.return Tez_repr.(deposit +? fees) >>=? fun unfrozen_amount ->
Lwt.return Tez_repr.(unfrozen_amount +? rewards) >>=? fun unfrozen_amount ->
Lwt.return Tez_repr.(balance +? unfrozen_amount) >>=? fun balance ->
Storage.Contract.Balance.set ctxt contract balance >>=? fun ctxt ->
Roll_storage.Delegate.add_amount ctxt delegate rewards >>=? fun ctxt ->
Storage.Contract.Frozen_deposits.remove (ctxt, contract) cycle >>= fun ctxt ->
Storage.Contract.Frozen_fees.remove (ctxt, contract) cycle >>= fun ctxt ->
Storage.Contract.Frozen_rewards.remove (ctxt, contract) cycle >>= fun ctxt ->
return (ctxt, (cleanup_balance_updates
[(Deposits (delegate, cycle), Debited deposit) ;
(Fees (delegate, cycle), Debited fees) ;
(Rewards (delegate, cycle), Debited rewards) ;
(Contract (Contract_repr.implicit_contract delegate), Credited unfrozen_amount)]))
let cycle_end ctxt last_cycle unrevealed =
let preserved = Constants_storage.preserved_cycles ctxt in
begin
match Cycle_repr.pred last_cycle with
| None -> return (ctxt,[])
| Some revealed_cycle ->
List.fold_left
(fun acc (u : Nonce_storage.unrevealed) ->
acc >>=? fun (ctxt, balance_updates) ->
burn_fees
ctxt u.delegate revealed_cycle u.fees >>=? fun ctxt ->
burn_rewards
ctxt u.delegate revealed_cycle u.rewards >>=? fun ctxt ->
let bus = [(Fees (u.delegate, revealed_cycle), Debited u.fees);
(Rewards (u.delegate, revealed_cycle), Debited u.rewards)] in
return (ctxt, bus @ balance_updates))
(return (ctxt,[])) unrevealed
end >>=? fun (ctxt, balance_updates) ->
match Cycle_repr.sub last_cycle preserved with
| None -> return (ctxt, balance_updates, [])
| Some unfrozen_cycle ->
Storage.Delegates_with_frozen_balance.fold (ctxt, unfrozen_cycle)
~init:(Ok (ctxt, balance_updates))
~f:(fun delegate acc ->
Lwt.return acc >>=? fun (ctxt, bus) ->
unfreeze ctxt
delegate unfrozen_cycle >>=? fun (ctxt, balance_updates) ->
return (ctxt, balance_updates @ bus)) >>=? fun (ctxt, balance_updates) ->
Storage.Delegates_with_frozen_balance.clear (ctxt, unfrozen_cycle) >>= fun ctxt ->
Storage.Active_delegates_with_rolls.fold ctxt
~init:(Ok (ctxt, []))
~f:(fun delegate acc ->
Lwt.return acc >>=? fun (ctxt, deactivated) ->
Storage.Contract.Delegate_desactivation.get ctxt
(Contract_repr.implicit_contract delegate) >>=? fun cycle ->
if Cycle_repr.(cycle <= last_cycle) then
Roll_storage.Delegate.set_inactive ctxt delegate >>=? fun ctxt ->
return (ctxt, delegate :: deactivated)
else
return (ctxt, deactivated)) >>=? fun (ctxt, deactivated) ->
return (ctxt, balance_updates, deactivated)
let punish ctxt delegate cycle =
let contract = Contract_repr.implicit_contract delegate in
get_frozen_deposit ctxt contract cycle >>=? fun deposit ->
get_frozen_fees ctxt contract cycle >>=? fun fees ->
get_frozen_rewards ctxt contract cycle >>=? fun rewards ->
Roll_storage.Delegate.remove_amount ctxt delegate deposit >>=? fun ctxt ->
Roll_storage.Delegate.remove_amount ctxt delegate fees >>=? fun ctxt ->
(* Rewards are not accounted in the delegate's rolls yet... *)
Storage.Contract.Frozen_deposits.remove (ctxt, contract) cycle >>= fun ctxt ->
Storage.Contract.Frozen_fees.remove (ctxt, contract) cycle >>= fun ctxt ->
Storage.Contract.Frozen_rewards.remove (ctxt, contract) cycle >>= fun ctxt ->
return (ctxt, { deposit ; fees ; rewards })
let has_frozen_balance ctxt delegate cycle =
let contract = Contract_repr.implicit_contract delegate in
get_frozen_deposit ctxt contract cycle >>=? fun deposit ->
if Tez_repr.(deposit <> zero) then return_true
else
get_frozen_fees ctxt contract cycle >>=? fun fees ->
if Tez_repr.(fees <> zero) then return_true
else
get_frozen_rewards ctxt contract cycle >>=? fun rewards ->
return Tez_repr.(rewards <> zero)
let frozen_balance_by_cycle_encoding =
let open Data_encoding in
conv
(Cycle_repr.Map.bindings)
(List.fold_left
(fun m (c, b) -> Cycle_repr.Map.add c b m)
Cycle_repr.Map.empty)
(list (merge_objs
(obj1 (req "cycle" Cycle_repr.encoding))
frozen_balance_encoding))
let empty_frozen_balance =
{ deposit = Tez_repr.zero ;
fees = Tez_repr.zero ;
rewards = Tez_repr.zero }
let frozen_balance_by_cycle ctxt delegate =
let contract = Contract_repr.implicit_contract delegate in
let map = Cycle_repr.Map.empty in
Storage.Contract.Frozen_deposits.fold
(ctxt, contract) ~init:map
~f:(fun cycle amount map ->
Lwt.return
(Cycle_repr.Map.add cycle
{ empty_frozen_balance with deposit = amount } map)) >>= fun map ->
Storage.Contract.Frozen_fees.fold
(ctxt, contract) ~init:map
~f:(fun cycle amount map ->
let balance =
match Cycle_repr.Map.find_opt cycle map with
| None -> empty_frozen_balance
| Some balance -> balance in
Lwt.return
(Cycle_repr.Map.add cycle
{ balance with fees = amount } map)) >>= fun map ->
Storage.Contract.Frozen_rewards.fold
(ctxt, contract) ~init:map
~f:(fun cycle amount map ->
let balance =
match Cycle_repr.Map.find_opt cycle map with
| None -> empty_frozen_balance
| Some balance -> balance in
Lwt.return
(Cycle_repr.Map.add cycle
{ balance with rewards = amount } map)) >>= fun map ->
Lwt.return map
let frozen_balance ctxt delegate =
let contract = Contract_repr.implicit_contract delegate in
let balance = Ok Tez_repr.zero in
Storage.Contract.Frozen_deposits.fold
(ctxt, contract) ~init:balance
~f:(fun _cycle amount acc ->
Lwt.return acc >>=? fun acc ->
Lwt.return (Tez_repr.(acc +? amount))) >>= fun balance ->
Storage.Contract.Frozen_fees.fold
(ctxt, contract) ~init:balance
~f:(fun _cycle amount acc ->
Lwt.return acc >>=? fun acc ->
Lwt.return (Tez_repr.(acc +? amount))) >>= fun balance ->
Storage.Contract.Frozen_rewards.fold
(ctxt, contract) ~init:balance
~f:(fun _cycle amount acc ->
Lwt.return acc >>=? fun acc ->
Lwt.return (Tez_repr.(acc +? amount))) >>= fun balance ->
Lwt.return balance
let full_balance ctxt delegate =
let contract = Contract_repr.implicit_contract delegate in
frozen_balance ctxt delegate >>=? fun frozen_balance ->
Storage.Contract.Balance.get ctxt contract >>=? fun balance ->
Lwt.return Tez_repr.(frozen_balance +? balance)
let deactivated = Roll_storage.Delegate.is_inactive
let grace_period ctxt delegate =
let contract = Contract_repr.implicit_contract delegate in
Storage.Contract.Delegate_desactivation.get ctxt contract
let staking_balance ctxt delegate =
let token_per_rolls = Constants_storage.tokens_per_roll ctxt in
Roll_storage.get_rolls ctxt delegate >>=? fun rolls ->
Roll_storage.get_change ctxt delegate >>=? fun change ->
let rolls = Int64.of_int (List.length rolls) in
Lwt.return Tez_repr.(token_per_rolls *? rolls) >>=? fun balance ->
Lwt.return Tez_repr.(balance +? change)
let delegated_balance ctxt delegate =
let contract = Contract_repr.implicit_contract delegate in
staking_balance ctxt delegate >>=? fun staking_balance ->
Storage.Contract.Balance.get ctxt contract >>= fun self_staking_balance ->
Storage.Contract.Frozen_deposits.fold
(ctxt, contract) ~init:self_staking_balance
~f:(fun _cycle amount acc ->
Lwt.return acc >>=? fun acc ->
Lwt.return (Tez_repr.(acc +? amount))) >>= fun self_staking_balance ->
Storage.Contract.Frozen_fees.fold
(ctxt, contract) ~init:self_staking_balance
~f:(fun _cycle amount acc ->
Lwt.return acc >>=? fun acc ->
Lwt.return (Tez_repr.(acc +? amount))) >>=? fun self_staking_balance ->
Lwt.return Tez_repr.(staking_balance -? self_staking_balance)
let fold = Storage.Delegates.fold
let list = Storage.Delegates.elements

187
vendors/ligo-utils/tezos-protocol-alpha/delegate_storage.mli vendored Normal file
View File

@ -0,0 +1,187 @@
(*****************************************************************************)
(* *)
(* 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. *)
(* *)
(*****************************************************************************)
(** Places where tezzies can be found in the ledger's state. *)
type balance =
| Contract of Contract_repr.t
| Rewards of Signature.Public_key_hash.t * Cycle_repr.t
| Fees of Signature.Public_key_hash.t * Cycle_repr.t
| Deposits of Signature.Public_key_hash.t * Cycle_repr.t
(** A credit or debit of tezzies to a balance. *)
type balance_update =
| Debited of Tez_repr.t
| Credited of Tez_repr.t
(** A list of balance updates. Duplicates may happen. *)
type balance_updates = (balance * balance_update) list
val balance_updates_encoding : balance_updates Data_encoding.t
(** Remove zero-valued balances from a list of updates. *)
val cleanup_balance_updates : balance_updates -> balance_updates
type frozen_balance = {
deposit : Tez_repr.t ;
fees : 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. *)
val init:
Raw_context.t -> Contract_repr.t -> Signature.Public_key_hash.t ->
Raw_context.t tzresult Lwt.t
(** Cleanup delegation when deleting a contract. *)
val remove:
Raw_context.t -> Contract_repr.t -> Raw_context.t tzresult Lwt.t
(** Reading the current delegate of a contract. *)
val get:
Raw_context.t -> Contract_repr.t ->
Signature.Public_key_hash.t option tzresult Lwt.t
val registered: Raw_context.t -> Signature.Public_key_hash.t -> bool Lwt.t
(** Updating the delegate of a contract.
When calling this function on an "implicit contract" this function
fails, unless when the registered delegate is the contract manager.
In the that case, the manager is now registered as a delegate. One
cannot unregister a delegate for now. The associate contract is
now 'undeletable'. *)
val set:
Raw_context.t -> Contract_repr.t -> Signature.Public_key_hash.t option ->
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 +=
| Non_delegatable_contract of Contract_repr.contract (* `Permanent *)
| No_deletion of Signature.Public_key_hash.t (* `Permanent *)
| Active_delegate (* `Temporary *)
| Current_delegate (* `Temporary *)
| Empty_delegate_account of Signature.Public_key_hash.t (* `Temporary *)
| Balance_too_low_for_deposit of
{ delegate : Signature.Public_key_hash.t ;
deposit : Tez_repr.t ;
balance : Tez_repr.t } (* `Temporary *)
(** Iterate on all registered delegates. *)
val fold:
Raw_context.t ->
init:'a ->
f:(Signature.Public_key_hash.t -> 'a -> 'a Lwt.t) -> 'a Lwt.t
(** List all registered delegates. *)
val list: Raw_context.t -> Signature.Public_key_hash.t list Lwt.t
(** Various functions to 'freeze' tokens. A frozen 'deposit' keeps its
associated rolls. When frozen, 'fees' may trigger new rolls
allocation. Rewards won't trigger new rolls allocation until
unfrozen. *)
val freeze_deposit:
Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t ->
Raw_context.t tzresult Lwt.t
val freeze_fees:
Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t ->
Raw_context.t tzresult Lwt.t
val freeze_rewards:
Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t ->
Raw_context.t tzresult Lwt.t
(** Trigger the context maintenance at the end of cycle 'n', i.e.:
unfreeze deposit/fees/rewards from 'n - preserved_cycle' ; punish the
provided unrevealed seeds (tipically seed from cycle 'n - 1').
Returns a list of account with the amount that was unfrozen for each
and the list of deactivated delegates. *)
val cycle_end:
Raw_context.t -> Cycle_repr.t -> Nonce_storage.unrevealed list ->
(Raw_context.t * balance_updates * Signature.Public_key_hash.t list) tzresult Lwt.t
(** Burn all then frozen deposit/fees/rewards for a delegate at a given
cycle. Returns the burned amounts. *)
val punish:
Raw_context.t -> Signature.Public_key_hash.t -> Cycle_repr.t ->
(Raw_context.t * frozen_balance) tzresult Lwt.t
(** Has the given key some frozen tokens in its implicit contract? *)
val has_frozen_balance:
Raw_context.t -> Signature.Public_key_hash.t -> Cycle_repr.t ->
bool tzresult Lwt.t
(** Returns the amount of frozen deposit, fees and rewards associated
to a given delegate. *)
val frozen_balance:
Raw_context.t -> Signature.Public_key_hash.t ->
Tez_repr.t tzresult Lwt.t
val frozen_balance_encoding: frozen_balance Data_encoding.t
val frozen_balance_by_cycle_encoding:
frozen_balance Cycle_repr.Map.t Data_encoding.t
(** Returns the amount of frozen deposit, fees and rewards associated
to a given delegate, indexed by the cycle by which at the end the
balance will be unfrozen. *)
val frozen_balance_by_cycle:
Raw_context.t -> Signature.Public_key_hash.t ->
frozen_balance Cycle_repr.Map.t Lwt.t
(** Returns the full 'balance' of the implicit contract associated to
a given key, i.e. the sum of the spendable balance and of the
frozen balance. *)
val full_balance:
Raw_context.t -> Signature.Public_key_hash.t ->
Tez_repr.t tzresult Lwt.t
val staking_balance:
Raw_context.t -> Signature.Public_key_hash.t ->
Tez_repr.t tzresult Lwt.t
(** Returns the list of contract that delegated towards a given delegate *)
val delegated_contracts:
Raw_context.t -> Signature.Public_key_hash.t ->
Contract_hash.t list Lwt.t
val delegated_balance:
Raw_context.t -> Signature.Public_key_hash.t ->
Tez_repr.t tzresult Lwt.t
val deactivated:
Raw_context.t -> Signature.Public_key_hash.t ->
bool tzresult Lwt.t
val grace_period:
Raw_context.t -> Signature.Public_key_hash.t ->
Cycle_repr.t tzresult Lwt.t

20
vendors/ligo-utils/tezos-protocol-alpha/dune vendored Normal file
View File

@ -0,0 +1,20 @@
;; -*- mode: dune; -*-
(include dune.inc)
(rule
(targets "dune.inc.gen")
(deps TEZOS_PROTOCOL (glob_files *.ml) (glob_files *.mli))
(action
(run
%{libexec:tezos-protocol-compiler:replace}
%{libexec:tezos-protocol-compiler:dune_protocol.template}
"dune.inc.gen")))
(alias
(name runtest_dune_template)
(action (diff dune.inc dune.inc.gen)))
(alias
(name runtest)
(deps (alias runtest_dune_template)))

2
vendors/ligo-utils/tezos-protocol-alpha/dune-project vendored Normal file
View File

@ -0,0 +1,2 @@
(lang dune 1.10)
(name tezos-embedded-protocol-alpha)

109
vendors/ligo-utils/tezos-protocol-alpha/dune.inc vendored Normal file
View File

@ -0,0 +1,109 @@
;
; /!\ /!\ Do not modify this file /!\ /!\
;
; but the original template in `tezos-protocol-compiler`
;
(rule
(targets environment.ml)
(action
(write-file %{targets}
"module Name = struct let name = \"alpha\" end
include Tezos_protocol_environment.MakeV1(Name)()
module CamlinternalFormatBasics = struct include CamlinternalFormatBasics end
")))
(rule
(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
(:src_dir TEZOS_PROTOCOL))
(action
(with-stdout-to %{targets}
(chdir %{workspace_root} (run %{bin:tezos-embedded-protocol-packer} "%{src_dir}" "alpha")))))
(rule
(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
(:src_dir TEZOS_PROTOCOL))
(action (with-stdout-to %{targets}
(chdir %{workspace_root}
(run %{bin:tezos-protocol-compiler.tezos-protocol-packer} %{src_dir})))))
(rule
(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)
(action
(write-file %{targets}
"module Environment = Tezos_protocol_environment_alpha.Environment
let hash = Tezos_crypto.Protocol_hash.of_b58check_exn \"ProtoALphaALphaALphaALphaALphaALphaALphaALphaDdp3zK\"
let name = Environment.Name.name
include Tezos_raw_protocol_alpha
include Tezos_raw_protocol_alpha.Main
")))
(library
(name tezos_protocol_environment_alpha)
(public_name tezos-protocol-alpha.environment)
(library_flags (:standard -linkall))
(libraries tezos-protocol-environment)
(modules Environment))
(library
(name tezos_raw_protocol_alpha)
(public_name tezos-protocol-alpha.raw)
(libraries tezos_protocol_environment_alpha)
(library_flags (:standard -linkall))
(flags (:standard -nopervasives -nostdlib
-w +a-4-6-7-9-29-32-40..42-44-45-48
-warn-error -a+8
-open Tezos_protocol_environment_alpha__Environment
-open Pervasives
-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))
(install
(section lib)
(package tezos-protocol-alpha)
(files (TEZOS_PROTOCOL as raw/TEZOS_PROTOCOL)))
(library
(name tezos_protocol_alpha)
(public_name tezos-protocol-alpha)
(libraries
tezos-protocol-environment
tezos-protocol-environment-sigs
tezos_raw_protocol_alpha)
(flags -w "+a-4-6-7-9-29-40..42-44-45-48"
-warn-error "-a+8"
-nopervasives)
(modules Protocol))
(library
(name tezos_protocol_alpha_functor)
(public_name tezos-protocol-alpha.functor)
(libraries
tezos-protocol-environment
tezos-protocol-environment-sigs
tezos_raw_protocol_alpha)
(flags -w "+a-4-6-7-9-29-40..42-44-45-48"
-warn-error "-a+8"
-nopervasives)
(modules Functor))
(library
(name tezos_embedded_protocol_alpha)
(public_name tezos-embedded-protocol-alpha)
(library_flags (:standard -linkall))
(libraries tezos-protocol-alpha
tezos-protocol-updater
tezos-protocol-environment)
(flags (:standard -w +a-4-6-7-9-29-32-40..42-44-45-48
-warn-error -a+8))
(modules Registerer))
(alias
(name runtest_sandbox)
(deps .tezos_protocol_alpha.objs/native/tezos_protocol_alpha.cmx))

111
vendors/ligo-utils/tezos-protocol-alpha/fees_storage.ml vendored Normal file
View File

@ -0,0 +1,111 @@
(*****************************************************************************)
(* *)
(* 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. *)
(* *)
(*****************************************************************************)
type error += Cannot_pay_storage_fee (* `Temporary *)
type error += Operation_quota_exceeded (* `Temporary *)
type error += Storage_limit_too_high (* `Permanent *)
let () =
let open Data_encoding in
register_error_kind
`Temporary
~id:"contract.cannot_pay_storage_fee"
~title:"Cannot pay storage fee"
~description:"The storage fee is higher than the contract balance"
~pp:(fun ppf () -> Format.fprintf ppf "Cannot pay storage storage fee")
Data_encoding.empty
(function Cannot_pay_storage_fee -> Some () | _ -> None)
(fun () -> Cannot_pay_storage_fee) ;
register_error_kind
`Temporary
~id:"storage_exhausted.operation"
~title: "Storage quota exceeded for the operation"
~description:
"A script or one of its callee wrote more \
bytes than the operation said it would"
Data_encoding.empty
(function Operation_quota_exceeded -> Some () | _ -> None)
(fun () -> Operation_quota_exceeded) ;
register_error_kind
`Permanent
~id:"storage_limit_too_high"
~title: "Storage limit out of protocol hard bounds"
~description:
"A transaction tried to exceed the hard limit on storage"
empty
(function Storage_limit_too_high -> Some () | _ -> None)
(fun () -> Storage_limit_too_high)
let origination_burn c =
let origination_size = Constants_storage.origination_size c in
let cost_per_byte = Constants_storage.cost_per_byte c in
(* the origination burn, measured in bytes *)
Lwt.return
Tez_repr.(cost_per_byte *? (Int64.of_int origination_size)) >>=? fun to_be_paid ->
return (Raw_context.update_allocated_contracts_count c,
to_be_paid)
let record_paid_storage_space c contract =
Contract_storage.used_storage_space c contract >>=? fun size ->
Contract_storage.set_paid_storage_space_and_return_fees_to_pay c contract size >>=? fun (to_be_paid, c) ->
let c = Raw_context.update_storage_space_to_pay c to_be_paid in
let cost_per_byte = Constants_storage.cost_per_byte c in
Lwt.return (Tez_repr.(cost_per_byte *? (Z.to_int64 to_be_paid))) >>=? fun to_burn ->
return (c, size, to_be_paid, to_burn)
let burn_storage_fees c ~storage_limit ~payer =
let origination_size = Constants_storage.origination_size c in
let c, storage_space_to_pay, allocated_contracts =
Raw_context.clear_storage_space_to_pay c in
let storage_space_for_allocated_contracts =
Z.mul (Z.of_int allocated_contracts) (Z.of_int origination_size) in
let consumed =
Z.add storage_space_to_pay storage_space_for_allocated_contracts in
let remaining = Z.sub storage_limit consumed in
if Compare.Z.(remaining < Z.zero) then
fail Operation_quota_exceeded
else
let cost_per_byte = Constants_storage.cost_per_byte c in
Lwt.return (Tez_repr.(cost_per_byte *? (Z.to_int64 consumed))) >>=? fun to_burn ->
(* Burning the fees... *)
if Tez_repr.(to_burn = Tez_repr.zero) then
(* If the payer was was deleted by transfering all its balance, and no space was used,
burning zero would fail *)
return c
else
trace Cannot_pay_storage_fee
(Contract_storage.must_exist c payer >>=? fun () ->
Contract_storage.spend_from_script c payer to_burn) >>=? fun c ->
return c
let check_storage_limit c ~storage_limit =
if Compare.Z.(storage_limit > (Raw_context.constants c).hard_storage_limit_per_operation)
|| Compare.Z.(storage_limit < Z.zero)then
error Storage_limit_too_high
else
ok ()
let start_counting_storage_fees c =
Raw_context.init_storage_space_to_pay c

46
vendors/ligo-utils/tezos-protocol-alpha/fees_storage.mli vendored Normal file
View File

@ -0,0 +1,46 @@
(*****************************************************************************)
(* *)
(* 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. *)
(* *)
(*****************************************************************************)
type error += Cannot_pay_storage_fee (* `Temporary *)
type error += Operation_quota_exceeded (* `Temporary *)
type error += Storage_limit_too_high (* `Permanent *)
(** Does not burn, only adds the burn to storage space to be paid *)
val origination_burn:
Raw_context.t -> (Raw_context.t * Tez_repr.t) tzresult Lwt.t
(** The returned Tez quantity is for logging purpose only *)
val record_paid_storage_space:
Raw_context.t -> Contract_repr.t ->
(Raw_context.t * Z.t * Z.t * Tez_repr.t) tzresult Lwt.t
val check_storage_limit:
Raw_context.t -> storage_limit:Z.t -> unit tzresult
val start_counting_storage_fees :
Raw_context.t -> Raw_context.t
val burn_storage_fees:
Raw_context.t -> storage_limit:Z.t -> payer:Contract_repr.t -> Raw_context.t tzresult Lwt.t

61
vendors/ligo-utils/tezos-protocol-alpha/fitness_repr.ml vendored Normal file
View File

@ -0,0 +1,61 @@
(*****************************************************************************)
(* *)
(* 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. *)
(* *)
(*****************************************************************************)
type error += Invalid_fitness (* `Permanent *)
let () =
register_error_kind
`Permanent
~id:"invalid_fitness"
~title:"Invalid fitness"
~description:"Fitness representation should be exactly 8 bytes long."
~pp:(fun ppf () -> Format.fprintf ppf "Invalid fitness")
Data_encoding.empty
(function Invalid_fitness -> Some () | _ -> None)
(fun () -> Invalid_fitness)
let int64_to_bytes i =
let b = MBytes.create 8 in
MBytes.set_int64 b 0 i;
b
let int64_of_bytes b =
if Compare.Int.(MBytes.length b <> 8) then
error Invalid_fitness
else
ok (MBytes.get_int64 b 0)
let from_int64 fitness =
[ MBytes.of_string Constants_repr.version_number ;
int64_to_bytes fitness ]
let to_int64 = function
| [ version ;
fitness ]
when Compare.String.
(MBytes.to_string version = Constants_repr.version_number) ->
int64_of_bytes fitness
| [] -> ok 0L
| _ -> error Invalid_fitness

29
vendors/ligo-utils/tezos-protocol-alpha/fitness_storage.ml vendored Normal file
View File

@ -0,0 +1,29 @@
(*****************************************************************************)
(* *)
(* 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. *)
(* *)
(*****************************************************************************)
let current = Raw_context.current_fitness
let increase ?(gap = 1) ctxt =
let fitness = current ctxt in
Raw_context.set_current_fitness ctxt (Int64.add (Int64.of_int gap) fitness)

208
vendors/ligo-utils/tezos-protocol-alpha/gas_limit_repr.ml vendored Normal file
View File

@ -0,0 +1,208 @@
(*****************************************************************************)
(* *)
(* 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. *)
(* *)
(*****************************************************************************)
type t =
| Unaccounted
| Limited of { remaining : Z.t }
type cost =
{ allocations : Z.t ;
steps : Z.t ;
reads : Z.t ;
writes : Z.t ;
bytes_read : Z.t ;
bytes_written : Z.t }
let encoding =
let open Data_encoding in
union
[ case (Tag 0)
~title:"Limited"
z
(function Limited { remaining } -> Some remaining | _ -> None)
(fun remaining -> Limited { remaining }) ;
case (Tag 1)
~title:"Unaccounted"
(constant "unaccounted")
(function Unaccounted -> Some () | _ -> None)
(fun () -> Unaccounted) ]
let pp ppf = function
| Unaccounted ->
Format.fprintf ppf "unaccounted"
| Limited { remaining } ->
Format.fprintf ppf "%s units remaining" (Z.to_string remaining)
let cost_encoding =
let open Data_encoding in
conv
(fun { allocations ; steps ; reads ; writes ; bytes_read ; bytes_written } ->
(allocations, steps, reads, writes, bytes_read, bytes_written))
(fun (allocations, steps, reads, writes, bytes_read, bytes_written) ->
{ allocations ; steps ; reads ; writes ; bytes_read ; bytes_written })
(obj6
(req "allocations" z)
(req "steps" z)
(req "reads" z)
(req "writes" z)
(req "bytes_read" z)
(req "bytes_written" z))
let pp_cost ppf { allocations ; steps ; reads ; writes ; bytes_read ; bytes_written } =
Format.fprintf ppf
"(steps: %s, allocs: %s, reads: %s (%s bytes), writes: %s (%s bytes))"
(Z.to_string steps)
(Z.to_string allocations)
(Z.to_string reads)
(Z.to_string bytes_read)
(Z.to_string writes)
(Z.to_string bytes_written)
type error += Block_quota_exceeded (* `Temporary *)
type error += Operation_quota_exceeded (* `Temporary *)
let allocation_weight = Z.of_int 2
let step_weight = Z.of_int 1
let read_base_weight = Z.of_int 100
let write_base_weight = Z.of_int 160
let byte_read_weight = Z.of_int 10
let byte_written_weight = Z.of_int 15
let consume block_gas operation_gas cost = match operation_gas with
| Unaccounted -> ok (block_gas, Unaccounted)
| Limited { remaining } ->
let weighted_cost =
Z.add
(Z.add
(Z.mul allocation_weight cost.allocations)
(Z.mul step_weight cost.steps))
(Z.add
(Z.add
(Z.mul read_base_weight cost.reads)
(Z.mul write_base_weight cost.writes))
(Z.add
(Z.mul byte_read_weight cost.bytes_read)
(Z.mul byte_written_weight cost.bytes_written))) in
let remaining =
Z.sub remaining weighted_cost in
let block_remaining =
Z.sub block_gas weighted_cost in
if Compare.Z.(remaining < Z.zero)
then error Operation_quota_exceeded
else if Compare.Z.(block_remaining < Z.zero)
then error Block_quota_exceeded
else ok (block_remaining, Limited { remaining })
let check_enough block_gas operation_gas cost =
consume block_gas operation_gas cost
>|? fun (_block_remainig, _remaining) -> ()
let alloc_cost n =
{ allocations = Z.of_int (n + 1) ;
steps = Z.zero ;
reads = Z.zero ;
writes = Z.zero ;
bytes_read = Z.zero ;
bytes_written = Z.zero }
let alloc_bytes_cost n =
alloc_cost ((n + 7) / 8)
let alloc_bits_cost n =
alloc_cost ((n + 63) / 64)
let step_cost n =
{ allocations = Z.zero ;
steps = Z.of_int n ;
reads = Z.zero ;
writes = Z.zero ;
bytes_read = Z.zero ;
bytes_written = Z.zero }
let free =
{ allocations = Z.zero ;
steps = Z.zero ;
reads = Z.zero ;
writes = Z.zero ;
bytes_read = Z.zero ;
bytes_written = Z.zero }
let read_bytes_cost n =
{ allocations = Z.zero ;
steps = Z.zero ;
reads = Z.one ;
writes = Z.zero ;
bytes_read = n ;
bytes_written = Z.zero }
let write_bytes_cost n =
{ allocations = Z.zero ;
steps = Z.zero ;
reads = Z.zero ;
writes = Z.one ;
bytes_read = Z.zero ;
bytes_written = n }
let ( +@ ) x y =
{ allocations = Z.add x.allocations y.allocations ;
steps = Z.add x.steps y.steps ;
reads = Z.add x.reads y.reads ;
writes = Z.add x.writes y.writes ;
bytes_read = Z.add x.bytes_read y.bytes_read ;
bytes_written = Z.add x.bytes_written y.bytes_written }
let ( *@ ) x y =
{ allocations = Z.mul (Z.of_int x) y.allocations ;
steps = Z.mul (Z.of_int x) y.steps ;
reads = Z.mul (Z.of_int x) y.reads ;
writes = Z.mul (Z.of_int x) y.writes ;
bytes_read = Z.mul (Z.of_int x) y.bytes_read ;
bytes_written = Z.mul (Z.of_int x) y.bytes_written }
let alloc_mbytes_cost n =
alloc_cost 12 +@ alloc_bytes_cost n
let () =
let open Data_encoding in
register_error_kind
`Temporary
~id:"gas_exhausted.operation"
~title: "Gas quota exceeded for the operation"
~description:
"A script or one of its callee took more \
time than the operation said it would"
empty
(function Operation_quota_exceeded -> Some () | _ -> None)
(fun () -> Operation_quota_exceeded) ;
register_error_kind
`Temporary
~id:"gas_exhausted.block"
~title: "Gas quota exceeded for the block"
~description:
"The sum of gas consumed by all the operations in the block \
exceeds the hard gas limit per block"
empty
(function Block_quota_exceeded -> Some () | _ -> None)
(fun () -> Block_quota_exceeded) ;

54
vendors/ligo-utils/tezos-protocol-alpha/gas_limit_repr.mli vendored Normal file
View File

@ -0,0 +1,54 @@
(*****************************************************************************)
(* *)
(* 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. *)
(* *)
(*****************************************************************************)
type t =
| Unaccounted
| Limited of { remaining : Z.t }
val encoding : t Data_encoding.encoding
val pp : Format.formatter -> t -> unit
type cost
val cost_encoding : cost Data_encoding.encoding
val pp_cost : Format.formatter -> cost -> unit
type error += Block_quota_exceeded (* `Temporary *)
type error += Operation_quota_exceeded (* `Temporary *)
val consume : Z.t -> t -> cost -> (Z.t * t) tzresult
val check_enough : Z.t -> t -> cost -> unit tzresult
val free : cost
val step_cost : int -> cost
val alloc_cost : int -> cost
val alloc_bytes_cost : int -> cost
val alloc_mbytes_cost : int -> cost
val alloc_bits_cost : int -> cost
val read_bytes_cost : Z.t -> cost
val write_bytes_cost : Z.t -> cost
val ( *@ ) : int -> cost -> cost
val ( +@ ) : cost -> cost -> cost

635
vendors/ligo-utils/tezos-protocol-alpha/helpers_services.ml vendored Normal file
View File

@ -0,0 +1,635 @@
(*****************************************************************************)
(* *)
(* 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 Alpha_context
type error += Cannot_parse_operation (* `Branch *)
let () =
register_error_kind
`Branch
~id:"operation.cannot_parse"
~title:"Cannot parse operation"
~description:"The operation is ill-formed \
or for another protocol version"
~pp:(fun ppf () ->
Format.fprintf ppf "The operation cannot be parsed")
Data_encoding.unit
(function Cannot_parse_operation -> Some () | _ -> None)
(fun () -> Cannot_parse_operation)
let parse_operation (op: Operation.raw) =
match Data_encoding.Binary.of_bytes
Operation.protocol_data_encoding
op.proto with
| Some protocol_data ->
ok { shell = op.shell ; protocol_data }
| None -> error Cannot_parse_operation
let path = RPC_path.(open_root / "helpers")
module Scripts = struct
module S = struct
open Data_encoding
let path = RPC_path.(path / "scripts")
let run_code_input_encoding =
(obj7
(req "script" Script.expr_encoding)
(req "storage" Script.expr_encoding)
(req "input" Script.expr_encoding)
(req "amount" Tez.encoding)
(opt "source" Contract.encoding)
(opt "payer" Contract.encoding)
(opt "gas" z))
let trace_encoding =
def "scripted.trace" @@
(list @@ obj3
(req "location" Script.location_encoding)
(req "gas" Gas.encoding)
(req "stack"
(list
(obj2
(req "item" (Script.expr_encoding))
(opt "annot" string)))))
let run_code =
RPC_service.post_service
~description: "Run a piece of code in the current context"
~query: RPC_query.empty
~input: run_code_input_encoding
~output: (obj3
(req "storage" Script.expr_encoding)
(req "operations" (list Operation.internal_operation_encoding))
(opt "big_map_diff" Contract.big_map_diff_encoding))
RPC_path.(path / "run_code")
let trace_code =
RPC_service.post_service
~description: "Run a piece of code in the current context, \
keeping a trace"
~query: RPC_query.empty
~input: run_code_input_encoding
~output: (obj4
(req "storage" Script.expr_encoding)
(req "operations" (list Operation.internal_operation_encoding))
(req "trace" trace_encoding)
(opt "big_map_diff" Contract.big_map_diff_encoding))
RPC_path.(path / "trace_code")
let typecheck_code =
RPC_service.post_service
~description: "Typecheck a piece of code in the current context"
~query: RPC_query.empty
~input: (obj2
(req "program" Script.expr_encoding)
(opt "gas" z))
~output: (obj2
(req "type_map" Script_tc_errors_registration.type_map_enc)
(req "gas" Gas.encoding))
RPC_path.(path / "typecheck_code")
let typecheck_data =
RPC_service.post_service
~description: "Check that some data expression is well formed \
and of a given type in the current context"
~query: RPC_query.empty
~input: (obj3
(req "data" Script.expr_encoding)
(req "type" Script.expr_encoding)
(opt "gas" z))
~output: (obj1 (req "gas" Gas.encoding))
RPC_path.(path / "typecheck_data")
let pack_data =
RPC_service.post_service
~description: "Computes the serialized version of some data expression \
using the same algorithm as script instruction PACK"
~input: (obj3
(req "data" Script.expr_encoding)
(req "type" Script.expr_encoding)
(opt "gas" z))
~output: (obj2
(req "packed" bytes)
(req "gas" Gas.encoding))
~query: RPC_query.empty
RPC_path.(path / "pack_data")
let run_operation =
RPC_service.post_service
~description:
"Run an operation without signature checks"
~query: RPC_query.empty
~input: Operation.encoding
~output: Apply_results.operation_data_and_metadata_encoding
RPC_path.(path / "run_operation")
end
let register () =
let open Services_registration in
let originate_dummy_contract ctxt script =
let ctxt = Contract.init_origination_nonce ctxt Operation_hash.zero in
Contract.fresh_contract_from_current_nonce ctxt >>=? fun (ctxt, dummy_contract) ->
let balance = match Tez.of_mutez 4_000_000_000_000L with
| Some balance -> balance
| None -> assert false in
Contract.originate ctxt dummy_contract
~balance
~manager: Signature.Public_key_hash.zero
~delegate: None
~spendable: false
~delegatable: false
~script: (script, None) >>=? fun ctxt ->
return (ctxt, dummy_contract) in
register0 S.run_code begin fun ctxt ()
(code, storage, parameter, amount, source, payer, gas) ->
let storage = Script.lazy_expr storage in
let code = Script.lazy_expr code in
originate_dummy_contract ctxt { storage ; code } >>=? fun (ctxt, dummy_contract) ->
let source, payer = match source, payer with
| Some source, Some payer -> source, payer
| Some source, None -> source, source
| None, Some payer -> payer, payer
| None, None -> dummy_contract, dummy_contract in
let gas = match gas with
| Some gas -> gas
| None -> Constants.hard_gas_limit_per_operation ctxt in
let ctxt = Gas.set_limit ctxt gas in
Script_interpreter.execute
ctxt Readable
~source
~payer
~self:(dummy_contract, { storage ; code })
~amount ~parameter
>>=? fun { Script_interpreter.storage ; operations ; big_map_diff ; _ } ->
return (storage, operations, big_map_diff)
end ;
register0 S.trace_code begin fun ctxt ()
(code, storage, parameter, amount, source, payer, gas) ->
let storage = Script.lazy_expr storage in
let code = Script.lazy_expr code in
originate_dummy_contract ctxt { storage ; code } >>=? fun (ctxt, dummy_contract) ->
let source, payer = match source, payer with
| Some source, Some payer -> source, payer
| Some source, None -> source, source
| None, Some payer -> payer, payer
| None, None -> dummy_contract, dummy_contract in
let gas = match gas with
| Some gas -> gas
| None -> Constants.hard_gas_limit_per_operation ctxt in
let ctxt = Gas.set_limit ctxt gas in
Script_interpreter.trace
ctxt Readable
~source
~payer
~self:(dummy_contract, { storage ; code })
~amount ~parameter
>>=? fun ({ Script_interpreter.storage ; operations ; big_map_diff ; _ }, trace) ->
return (storage, operations, trace, big_map_diff)
end ;
register0 S.typecheck_code begin fun ctxt () (expr, maybe_gas) ->
let ctxt = match maybe_gas with
| None -> Gas.set_unlimited ctxt
| Some gas -> Gas.set_limit ctxt gas in
Script_ir_translator.typecheck_code ctxt expr >>=? fun (res, ctxt) ->
return (res, Gas.level ctxt)
end ;
register0 S.typecheck_data begin fun ctxt () (data, ty, maybe_gas) ->
let ctxt = match maybe_gas with
| None -> Gas.set_unlimited ctxt
| Some gas -> Gas.set_limit ctxt gas in
Script_ir_translator.typecheck_data ctxt (data, ty) >>=? fun ctxt ->
return (Gas.level ctxt)
end ;
register0 S.pack_data begin fun ctxt () (expr, typ, maybe_gas) ->
let open Script_ir_translator in
let ctxt = match maybe_gas with
| None -> Gas.set_unlimited ctxt
| 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) ->
parse_data ctxt typ (Micheline.root expr) >>=? fun (data, ctxt) ->
Script_ir_translator.pack_data ctxt typ data >>=? fun (bytes, ctxt) ->
return (bytes, Gas.level ctxt)
end ;
register0 S.run_operation begin fun ctxt ()
{ shell ; protocol_data = Operation_data protocol_data } ->
(* this code is a duplicate of Apply without signature check *)
let partial_precheck_manager_contents
(type kind) ctxt (op : kind Kind.manager contents)
: context tzresult Lwt.t =
let Manager_operation { source ; fee ; counter ; operation ; gas_limit ; storage_limit } = op in
Lwt.return (Gas.check_limit ctxt gas_limit) >>=? fun () ->
let ctxt = Gas.set_limit ctxt gas_limit in
Lwt.return (Fees.check_storage_limit ctxt storage_limit) >>=? fun () ->
Contract.must_be_allocated ctxt source >>=? fun () ->
Contract.check_counter_increment ctxt source counter >>=? fun () ->
begin
match operation with
| Reveal pk ->
Contract.reveal_manager_key ctxt source pk
| Transaction { parameters = Some arg ; _ } ->
(* 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 = match Data_encoding.Binary.of_bytes Script.lazy_expr_encoding arg_bytes with
| Some arg -> arg
| None -> assert false in
(* Fail quickly if not enough gas for minimal deserialization cost *)
Lwt.return @@ record_trace Apply.Gas_quota_exceeded_init_deserialize @@
Gas.check_enough ctxt (Script.minimal_deserialize_cost arg) >>=? fun () ->
(* Fail if not enough gas for complete deserialization cost *)
trace Apply.Gas_quota_exceeded_init_deserialize @@
Script.force_decode ctxt arg >>|? fun (_arg, ctxt) -> ctxt
| Origination { script = Some script ; _ } ->
(* 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 = match Data_encoding.Binary.of_bytes Script.encoding script_bytes with
| Some script -> script
| None -> assert false in
(* Fail quickly if not enough gas for minimal deserialization cost *)
Lwt.return @@ record_trace Apply.Gas_quota_exceeded_init_deserialize @@
(Gas.consume ctxt (Script.minimal_deserialize_cost script.code) >>? fun ctxt ->
Gas.check_enough ctxt (Script.minimal_deserialize_cost script.storage)) >>=? fun () ->
(* Fail if not enough gas for complete deserialization cost *)
trace Apply.Gas_quota_exceeded_init_deserialize @@
Script.force_decode ctxt script.code >>=? fun (_code, ctxt) ->
trace Apply.Gas_quota_exceeded_init_deserialize @@
Script.force_decode ctxt script.storage >>|? fun (_storage, ctxt) -> ctxt
| _ -> return ctxt
end >>=? fun ctxt ->
Contract.get_manager_key ctxt source >>=? fun _public_key ->
(* signature check unplugged from here *)
Contract.increment_counter ctxt source >>=? fun ctxt ->
Contract.spend ctxt source fee >>=? fun ctxt ->
return ctxt in
let rec partial_precheck_manager_contents_list
: type kind.
Alpha_context.t -> kind Kind.manager contents_list ->
context tzresult Lwt.t =
fun ctxt contents_list ->
match contents_list with
| Single (Manager_operation _ as op) ->
partial_precheck_manager_contents ctxt op
| Cons (Manager_operation _ as op, rest) ->
partial_precheck_manager_contents ctxt op >>=? fun ctxt ->
partial_precheck_manager_contents_list ctxt rest in
let return contents =
return (Operation_data protocol_data,
Apply_results.Operation_metadata { contents }) in
let operation : _ operation = { shell ; protocol_data } in
let hash = Operation.hash { shell ; protocol_data } in
let ctxt = Contract.init_origination_nonce ctxt hash in
let baker = Signature.Public_key_hash.zero in
match protocol_data.contents with
| Single (Manager_operation _) as op ->
partial_precheck_manager_contents_list ctxt op >>=? fun ctxt ->
Apply.apply_manager_contents_list ctxt Optimized baker op >>= fun (_ctxt, result) ->
return result
| Cons (Manager_operation _, _) as op ->
partial_precheck_manager_contents_list ctxt op >>=? fun ctxt ->
Apply.apply_manager_contents_list ctxt Optimized baker op >>= fun (_ctxt, result) ->
return result
| _ ->
Apply.apply_contents_list
ctxt ~partial:true Chain_id.zero Optimized shell.branch baker operation
operation.protocol_data.contents >>=? fun (_ctxt, result) ->
return result
end
let run_code ctxt block code (storage, input, amount, source, payer, gas) =
RPC_context.make_call0 S.run_code ctxt
block () (code, storage, input, amount, source, payer, gas)
let trace_code ctxt block code (storage, input, amount, source, payer, gas) =
RPC_context.make_call0 S.trace_code ctxt
block () (code, storage, input, amount, source, payer, gas)
let typecheck_code ctxt block =
RPC_context.make_call0 S.typecheck_code ctxt block ()
let typecheck_data ctxt block =
RPC_context.make_call0 S.typecheck_data ctxt block ()
let pack_data ctxt block =
RPC_context.make_call0 S.pack_data ctxt block ()
let run_operation ctxt block =
RPC_context.make_call0 S.run_operation ctxt block ()
end
module Forge = struct
module S = struct
open Data_encoding
let path = RPC_path.(path / "forge")
let operations =
RPC_service.post_service
~description:"Forge an operation"
~query: RPC_query.empty
~input: Operation.unsigned_encoding
~output: bytes
RPC_path.(path / "operations" )
let empty_proof_of_work_nonce =
MBytes.of_string
(String.make Constants_repr.proof_of_work_nonce_size '\000')
let protocol_data =
RPC_service.post_service
~description: "Forge the protocol-specific part of a block header"
~query: RPC_query.empty
~input:
(obj3
(req "priority" uint16)
(opt "nonce_hash" Nonce_hash.encoding)
(dft "proof_of_work_nonce"
(Fixed.bytes
Alpha_context.Constants.proof_of_work_nonce_size)
empty_proof_of_work_nonce))
~output: (obj1 (req "protocol_data" bytes))
RPC_path.(path / "protocol_data")
end
let register () =
let open Services_registration in
register0_noctxt S.operations begin fun () (shell, proto) ->
return (Data_encoding.Binary.to_bytes_exn
Operation.unsigned_encoding (shell, proto))
end ;
register0_noctxt S.protocol_data begin fun ()
(priority, seed_nonce_hash, proof_of_work_nonce) ->
return (Data_encoding.Binary.to_bytes_exn
Block_header.contents_encoding
{ priority ; seed_nonce_hash ; proof_of_work_nonce })
end
module Manager = struct
let operations ctxt
block ~branch ~source ?sourcePubKey ~counter ~fee
~gas_limit ~storage_limit operations =
Contract_services.manager_key ctxt block source >>= function
| Error _ as e -> Lwt.return e
| Ok (_, revealed) ->
let ops =
List.map
(fun (Manager operation) ->
Contents
(Manager_operation { source ;
counter ; operation ; fee ;
gas_limit ; storage_limit }))
operations in
let ops =
match sourcePubKey, revealed with
| None, _ | _, Some _ -> ops
| Some pk, None ->
let operation = Reveal pk in
Contents
(Manager_operation { source ;
counter ; operation ; fee ;
gas_limit ; storage_limit }) :: ops in
RPC_context.make_call0 S.operations ctxt block
() ({ branch }, Operation.of_list ops)
let reveal ctxt
block ~branch ~source ~sourcePubKey ~counter ~fee () =
operations ctxt block ~branch ~source ~sourcePubKey ~counter ~fee
~gas_limit:Z.zero ~storage_limit:Z.zero []
let transaction ctxt
block ~branch ~source ?sourcePubKey ~counter
~amount ~destination ?parameters
~gas_limit ~storage_limit ~fee ()=
let parameters = Option.map ~f:Script.lazy_expr parameters in
operations ctxt block ~branch ~source ?sourcePubKey ~counter
~fee ~gas_limit ~storage_limit
[Manager (Transaction { amount ; parameters ; destination })]
let origination ctxt
block ~branch
~source ?sourcePubKey ~counter
~managerPubKey ~balance
?(spendable = true)
?(delegatable = true)
?delegatePubKey ?script
~gas_limit ~storage_limit ~fee () =
operations ctxt block ~branch ~source ?sourcePubKey ~counter
~fee ~gas_limit ~storage_limit
[Manager (Origination { manager = managerPubKey ;
delegate = delegatePubKey ;
script ;
spendable ;
delegatable ;
credit = balance ;
preorigination = None })]
let delegation ctxt
block ~branch ~source ?sourcePubKey ~counter ~fee delegate =
operations ctxt block ~branch ~source ?sourcePubKey ~counter ~fee
~gas_limit:Z.zero ~storage_limit:Z.zero
[Manager (Delegation delegate)]
end
let operation ctxt
block ~branch operation =
RPC_context.make_call0 S.operations ctxt block
() ({ branch }, Contents_list (Single operation))
let endorsement ctxt
b ~branch ~level () =
operation ctxt b ~branch
(Endorsement { level })
let proposals ctxt
b ~branch ~source ~period ~proposals () =
operation ctxt b ~branch
(Proposals { source ; period ; proposals })
let ballot ctxt
b ~branch ~source ~period ~proposal ~ballot () =
operation ctxt b ~branch
(Ballot { source ; period ; proposal ; ballot })
let seed_nonce_revelation ctxt
block ~branch ~level ~nonce () =
operation ctxt block ~branch (Seed_nonce_revelation { level ; nonce })
let double_baking_evidence ctxt
block ~branch ~bh1 ~bh2 () =
operation ctxt block ~branch (Double_baking_evidence { bh1 ; bh2 })
let double_endorsement_evidence ctxt
block ~branch ~op1 ~op2 () =
operation ctxt block ~branch (Double_endorsement_evidence { op1 ; op2 })
let empty_proof_of_work_nonce =
MBytes.of_string
(String.make Constants_repr.proof_of_work_nonce_size '\000')
let protocol_data ctxt
block
~priority ?seed_nonce_hash
?(proof_of_work_nonce = empty_proof_of_work_nonce)
() =
RPC_context.make_call0 S.protocol_data
ctxt block () (priority, seed_nonce_hash, proof_of_work_nonce)
end
module Parse = struct
module S = struct
open Data_encoding
let path = RPC_path.(path / "parse")
let operations =
RPC_service.post_service
~description:"Parse operations"
~query: RPC_query.empty
~input:
(obj2
(req "operations" (list (dynamic_size Operation.raw_encoding)))
(opt "check_signature" bool))
~output: (list (dynamic_size Operation.encoding))
RPC_path.(path / "operations" )
let block =
RPC_service.post_service
~description:"Parse a block"
~query: RPC_query.empty
~input: Block_header.raw_encoding
~output: Block_header.protocol_data_encoding
RPC_path.(path / "block" )
end
let parse_protocol_data protocol_data =
match
Data_encoding.Binary.of_bytes
Block_header.protocol_data_encoding
protocol_data
with
| None -> failwith "Cant_parse_protocol_data"
| Some protocol_data -> return protocol_data
let register () =
let open Services_registration in
register0 S.operations begin fun _ctxt () (operations, check) ->
map_s begin fun raw ->
Lwt.return (parse_operation raw) >>=? fun op ->
begin match check with
| Some true ->
return_unit (* FIXME *)
(* I.check_signature ctxt *)
(* op.protocol_data.signature op.shell op.protocol_data.contents *)
| Some false | None -> return_unit
end >>|? fun () -> op
end operations
end ;
register0_noctxt S.block begin fun () raw_block ->
parse_protocol_data raw_block.protocol_data
end
let operations ctxt block ?check operations =
RPC_context.make_call0
S.operations ctxt block () (operations, check)
let block ctxt block shell protocol_data =
RPC_context.make_call0
S.block ctxt block () ({ shell ; protocol_data } : Block_header.raw)
end
module S = struct
open Data_encoding
type level_query = {
offset: int32 ;
}
let level_query : level_query RPC_query.t =
let open RPC_query in
query (fun offset -> { offset })
|+ field "offset" RPC_arg.int32 0l (fun t -> t.offset)
|> seal
let current_level =
RPC_service.get_service
~description:
"Returns the level of the interrogated block, or the one of a \
block located `offset` blocks after in the chain (or before \
when negative). For instance, the next block if `offset` is 1."
~query: level_query
~output: Level.encoding
RPC_path.(path / "current_level")
let levels_in_current_cycle =
RPC_service.get_service
~description: "Levels of a cycle"
~query: level_query
~output: (obj2
(req "first" Raw_level.encoding)
(req "last" Raw_level.encoding))
RPC_path.(path / "levels_in_current_cycle")
end
let register () =
Scripts.register () ;
Forge.register () ;
Parse.register () ;
let open Services_registration in
register0 S.current_level begin fun ctxt q () ->
let level = Level.current ctxt in
return (Level.from_raw ctxt ~offset:q.offset level.level)
end ;
register0 S.levels_in_current_cycle begin fun ctxt q () ->
let levels = Level.levels_in_current_cycle ctxt ~offset:q.offset () in
match levels with
| [] -> raise Not_found
| _ ->
let first = List.hd (List.rev levels) in
let last = List.hd levels in
return (first.level, last.level)
end
let current_level ctxt ?(offset = 0l) block =
RPC_context.make_call0 S.current_level ctxt block { offset } ()
let levels_in_current_cycle ctxt ?(offset = 0l) block =
RPC_context.make_call0 S.levels_in_current_cycle ctxt block { offset } ()

211
vendors/ligo-utils/tezos-protocol-alpha/helpers_services.mli vendored Normal file
View File

@ -0,0 +1,211 @@
(*****************************************************************************)
(* *)
(* 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 Alpha_context
type error += Cannot_parse_operation (* `Branch *)
val current_level:
'a #RPC_context.simple ->
?offset:int32 -> 'a -> Level.t shell_tzresult Lwt.t
val levels_in_current_cycle:
'a #RPC_context.simple ->
?offset:int32 -> 'a -> (Raw_level.t * Raw_level.t) shell_tzresult Lwt.t
module Scripts : sig
val run_code:
'a #RPC_context.simple ->
'a -> Script.expr ->
(Script.expr * Script.expr * Tez.t * Contract.t option * Contract.t option * Z.t option) ->
(Script.expr *
packed_internal_operation list *
Contract.big_map_diff option) shell_tzresult Lwt.t
val trace_code:
'a #RPC_context.simple ->
'a -> Script.expr ->
(Script.expr * Script.expr * Tez.t * Contract.t option * Contract.t option* Z.t option) ->
(Script.expr *
packed_internal_operation list *
Script_interpreter.execution_trace *
Contract.big_map_diff option) shell_tzresult Lwt.t
val typecheck_code:
'a #RPC_context.simple ->
'a -> (Script.expr * Z.t option) ->
(Script_tc_errors.type_map * Gas.t) shell_tzresult Lwt.t
val typecheck_data:
'a #RPC_context.simple ->
'a -> Script.expr * Script.expr * Z.t option -> Gas.t shell_tzresult Lwt.t
val pack_data:
'a #RPC_context.simple ->
'a -> Script.expr * Script.expr * Z.t option -> (MBytes.t * Gas.t) shell_tzresult Lwt.t
val run_operation:
'a #RPC_context.simple ->
'a -> packed_operation ->
(packed_protocol_data * Apply_results.packed_operation_metadata) shell_tzresult Lwt.t
end
module Forge : sig
module Manager : sig
val operations:
'a #RPC_context.simple -> 'a ->
branch:Block_hash.t ->
source:Contract.t ->
?sourcePubKey:public_key ->
counter:counter ->
fee:Tez.t ->
gas_limit:Z.t ->
storage_limit:Z.t ->
packed_manager_operation list -> MBytes.t shell_tzresult Lwt.t
val reveal:
'a #RPC_context.simple -> 'a ->
branch:Block_hash.t ->
source:Contract.t ->
sourcePubKey:public_key ->
counter:counter ->
fee:Tez.t ->
unit -> MBytes.t shell_tzresult Lwt.t
val transaction:
'a #RPC_context.simple -> 'a ->
branch:Block_hash.t ->
source:Contract.t ->
?sourcePubKey:public_key ->
counter:counter ->
amount:Tez.t ->
destination:Contract.t ->
?parameters:Script.expr ->
gas_limit:Z.t ->
storage_limit:Z.t ->
fee:Tez.t ->
unit -> MBytes.t shell_tzresult Lwt.t
val origination:
'a #RPC_context.simple -> 'a ->
branch:Block_hash.t ->
source:Contract.t ->
?sourcePubKey:public_key ->
counter:counter ->
managerPubKey:public_key_hash ->
balance:Tez.t ->
?spendable:bool ->
?delegatable:bool ->
?delegatePubKey: public_key_hash ->
?script:Script.t ->
gas_limit:Z.t ->
storage_limit:Z.t ->
fee:Tez.t->
unit -> MBytes.t shell_tzresult Lwt.t
val delegation:
'a #RPC_context.simple -> 'a ->
branch:Block_hash.t ->
source:Contract.t ->
?sourcePubKey:public_key ->
counter:counter ->
fee:Tez.t ->
public_key_hash option ->
MBytes.t shell_tzresult Lwt.t
end
val endorsement:
'a #RPC_context.simple -> 'a ->
branch:Block_hash.t ->
level:Raw_level.t ->
unit -> MBytes.t shell_tzresult Lwt.t
val proposals:
'a #RPC_context.simple -> 'a ->
branch:Block_hash.t ->
source:public_key_hash ->
period:Voting_period.t ->
proposals:Protocol_hash.t list ->
unit -> MBytes.t shell_tzresult Lwt.t
val ballot:
'a #RPC_context.simple -> 'a ->
branch:Block_hash.t ->
source:public_key_hash ->
period:Voting_period.t ->
proposal:Protocol_hash.t ->
ballot:Vote.ballot ->
unit -> MBytes.t shell_tzresult Lwt.t
val seed_nonce_revelation:
'a #RPC_context.simple -> 'a ->
branch:Block_hash.t ->
level:Raw_level.t ->
nonce:Nonce.t ->
unit -> MBytes.t shell_tzresult Lwt.t
val double_baking_evidence:
'a #RPC_context.simple -> 'a ->
branch:Block_hash.t ->
bh1: Block_header.t ->
bh2: Block_header.t ->
unit -> MBytes.t shell_tzresult Lwt.t
val double_endorsement_evidence:
'a #RPC_context.simple -> 'a ->
branch:Block_hash.t ->
op1: Kind.endorsement operation ->
op2: Kind.endorsement operation ->
unit -> MBytes.t shell_tzresult Lwt.t
val protocol_data:
'a #RPC_context.simple -> 'a ->
priority: int ->
?seed_nonce_hash: Nonce_hash.t ->
?proof_of_work_nonce: MBytes.t ->
unit -> MBytes.t shell_tzresult Lwt.t
end
module Parse : sig
val operations:
'a #RPC_context.simple -> 'a ->
?check:bool -> Operation.raw list ->
Operation.packed list shell_tzresult Lwt.t
val block:
'a #RPC_context.simple -> 'a ->
Block_header.shell_header -> MBytes.t ->
Block_header.protocol_data shell_tzresult Lwt.t
end
val register: unit -> unit

51
vendors/ligo-utils/tezos-protocol-alpha/init_storage.ml vendored Normal file
View File

@ -0,0 +1,51 @@
(*****************************************************************************)
(* *)
(* 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. *)
(* *)
(*****************************************************************************)
(* This is the genesis protocol: initialise the state *)
let prepare_first_block ctxt ~typecheck ~level ~timestamp ~fitness =
Raw_context.prepare_first_block
~level ~timestamp ~fitness ctxt >>=? fun (previous_protocol, ctxt) ->
match previous_protocol with
| Genesis param ->
Commitment_storage.init ctxt param.commitments >>=? fun ctxt ->
Roll_storage.init ctxt >>=? fun ctxt ->
Seed_storage.init ctxt >>=? fun ctxt ->
Contract_storage.init ctxt >>=? fun ctxt ->
Bootstrap_storage.init ctxt
~typecheck
?ramp_up_cycles:param.security_deposit_ramp_up_cycles
?no_reward_cycles:param.no_reward_cycles
param.bootstrap_accounts
param.bootstrap_contracts >>=? fun ctxt ->
Roll_storage.init_first_cycles ctxt >>=? fun ctxt ->
Vote_storage.init ctxt >>=? fun ctxt ->
Storage.Last_block_priority.init ctxt 0 >>=? fun ctxt ->
Vote_storage.freeze_listings ctxt >>=? fun ctxt ->
return ctxt
| Alpha_previous ->
return ctxt
let prepare ctxt ~level ~timestamp ~fitness =
Raw_context.prepare ~level ~timestamp ~fitness ctxt

148
vendors/ligo-utils/tezos-protocol-alpha/level_repr.ml vendored Normal file
View File

@ -0,0 +1,148 @@
(*****************************************************************************)
(* *)
(* 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. *)
(* *)
(*****************************************************************************)
type t = {
level: Raw_level_repr.t ;
level_position: int32 ;
cycle: Cycle_repr.t ;
cycle_position: int32 ;
voting_period: Voting_period_repr.t ;
voting_period_position: int32 ;
expected_commitment: bool ;
}
include Compare.Make(struct
type nonrec t = t
let compare { level = l1 } { level = l2 } = Raw_level_repr.compare l1 l2
end)
type level = t
let pp ppf { level } = Raw_level_repr.pp ppf level
let pp_full ppf l =
Format.fprintf ppf
"%a.%ld (cycle %a.%ld) (vote %a.%ld)"
Raw_level_repr.pp l.level l.level_position
Cycle_repr.pp l.cycle l.cycle_position
Voting_period_repr.pp l.voting_period l.voting_period_position
let encoding =
let open Data_encoding in
conv
(fun { level ; level_position ;
cycle ; cycle_position ;
voting_period; voting_period_position ;
expected_commitment } ->
(level, level_position,
cycle, cycle_position,
voting_period, voting_period_position,
expected_commitment))
(fun (level, level_position,
cycle, cycle_position,
voting_period, voting_period_position,
expected_commitment) ->
{ level ; level_position ;
cycle ; cycle_position ;
voting_period ; voting_period_position ;
expected_commitment })
(obj7
(req "level"
~description:
"The level of the block relative to genesis. This is also \
the Shell's notion of level"
Raw_level_repr.encoding)
(req "level_position"
~description:
"The level of the block relative to the block that starts \
protocol alpha. This is specific to the protocol \
alpha. Other protocols might or might not include a \
similar notion."
int32)
(req "cycle"
~description:
"The current cycle's number. Note that cycles are a \
protocol-specific notion. As a result, the cycle number starts at 0 \
with the first block of protocol alpha."
Cycle_repr.encoding)
(req "cycle_position"
~description:
"The current level of the block relative to the first \
block of the current cycle."
int32)
(req "voting_period"
~description:
"The current voting period's index. Note that cycles are a \
protocol-specific notion. As a result, the voting period \
index starts at 0 with the first block of protocol alpha."
Voting_period_repr.encoding)
(req "voting_period_position"
~description:
"The current level of the block relative to the first \
block of the current voting period."
int32)
(req "expected_commitment"
~description:
"Tells wether the baker of this block has to commit a seed \
nonce hash."
bool))
let root first_level =
{ level = first_level ;
level_position = 0l ;
cycle = Cycle_repr.root ;
cycle_position = 0l ;
voting_period = Voting_period_repr.root ;
voting_period_position = 0l ;
expected_commitment = false ;
}
let from_raw
~first_level ~blocks_per_cycle ~blocks_per_voting_period
~blocks_per_commitment
level =
let raw_level = Raw_level_repr.to_int32 level in
let first_level = Raw_level_repr.to_int32 first_level in
let level_position =
Compare.Int32.max 0l (Int32.sub raw_level first_level) in
let cycle =
Cycle_repr.of_int32_exn (Int32.div level_position blocks_per_cycle) in
let cycle_position = Int32.rem level_position blocks_per_cycle in
let voting_period =
Voting_period_repr.of_int32_exn
(Int32.div level_position blocks_per_voting_period) in
let voting_period_position =
Int32.rem level_position blocks_per_voting_period in
let expected_commitment =
Compare.Int32.(Int32.rem cycle_position blocks_per_commitment =
Int32.pred blocks_per_commitment) in
{ level ; level_position ;
cycle ; cycle_position ;
voting_period ; voting_period_position ;
expected_commitment }
let diff { level = l1 ; _ } { level = l2 ; _ } =
Int32.sub (Raw_level_repr.to_int32 l1) (Raw_level_repr.to_int32 l2)

69
vendors/ligo-utils/tezos-protocol-alpha/level_repr.mli vendored Normal file
View File

@ -0,0 +1,69 @@
(*****************************************************************************)
(* *)
(* 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. *)
(* *)
(*****************************************************************************)
type t = private {
level: Raw_level_repr.t (** The level of the block relative to genesis. This
is also the Shell's notion of level. *);
level_position: int32 (** The level of the block relative to the block that
starts protocol alpha. This is specific to the
protocol alpha. Other protocols might or might not
include a similar notion. *);
cycle: Cycle_repr.t (** The current cycle's number. Note that cycles are a
protocol-specific notion. As a result, the cycle
number starts at 0 with the first block of protocol
alpha. *);
cycle_position: int32 (** The current level of the block relative to the first
block of the current cycle. *);
voting_period: Voting_period_repr.t ;
voting_period_position: int32 ;
expected_commitment: bool ;
}
(* Note that, the type `t` above must respect some invariants (hence the
`private` annotation). Notably:
level_position = cycle * blocks_per_cycle + cycle_position
*)
type level = t
include Compare.S with type t := level
val encoding: level Data_encoding.t
val pp: Format.formatter -> level -> unit
val pp_full: Format.formatter -> level -> unit
val root: Raw_level_repr.t -> level
val from_raw:
first_level:Raw_level_repr.t ->
blocks_per_cycle:int32 ->
blocks_per_voting_period:int32 ->
blocks_per_commitment:int32 ->
Raw_level_repr.t -> level
val diff: level -> level -> int32

Some files were not shown because too many files have changed in this diff Show More