From 79472c727a1008a789e0f2f7f07e8f98be223cc1 Mon Sep 17 00:00:00 2001 From: Milo Davis Date: Thu, 14 Dec 2017 16:45:04 +0100 Subject: [PATCH] Michelson: introducing big maps, limited edition Quick and dirty (yet safe, of course) implementation of lazily deserialized maps for storing large collections of indexed data. Only one big_map is allowed, as the left component of the toplevel storage pair. Review and bugfixes: Benjamin Canou --- .../test/contracts/big_map_get_add.tz | 8 + src/bin_client/test/contracts/big_map_mem.tz | 6 + src/bin_client/test/test_contracts.sh | 30 ++- .../lib_client/client_proto_programs.ml | 31 ++- .../lib_client/client_proto_programs.mli | 21 +- .../lib_client/client_proto_rpcs.mli | 5 +- .../lib_client/michelson_v1_error_reporter.ml | 5 + src/proto_alpha/lib_protocol/src/apply.ml | 29 +- .../lib_protocol/src/contract_storage.ml | 22 +- .../lib_protocol/src/contract_storage.mli | 18 +- src/proto_alpha/lib_protocol/src/gas.ml | 4 + src/proto_alpha/lib_protocol/src/gas.mli | 3 + .../src/michelson_v1_primitives.ml | 4 + .../src/michelson_v1_primitives.mli | 1 + .../lib_protocol/src/script_interpreter.ml | 53 +++- .../lib_protocol/src/script_interpreter.mli | 5 +- .../lib_protocol/src/script_ir_translator.ml | 250 +++++++++++++----- .../lib_protocol/src/script_ir_translator.mli | 20 +- .../lib_protocol/src/script_tc_errors.ml | 1 + .../src/script_tc_errors_registration.ml | 14 +- .../lib_protocol/src/script_typed_ir.ml | 18 +- src/proto_alpha/lib_protocol/src/services.ml | 12 +- .../lib_protocol/src/services_registration.ml | 10 +- src/proto_alpha/lib_protocol/src/storage.ml | 21 ++ src/proto_alpha/lib_protocol/src/storage.mli | 7 + .../lib_protocol/src/tezos_context.ml | 8 + .../lib_protocol/src/tezos_context.mli | 15 +- .../test/helpers/helpers_script.mli | 2 +- src/proto_alpha/lib_protocol/test/jbuild | 2 + .../lib_protocol/test/test_michelson.ml | 18 +- 30 files changed, 511 insertions(+), 132 deletions(-) create mode 100644 src/bin_client/test/contracts/big_map_get_add.tz create mode 100644 src/bin_client/test/contracts/big_map_mem.tz diff --git a/src/bin_client/test/contracts/big_map_get_add.tz b/src/bin_client/test/contracts/big_map_get_add.tz new file mode 100644 index 000000000..e4f736c83 --- /dev/null +++ b/src/bin_client/test/contracts/big_map_get_add.tz @@ -0,0 +1,8 @@ +parameter (pair (pair @set_pair int (option int)) (pair @check_pair int (option int))) ; +storage (pair (big_map int int) unit) ; +return unit ; +code { DUP ; DIP { CDAR } ; + DUP ; DIP { CADR; DUP ; CAR ; DIP { CDR } ; UPDATE ; DUP } ; + CADR ; DUP ; CDR ; DIP { CAR ; GET } ; + IF_SOME { SWAP ; IF_SOME { ASSERT_CMPEQ } {FAIL}} { ASSERT_NONE } ; + UNIT ; SWAP ; PAIR ; UNIT ; PAIR } diff --git a/src/bin_client/test/contracts/big_map_mem.tz b/src/bin_client/test/contracts/big_map_mem.tz new file mode 100644 index 000000000..015819626 --- /dev/null +++ b/src/bin_client/test/contracts/big_map_mem.tz @@ -0,0 +1,6 @@ +# Fails if the boolean does not match the membership criteria +parameter (pair int bool) ; +storage (pair (big_map int unit) unit) ; +return unit ; +code { DUP ; DUP ; CADR ; DIP { CAAR ; DIP { CDAR ; DUP } ; MEM } ; + ASSERT_CMPEQ ; UNIT ; SWAP ; PAIR ; UNIT ; PAIR } diff --git a/src/bin_client/test/test_contracts.sh b/src/bin_client/test/test_contracts.sh index 1c65d9295..d48e69b4e 100755 --- a/src/bin_client/test/test_contracts.sh +++ b/src/bin_client/test/test_contracts.sh @@ -405,12 +405,13 @@ init_with_transfer $contract_dir/self.tz $key1 \ $client transfer 0 from bootstrap1 to self assert_storage_contains self "\"$(get_contract_addr self)\"" - +# Test sets and map literals assert_fails $client typecheck data '{ Elt 0 1 ; Elt 0 1 }' against type '(map nat nat)' assert_fails $client typecheck data '{ Elt 0 1 ; Elt 10 1 ; Elt 5 1 }' against type '(map nat nat)' assert_fails $client typecheck data '{ "A" ; "C" ; "B" }' against type '(set string)' assert_fails $client typecheck data '{ "A" ; "B" ; "B" }' against type '(set string)' +# Test hash consistency between Michelson and the CLI hash_result=`$client hash data '(Pair "22220.00" (Pair "2017-12-13T04:49:00Z" 034))' \ of type '(pair tez (pair timestamp int))'` @@ -420,6 +421,33 @@ assert_output $contract_dir/hash_consistency_checker.tz Unit \ assert_output $contract_dir/hash_consistency_checker.tz Unit \ '(Pair "22,220" (Pair "2017-12-13T04:49:00+00:00" 34))' "$hash_result" +# Test for big maps +init_with_transfer $contract_dir/big_map_mem.tz $key1\ + '(Pair { Elt 1 Unit ; Elt 2 Unit ; Elt 3 Unit } Unit)' \ + 100 bootstrap1 +$client transfer 1 from bootstrap1 to big_map_mem -arg '(Pair 0 False)' +assert_fails $client transfer 1 from bootstrap1 to big_map_mem -arg '(Pair 0 True)' +$client transfer 1 from bootstrap1 to big_map_mem -arg '(Pair 1 True)' +assert_fails $client transfer 1 from bootstrap1 to big_map_mem -arg '(Pair 1 False)' +$client transfer 1 from bootstrap1 to big_map_mem -arg '(Pair 2 True)' +assert_fails $client transfer 1 from bootstrap1 to big_map_mem -arg '(Pair 2 False)' +$client transfer 1 from bootstrap1 to big_map_mem -arg '(Pair 3 True)' +assert_fails $client transfer 1 from bootstrap1 to big_map_mem -arg '(Pair 3 False)' +$client transfer 1 from bootstrap1 to big_map_mem -arg '(Pair 4 False)' +assert_fails $client transfer 1 from bootstrap1 to big_map_mem -arg '(Pair 4 True)' + +init_with_transfer $contract_dir/big_map_get_add.tz $key1\ + '(Pair { Elt 0 1 ; Elt 1 2 ; Elt 2 3 } Unit)' \ + 100 bootstrap1 + +$client transfer 1 from bootstrap1 to big_map_get_add -arg '(Pair (Pair 200 (Some 2)) (Pair 200 (Some 2)))' +$client transfer 1 from bootstrap1 to big_map_get_add -arg '(Pair (Pair 200 None) (Pair 200 None))' +$client transfer 1 from bootstrap1 to big_map_get_add -arg '(Pair (Pair 200 None) (Pair 300 None))' +$client transfer 1 from bootstrap1 to big_map_get_add -arg '(Pair (Pair 1 None) (Pair 200 None))' +$client transfer 1 from bootstrap1 to big_map_get_add -arg '(Pair (Pair 1 (Some 2)) (Pair 0 (Some 1)))' +$client transfer 1 from bootstrap1 to big_map_get_add -arg '(Pair (Pair 400 (Some 1232)) (Pair 400 (Some 1232)))' +$client transfer 1 from bootstrap1 to big_map_get_add -arg '(Pair (Pair 401 (Some 0)) (Pair 400 (Some 1232)))' + printf "\nEnd of test\n" show_logs="no" diff --git a/src/proto_alpha/lib_client/client_proto_programs.ml b/src/proto_alpha/lib_client/client_proto_programs.ml index 40b4e7c6c..99aec5d67 100644 --- a/src/proto_alpha/lib_client/client_proto_programs.ml +++ b/src/proto_alpha/lib_client/client_proto_programs.ml @@ -35,23 +35,44 @@ let print_errors (cctxt : #Client_commands.logger) errs ~show_source ~parsed = cctxt#error "error running program" >>= fun () -> return () +let print_big_map_diff ppf = function + | None -> () + | Some diff -> + Format.fprintf ppf + "@[map diff:@,%a@]@," + (Format.pp_print_list + ~pp_sep:Format.pp_print_space + (fun ppf (key, value) -> + Format.fprintf ppf "%s %a%a" + (match value with + | None -> "-" + | Some _ -> "+") + print_expr key + (fun ppf -> function + | None -> () + | Some x -> Format.fprintf ppf "-> %a" print_expr x) + value)) + diff + let print_run_result (cctxt : #Client_commands.logger) ~show_source ~parsed = function - | Ok (storage, output) -> - cctxt#message "@[@[storage@,%a@]@,@[output@,%a@]@]@." + | Ok (storage, output, maybe_diff) -> + cctxt#message "@[@[storage@,%a@]@,@[output@,%a@]@,@[%a@]@]@." print_expr storage - print_expr output >>= fun () -> + print_expr output + print_big_map_diff maybe_diff >>= fun () -> return () | Error errs -> print_errors cctxt errs ~show_source ~parsed let print_trace_result (cctxt : #Client_commands.logger) ~show_source ~parsed = function - | Ok (storage, output, trace) -> + | Ok (storage, output, trace, maybe_big_map_diff) -> cctxt#message "@[@[storage@,%a@]@,\ - @[output@,%a@]@,@[trace@,%a@]@]@." + @[output@,%a@]@,%a@[@[trace@,%a@]@]@." print_expr storage print_expr output + print_big_map_diff maybe_big_map_diff (Format.pp_print_list (fun ppf (loc, gas, stack) -> Format.fprintf ppf diff --git a/src/proto_alpha/lib_client/client_proto_programs.mli b/src/proto_alpha/lib_client/client_proto_programs.mli index 9a4734936..2003349a5 100644 --- a/src/proto_alpha/lib_client/client_proto_programs.mli +++ b/src/proto_alpha/lib_client/client_proto_programs.mli @@ -21,7 +21,7 @@ val run : input:Michelson_v1_parser.parsed -> Client_rpcs.block -> #Client_rpcs.ctxt -> - (Script.expr * Script.expr) tzresult Lwt.t + (Script.expr * Script.expr * (Script.expr * Script.expr option) list option) tzresult Lwt.t val trace : ?amount:Tez.t -> @@ -30,23 +30,24 @@ val trace : input:Michelson_v1_parser.parsed -> Client_rpcs.block -> #Client_rpcs.ctxt -> - (Script.expr * Script.expr * (int * Gas.t * Script.expr list) list) tzresult Lwt.t + (Script.expr * Script.expr * (int * Gas.t * Script.expr list) list * (Script.expr * Script.expr option) list option) tzresult Lwt.t + +val print_run_result : + #Client_commands.logger -> + show_source:bool -> + parsed:Michelson_v1_parser.parsed -> + (Script_repr.expr * Script_repr.expr * + (Script_repr.expr * Script_repr.expr option) list option) tzresult -> unit tzresult Lwt.t val print_trace_result : #Client_commands.logger -> show_source:bool -> parsed:Michelson_v1_parser.parsed -> (Script_repr.expr * Script_repr.expr * - (int * Gas.t * Script_repr.expr list) list) + (int * Gas.t * Script_repr.expr list) list * + (Script_repr.expr * Script_repr.expr option) list option) tzresult -> unit tzresult Lwt.t -val print_run_result : - #Client_commands.logger -> - show_source:bool -> - parsed:Michelson_v1_parser.parsed -> - (Script.expr * Script.expr) tzresult -> - unit tzresult Lwt.t - val hash_and_sign : Michelson_v1_parser.parsed -> Michelson_v1_parser.parsed -> diff --git a/src/proto_alpha/lib_client/client_proto_rpcs.mli b/src/proto_alpha/lib_client/client_proto_rpcs.mli index 2d12cdcfd..f6deb6251 100644 --- a/src/proto_alpha/lib_client/client_proto_rpcs.mli +++ b/src/proto_alpha/lib_client/client_proto_rpcs.mli @@ -160,13 +160,14 @@ module Helpers : sig #Client_rpcs.ctxt -> block -> Script.expr -> (Script.expr * Script.expr * Tez.t) -> - (Script.expr * Script.expr) tzresult Lwt.t + (Script.expr * Script.expr * (Script.expr * Script.expr option) list option) tzresult Lwt.t val trace_code: #Client_rpcs.ctxt -> block -> Script.expr -> (Script.expr * Script.expr * Tez.t) -> (Script.expr * Script.expr * - (Script.location * Gas.t * Script.expr list) list) tzresult Lwt.t + (Script.location * Gas.t * Script.expr list) list * + (Script.expr * Script.expr option) list option) tzresult Lwt.t val typecheck_code: #Client_rpcs.ctxt -> block -> Script.expr -> Script_tc_errors.type_map tzresult Lwt.t diff --git a/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml b/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml index 2151ca645..494c1e7ba 100644 --- a/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml +++ b/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml @@ -66,6 +66,7 @@ let collect_error_locations errs = | Invalid_primitive (loc, _, _) | Invalid_kind (loc, _, _) | Duplicate_field (loc, _) + | Unexpected_big_map loc | Fail_not_in_tail_position loc | Undefined_binop (loc, _, _, _) | Undefined_unop (loc, _, _) @@ -167,6 +168,10 @@ let report_errors ~details ~show_source ?parsed ppf errs = print_loc loc (Michelson_v1_primitives.string_of_prim prim) ; print_trace locations rest + | Unexpected_big_map loc :: rest -> + Format.fprintf ppf "%abig_map type only allowed on the left of the toplevel storage pair" + print_loc loc ; + print_trace locations rest | Runtime_contract_error (contract, expr) :: rest -> let parsed = match parsed with diff --git a/src/proto_alpha/lib_protocol/src/apply.ml b/src/proto_alpha/lib_protocol/src/apply.ml index 707049f3c..ec0d8f5ae 100644 --- a/src/proto_alpha/lib_protocol/src/apply.ml +++ b/src/proto_alpha/lib_protocol/src/apply.ml @@ -135,12 +135,17 @@ let apply_manager_operation_content source destination ctxt script amount argument (Gas.of_int (Constants.max_gas ctxt)) >>= function - | Ok (storage_res, _res, _steps, ctxt, origination_nonce) -> + | Ok (storage_res, _res, _steps, ctxt, origination_nonce, maybe_big_map_diff) -> (* TODO: pay for the steps and the storage diff: update_script_storage checks the storage cost *) Contract.update_script_storage_and_fees ctxt destination - Script_interpreter.dummy_storage_fee storage_res >>=? fun ctxt -> + Script_interpreter.dummy_storage_fee + storage_res + (match maybe_big_map_diff with + | None -> None + | Some map -> + Some (Script_ir_translator.to_serializable_big_map map)) >>=? fun ctxt -> return (ctxt, origination_nonce, None) | Error err -> return (ctxt, origination_nonce, Some err) in @@ -161,18 +166,30 @@ let apply_manager_operation_content | Origination { manager ; delegate ; script ; spendable ; delegatable ; credit } -> begin match script with - | None -> return None + | None -> return (None, None) | Some script -> Script_ir_translator.parse_script ctxt script >>=? fun _ -> - return (Some (script, (Script_interpreter.dummy_code_fee, Script_interpreter.dummy_storage_fee))) - end >>=? fun script -> + Script_ir_translator.erase_big_map_initialization ctxt script >>=? fun (script, big_map_diff) -> + return (Some (script, (Script_interpreter.dummy_code_fee, Script_interpreter.dummy_storage_fee)), + big_map_diff) + end >>=? fun (script, big_map) -> Contract.spend ctxt source Constants.origination_burn >>=? fun ctxt -> Contract.spend ctxt source credit >>=? fun ctxt -> Contract.originate ctxt origination_nonce ~manager ~delegate ~balance:credit ?script - ~spendable ~delegatable >>=? fun (ctxt, _, origination_nonce) -> + ~spendable ~delegatable >>=? fun (ctxt, contract, origination_nonce) -> + begin match big_map with + | None -> return ctxt + | Some diff -> + fold_left_s (fun ctxt (key, value) -> + match value with + | None -> Contract.Big_map_storage.remove ctxt contract key + | Some v -> + Contract.Big_map_storage.set ctxt contract key v) + ctxt diff + end >>=? fun ctxt -> return (ctxt, origination_nonce, None) | Delegation delegate -> Contract.set_delegate ctxt source delegate >>=? fun ctxt -> diff --git a/src/proto_alpha/lib_protocol/src/contract_storage.ml b/src/proto_alpha/lib_protocol/src/contract_storage.ml index 65794c5a5..8492ff4d4 100644 --- a/src/proto_alpha/lib_protocol/src/contract_storage.ml +++ b/src/proto_alpha/lib_protocol/src/contract_storage.ml @@ -237,6 +237,7 @@ let delete c contract = Storage.Contract.Storage.remove c contract >>= fun c -> Storage.Contract.Code_fees.remove c contract >>= fun c -> Storage.Contract.Storage_fees.remove c contract >>= fun c -> + Storage.Contract.Big_map.clear (c, contract) >>= fun c -> return c let exists c contract = @@ -372,7 +373,9 @@ let contract_fee c contract = Lwt.return Tez_repr.(code_fees +? storage_fees) >>=? fun script_fees -> Lwt.return Tez_repr.(Constants_repr.minimal_contract_balance +? script_fees) -let update_script_storage_and_fees c contract storage_fees storage = +type big_map_diff = (string * Script_repr.expr option) list + +let update_script_storage_and_fees c contract storage_fees storage big_map = Storage.Contract.Balance.get_option c contract >>=? function | None -> (* The contract was destroyed *) @@ -382,6 +385,16 @@ let update_script_storage_and_fees c contract storage_fees storage = contract_fee c contract >>=? fun fee -> fail_unless Tez_repr.(balance > fee) (Cannot_pay_storage_fee (contract, balance, fee)) >>=? fun () -> + begin match big_map with + | None -> return c + | Some diff -> + fold_left_s (fun c (key, value) -> + match value with + | None -> Storage.Contract.Big_map.remove (c, contract) key >>= return + | Some v -> + Storage.Contract.Big_map.init_set (c, contract) key v >>= return) + c diff + end >>=? fun c -> Storage.Contract.Storage.set c contract storage let spend_from_script c contract amount = @@ -432,3 +445,10 @@ let originate c nonce ~balance ~manager ?script ~delegate ~spendable ~delegatabl let init c = Storage.Contract.Global_counter.init c 0l + +module Big_map = struct + let set handle key value = Storage.Contract.Big_map.init_set handle key value >>= return + let remove = Storage.Contract.Big_map.delete + let mem = Storage.Contract.Big_map.mem + let get_opt = Storage.Contract.Big_map.get_option +end diff --git a/src/proto_alpha/lib_protocol/src/contract_storage.mli b/src/proto_alpha/lib_protocol/src/contract_storage.mli index 740b2cf6a..f8d9de194 100644 --- a/src/proto_alpha/lib_protocol/src/contract_storage.mli +++ b/src/proto_alpha/lib_protocol/src/contract_storage.mli @@ -46,7 +46,12 @@ val get_counter: Raw_context.t -> Contract_repr.t -> int32 tzresult Lwt.t val get_script: Raw_context.t -> Contract_repr.t -> Script_repr.t option tzresult Lwt.t val get_storage: Raw_context.t -> Contract_repr.t -> Script_repr.expr option tzresult Lwt.t -val update_script_storage_and_fees: Raw_context.t -> Contract_repr.t -> Tez_repr.t -> Script_repr.expr -> Raw_context.t tzresult Lwt.t +type big_map_diff = (string * Script_repr.expr option) list + +val update_script_storage_and_fees: + Raw_context.t -> Contract_repr.t -> Tez_repr.t -> Script_repr.expr -> + big_map_diff option -> + Raw_context.t tzresult Lwt.t (** fails if the contract is not delegatable *) val set_delegate : Raw_context.t -> Contract_repr.t -> Ed25519.Public_key_hash.t option -> Raw_context.t tzresult Lwt.t @@ -72,3 +77,14 @@ val originate : val init : Raw_context.t -> Raw_context.t tzresult Lwt.t + +module Big_map : sig + val set : + Storage.Contract.bigmap_key -> + string -> Script_repr.expr -> Raw_context.t tzresult Lwt.t + val remove : + Storage.Contract.bigmap_key -> string -> Raw_context.t tzresult Lwt.t + val mem : Storage.Contract.bigmap_key -> string -> bool Lwt.t + val get_opt : + Storage.Contract.bigmap_key -> string -> Script_repr.expr option tzresult Lwt.t +end diff --git a/src/proto_alpha/lib_protocol/src/gas.ml b/src/proto_alpha/lib_protocol/src/gas.ml index b4fa2761d..4d7ea17a4 100644 --- a/src/proto_alpha/lib_protocol/src/gas.ml +++ b/src/proto_alpha/lib_protocol/src/gas.ml @@ -149,6 +149,10 @@ module Cost_of = struct let map_size = step_cost 2 + let big_map_mem _key _map = step_cost 200 + let big_map_get _key _map = step_cost 200 + let big_map_update _key _value _map = step_cost 200 + let set_access : type elt. elt -> elt Script_typed_ir.set -> int = fun _key (module Box) -> log2 @@ Box.size diff --git a/src/proto_alpha/lib_protocol/src/gas.mli b/src/proto_alpha/lib_protocol/src/gas.mli index 3441e4b54..3695bfa5f 100644 --- a/src/proto_alpha/lib_protocol/src/gas.mli +++ b/src/proto_alpha/lib_protocol/src/gas.mli @@ -48,6 +48,9 @@ module Cost_of : sig val map_update : 'a -> 'b -> ('c, 'd) Script_typed_ir.map -> cost val map_size : cost + val big_map_mem : 'key -> ('key, 'value) Script_typed_ir.big_map -> cost + val big_map_get : 'key -> ('key, 'value) Script_typed_ir.big_map -> cost + val big_map_update : 'key -> 'value option -> ('key, 'value) Script_typed_ir.big_map -> cost val set_to_list : 'a Script_typed_ir.set -> cost val set_update : 'a -> 'b -> 'a Script_typed_ir.set -> cost val set_mem : 'a -> 'a Script_typed_ir.set -> cost diff --git a/src/proto_alpha/lib_protocol/src/michelson_v1_primitives.ml b/src/proto_alpha/lib_protocol/src/michelson_v1_primitives.ml index ec4ab7a81..a5b4b523a 100644 --- a/src/proto_alpha/lib_protocol/src/michelson_v1_primitives.ml +++ b/src/proto_alpha/lib_protocol/src/michelson_v1_primitives.ml @@ -103,6 +103,7 @@ type prim = | T_lambda | T_list | T_map + | T_big_map | T_nat | T_option | T_or @@ -223,6 +224,7 @@ let string_of_prim = function | T_lambda -> "lambda" | T_list -> "list" | T_map -> "map" + | T_big_map -> "big_map" | T_nat -> "nat" | T_option -> "option" | T_or -> "or" @@ -324,6 +326,7 @@ let prim_of_string = function | "lambda" -> ok T_lambda | "list" -> ok T_list | "map" -> ok T_map + | "big_map" -> ok T_big_map | "nat" -> ok T_nat | "option" -> ok T_option | "or" -> ok T_or @@ -469,6 +472,7 @@ let prim_encoding = ("lambda", T_lambda) ; ("list", T_list) ; ("map", T_map) ; + ("big_map", T_big_map) ; ("nat", T_nat) ; ("option", T_option) ; ("or", T_or) ; diff --git a/src/proto_alpha/lib_protocol/src/michelson_v1_primitives.mli b/src/proto_alpha/lib_protocol/src/michelson_v1_primitives.mli index 9c50b3c59..84c82959c 100644 --- a/src/proto_alpha/lib_protocol/src/michelson_v1_primitives.mli +++ b/src/proto_alpha/lib_protocol/src/michelson_v1_primitives.mli @@ -101,6 +101,7 @@ type prim = | T_lambda | T_list | T_map + | T_big_map | T_nat | T_option | T_or diff --git a/src/proto_alpha/lib_protocol/src/script_interpreter.ml b/src/proto_alpha/lib_protocol/src/script_interpreter.ml index 17f48cc1b..15c3c4505 100644 --- a/src/proto_alpha/lib_protocol/src/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/src/script_interpreter.ml @@ -392,6 +392,21 @@ let rec interp gas_check_terop descr (map_update, k, v, map) Gas.Cost_of.map_update rest | Map_size, Item (map, rest) -> gas_check_unop descr (map_size, map) (fun _ -> Gas.Cost_of.map_size) rest ctxt + (* Big map operations *) + | Big_map_mem, Item (key, Item (map, rest)) -> + let gas = Gas.consume gas (Gas.Cost_of.big_map_mem key map) in + Gas.check gas >>=? fun () -> + Script_ir_translator.big_map_mem ctxt source key map >>= fun res -> + logged_return (Item (res, rest), gas, ctxt) + | Big_map_get, Item (key, Item (map, rest)) -> + let gas = Gas.consume gas (Gas.Cost_of.big_map_get key map) in + Gas.check gas >>=? fun () -> + Script_ir_translator.big_map_get ctxt source key map >>=? fun res -> + logged_return (Item (res, rest), gas, ctxt) + | Big_map_update, Item (key, Item (maybe_value, Item (map, rest))) -> + gas_check_terop descr + (Script_ir_translator.big_map_update, key, maybe_value, map) + Gas.Cost_of.big_map_update rest (* timestamp operations *) | Add_seconds_to_timestamp, Item (n, Item (t, rest)) -> gas_check_binop descr @@ -633,14 +648,16 @@ let rec interp Contract.get_manager ctxt contract >>=? fun manager -> logged_return (Item (manager, rest), gas, ctxt) | Transfer_tokens storage_type, - Item (p, Item (amount, Item ((tp, Unit_t, destination), Item (sto, Empty)))) -> begin + Item (p, Item (amount, Item ((tp, Unit_t, destination), Item (storage, Empty)))) -> begin let gas = Gas.consume gas Gas.Cost_of.transfer in Gas.check gas >>=? fun () -> Contract.spend_from_script ctxt source amount >>=? fun ctxt -> Contract.credit ctxt destination amount >>=? fun ctxt -> Contract.get_script ctxt destination >>=? fun destination_script -> - let sto = Micheline.strip_locations (unparse_data storage_type sto) in - Contract.update_script_storage_and_fees ctxt source dummy_storage_fee sto >>=? fun ctxt -> + let sto = Micheline.strip_locations (unparse_data storage_type storage) in + Contract.update_script_storage_and_fees ctxt source dummy_storage_fee sto + (Option.map ~f:Script_ir_translator.to_serializable_big_map + (Script_ir_translator.extract_big_map storage_type storage)) >>=? fun ctxt -> begin match destination_script with | None -> (* we see non scripted contracts as (unit, unit) contract *) @@ -650,8 +667,9 @@ let rec interp | Some script -> let p = unparse_data tp p in execute origination source destination ctxt script amount p gas - >>=? fun (csto, ret, gas, ctxt, origination) -> - Contract.update_script_storage_and_fees ctxt destination dummy_storage_fee csto >>=? fun ctxt -> + >>=? fun (csto, ret, gas, ctxt, origination, maybe_diff) -> + Contract.update_script_storage_and_fees ctxt destination dummy_storage_fee csto + (Option.map ~f:Script_ir_translator.to_serializable_big_map maybe_diff) >>=? fun ctxt -> trace (Invalid_contract (loc, destination)) (parse_data ctxt Unit_t ret) >>=? fun () -> @@ -672,12 +690,16 @@ let rec interp Contract.get_script ctxt destination >>=? function | None -> fail (Invalid_contract (loc, destination)) | Some script -> + let maybe_diff = Script_ir_translator.( + Option.map ~f:to_serializable_big_map + @@ extract_big_map storage_type sto) in let sto = Micheline.strip_locations (unparse_data storage_type sto) in - Contract.update_script_storage_and_fees ctxt source dummy_storage_fee sto >>=? fun ctxt -> + Contract.update_script_storage_and_fees ctxt source dummy_storage_fee sto maybe_diff >>=? fun ctxt -> let p = unparse_data tp p in execute origination source destination ctxt script amount p gas - >>=? fun (sto, ret, gas, ctxt, origination) -> - Contract.update_script_storage_and_fees ctxt destination dummy_storage_fee sto >>=? fun ctxt -> + >>=? fun (sto, ret, gas, ctxt, origination, maybe_diff) -> + Contract.update_script_storage_and_fees ctxt destination dummy_storage_fee sto + (Option.map ~f:Script_ir_translator.to_serializable_big_map maybe_diff) >>=? fun ctxt -> trace (Invalid_contract (loc, destination)) (parse_data ctxt tr ret) >>=? fun v -> @@ -771,7 +793,9 @@ let rec interp (* ---- contract handling ---------------------------------------------------*) -and execute ?log origination orig source ctxt script amount arg gas = +and execute ?log origination orig source ctxt script amount arg gas : + (Script.expr * Script.node * Gas.t * context * Contract.origination_nonce * + Script_typed_ir.ex_big_map option) tzresult Lwt.t = parse_script ctxt script >>=? fun (Ex_script { code; arg_type; ret_type; storage; storage_type }) -> parse_data ctxt arg_type arg >>=? fun arg -> @@ -781,15 +805,16 @@ and execute ?log origination orig source ctxt script amount arg gas = >>=? fun ((ret, storage), gas, ctxt, origination) -> return (Micheline.strip_locations (unparse_data storage_type storage), unparse_data ret_type ret, - gas, ctxt, origination) + gas, ctxt, origination, + Script_ir_translator.extract_big_map storage_type storage) let trace origination orig source ctxt script amount arg gas = let log = ref [] in execute ~log origination orig source ctxt script amount (Micheline.root arg) gas - >>=? fun (sto, res, gas, ctxt, origination) -> - return ((sto, Micheline.strip_locations res, gas, ctxt, origination), List.rev !log) + >>=? fun (sto, res, gas, ctxt, origination, maybe_big_map) -> + return ((sto, Micheline.strip_locations res, gas, ctxt, origination, maybe_big_map), List.rev !log) let execute origination orig source ctxt script amount arg gas = execute origination orig source ctxt script amount (Micheline.root arg) gas - >>=? fun (sto, res, gas, ctxt, origination) -> - return (sto, Micheline.strip_locations res, gas, ctxt, origination) + >>=? fun (sto, res, gas, ctxt, origination, maybe_big_map) -> + return (sto, Micheline.strip_locations res, gas, ctxt, origination, maybe_big_map) diff --git a/src/proto_alpha/lib_protocol/src/script_interpreter.mli b/src/proto_alpha/lib_protocol/src/script_interpreter.mli index cd1f03741..e1964ee3f 100644 --- a/src/proto_alpha/lib_protocol/src/script_interpreter.mli +++ b/src/proto_alpha/lib_protocol/src/script_interpreter.mli @@ -21,12 +21,13 @@ val execute: Contract.t -> Contract.t -> Tezos_context.t -> Script.t -> Tez.t -> Script.expr -> Gas.t -> - (Script.expr * Script.expr * Gas.t * context * Contract.origination_nonce) tzresult Lwt.t + (Script.expr * Script.expr * Gas.t * context * Contract.origination_nonce * + Script_typed_ir.ex_big_map option) tzresult Lwt.t val trace: Contract.origination_nonce -> Contract.t -> Contract.t -> Tezos_context.t -> Script.t -> Tez.t -> Script.expr -> Gas.t -> - ((Script.expr * Script.expr * Gas.t * context * Contract.origination_nonce) * + ((Script.expr * Script.expr * Gas.t * context * Contract.origination_nonce * Script_typed_ir.ex_big_map option) * (Script.location * Gas.t * Script.expr list) list) tzresult Lwt.t diff --git a/src/proto_alpha/lib_protocol/src/script_ir_translator.ml b/src/proto_alpha/lib_protocol/src/script_ir_translator.ml index 6bcdc2b04..499a1859c 100644 --- a/src/proto_alpha/lib_protocol/src/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/src/script_ir_translator.ml @@ -74,6 +74,8 @@ let rec type_size : type t. t ty -> int = function 1 + comparable_type_size k | Map_t (k, v) -> 1 + comparable_type_size k + type_size v + | Big_map_t (k, v) -> + 1 + comparable_type_size k + type_size v | Contract_t (arg, ret) -> 1 + type_size arg + type_size ret @@ -130,6 +132,9 @@ let number_of_generated_growing_types : type b a. (b, a) instr -> int = function | Map_get -> 0 | Map_update -> 0 | Map_size -> 0 + | Big_map_get -> 0 + | Big_map_update -> 0 + | Big_map_mem -> 0 | Concat -> 0 | Add_seconds_to_timestamp -> 0 | Add_timestamp_to_seconds -> 0 @@ -305,6 +310,7 @@ let namespace = function | T_lambda | T_list | T_map + | T_big_map | T_nat | T_option | T_or @@ -447,6 +453,19 @@ let map_update | None -> (Box.OPS.remove k map, size - if contains then 1 else 0) end) +let map_set + : type a b. a -> b -> (a, b) map -> (a, b) map + = fun k v (module Box) -> + (module struct + type key = a + type value = b + let key_ty = Box.key_ty + module OPS = Box.OPS + let boxed = + let (map, size) = Box.boxed in + (Box.OPS.add k v map, if Box.OPS.mem k map then size else size + 1) + end) + let map_mem : type key value. key -> (key, value) map -> bool = fun k (module Box) -> @@ -526,6 +545,10 @@ let rec unparse_ty let ta = unparse_comparable_ty uta in let tr = unparse_ty None utr in Prim (-1, T_map, [ ta; tr ], None) + | Big_map_t (uta, utr) -> + let ta = unparse_comparable_ty uta in + let tr = unparse_ty None utr in + Prim (-1, T_big_map, [ ta; tr ], None) let rec unparse_data : type a. a ty -> a -> Script.node @@ -598,6 +621,8 @@ let rec unparse_data :: acc) map [] in Seq (-1, List.rev items, None) + | Big_map_t (_kt, _kv), _map -> + Seq (-1, [], None) | Lambda_t _, Lam (_, original_code) -> root original_code @@ -638,6 +663,11 @@ let rec ty_eq ty_eq tar tbr >>? fun Eq -> (Ok Eq : (ta ty, tb ty) eq tzresult)) |> record_trace (Inconsistent_types (ta, tb)) + | Big_map_t (tal, tar), Big_map_t (tbl, tbr) -> + (comparable_ty_eq tal tbl >>? fun Eq -> + ty_eq tar tbr >>? fun Eq -> + (Ok Eq : (ta ty, tb ty) eq tzresult)) |> + record_trace (Inconsistent_types (ta, tb)) | Set_t ea, Set_t eb -> (comparable_ty_eq ea eb >>? fun Eq -> (Ok Eq : (ta ty, tb ty) eq tzresult)) |> @@ -742,6 +772,10 @@ let merge_types : help tar tbr >>? fun value -> ty_eq tar value >>? fun Eq -> ok (Map_t (merge_comparable_types tal tbl, value)) + | Big_map_t (tal, tar), Big_map_t (tbl, tbr) -> + help tar tbr >>? fun value -> + ty_eq tar value >>? fun Eq -> + ok (Big_map_t (merge_comparable_types tal tbl, value)) | Set_t ea, Set_t eb -> ok (Set_t (merge_comparable_types ea eb)) | Pair_t ((tal, left_annot1), (tar, right_annot1)), @@ -842,7 +876,7 @@ let rec parse_comparable_ty : Script.node -> ex_comparable_ty tzresult = functio | Prim (loc, (T_pair | T_or | T_set | T_map | T_list | T_option | T_lambda | T_unit | T_signature | T_contract), _, _) as expr -> - parse_ty expr >>? fun (Ex_ty ty, _) -> + parse_ty false expr >>? fun (Ex_ty ty, _) -> error (Comparable_type_expected (loc, ty)) | expr -> error @@ unexpected expr [] Type_namespace @@ -850,7 +884,21 @@ let rec parse_comparable_ty : Script.node -> ex_comparable_ty tzresult = functio T_string ; T_tez ; T_bool ; T_key ; T_key_hash ; T_timestamp ] -and parse_ty : Script.node -> (ex_ty * annot) tzresult = function +and parse_ty : bool -> Script.node -> (ex_ty * annot) tzresult = fun big_map_possible -> function + | Prim (_, T_pair, [ + Prim (big_map_loc, T_big_map, args, map_annot) ; + remaining_storage ], storage_annot) + when big_map_possible -> + begin match args with + | [ key_ty ; value_ty ] -> + parse_comparable_ty key_ty >>? fun (Ex_comparable_ty key_ty) -> + parse_ty false value_ty >>? fun (Ex_ty value_ty, right_annot) -> + error_unexpected_annot big_map_loc right_annot >>? fun () -> + parse_ty false remaining_storage >>? fun (Ex_ty remaining_storage, remaining_annot) -> + ok (Ex_ty (Pair_t ((Big_map_t (key_ty, value_ty), map_annot), (remaining_storage, remaining_annot))), + storage_annot) + | args -> error @@ Invalid_arity (big_map_loc, T_big_map, 2, List.length args) + end | Prim (_, T_unit, [], annot) -> ok (Ex_ty Unit_t, annot) | Prim (_, T_int, [], annot) -> ok (Ex_ty (Int_t), annot) | Prim (_, T_nat, [], annot) -> ok (Ex_ty (Nat_t), annot) @@ -862,29 +910,29 @@ and parse_ty : Script.node -> (ex_ty * annot) tzresult = function | Prim (_, T_timestamp, [], annot) -> ok (Ex_ty Timestamp_t, annot) | Prim (_, T_signature, [], annot) -> ok (Ex_ty Signature_t, annot) | Prim (loc, T_contract, [ utl; utr ], annot) -> - parse_ty utl >>? fun (Ex_ty tl, left_annot) -> - parse_ty utr >>? fun (Ex_ty tr, right_annot) -> + parse_ty false utl >>? fun (Ex_ty tl, left_annot) -> + parse_ty false utr >>? fun (Ex_ty tr, right_annot) -> error_unexpected_annot loc left_annot >>? fun () -> error_unexpected_annot loc right_annot >|? fun () -> (Ex_ty (Contract_t (tl, tr)), annot) | Prim (_, T_pair, [ utl; utr ], annot) -> - parse_ty utl >>? fun (Ex_ty tl, left_annot) -> - parse_ty utr >>? fun (Ex_ty tr, right_annot) -> + parse_ty false utl >>? fun (Ex_ty tl, left_annot) -> + parse_ty false utr >>? fun (Ex_ty tr, right_annot) -> ok (Ex_ty (Pair_t ((tl, left_annot), (tr, right_annot))), annot) | Prim (_, T_or, [ utl; utr ], annot) -> - parse_ty utl >>? fun (Ex_ty tl, left_annot) -> - parse_ty utr >|? fun (Ex_ty tr, right_annot) -> + parse_ty false utl >>? fun (Ex_ty tl, left_annot) -> + parse_ty false utr >|? fun (Ex_ty tr, right_annot) -> (Ex_ty (Union_t ((tl, left_annot), (tr, right_annot))), annot) | Prim (_, T_lambda, [ uta; utr ], annot) -> - parse_ty uta >>? fun (Ex_ty ta, _) -> - parse_ty utr >>? fun (Ex_ty tr, _) -> + parse_ty false uta >>? fun (Ex_ty ta, _) -> + parse_ty false utr >>? fun (Ex_ty tr, _) -> ok (Ex_ty (Lambda_t (ta, tr)), annot) | Prim (loc, T_option, [ ut ], annot) -> - parse_ty ut >>? fun (Ex_ty t, opt_annot) -> + parse_ty false ut >>? fun (Ex_ty t, opt_annot) -> error_unexpected_annot loc annot >|? fun () -> (Ex_ty (Option_t t), opt_annot) | Prim (loc, T_list, [ ut ], annot) -> - parse_ty ut >>? fun (Ex_ty t, list_annot) -> + parse_ty false ut >>? fun (Ex_ty t, list_annot) -> error_unexpected_annot loc list_annot >>? fun () -> (ok (Ex_ty (List_t t), annot)) | Prim (_, T_set, [ ut ], annot) -> @@ -892,8 +940,10 @@ and parse_ty : Script.node -> (ex_ty * annot) tzresult = function ok (Ex_ty (Set_t t), annot) | Prim (_, T_map, [ uta; utr ], annot) -> parse_comparable_ty uta >>? fun (Ex_comparable_ty ta) -> - parse_ty utr >>? fun (Ex_ty tr, _) -> + parse_ty false utr >>? fun (Ex_ty tr, _) -> ok (Ex_ty (Map_t (ta, tr)), annot) + | Prim (loc, T_big_map, _, _) -> + error (Unexpected_big_map loc) | Prim (loc, (T_unit | T_signature | T_int | T_nat | T_string | T_tez | T_bool @@ -941,6 +991,30 @@ let rec parse_data Invalid_constant (location script_data, strip_locations script_data, ty) in let traced body = trace (error ()) body in + let parse_items ?type_logger loc ctxt expr key_type value_type items item_wrapper = + (fold_left_s + (fun (last_value, map) -> function + | Prim (_, D_Elt, [ k; v ], _) -> + parse_comparable_data ?type_logger ctxt key_type k >>=? fun k -> + parse_data ?type_logger ctxt value_type v >>=? fun v -> + begin match last_value with + | Some value -> + if Compare.Int.(0 <= (compare_comparable key_type value k)) + then + if Compare.Int.(0 = (compare_comparable key_type value k)) + then fail (Duplicate_map_keys (loc, strip_locations expr)) + else fail (Unordered_map_keys (loc, strip_locations expr)) + else return () + | None -> return () + end >>=? fun () -> + return (Some k, map_update k (Some (item_wrapper v)) map) + | Prim (loc, D_Elt, l, _) -> + fail @@ Invalid_arity (loc, D_Elt, 2, List.length l) + | Prim (loc, name, _, _) -> + fail @@ Invalid_primitive (loc, [ D_Elt ], name) + | Int _ | String _ | Seq _ -> + fail (error ())) + (None, empty_map key_type) items) >>|? snd |> traced in match ty, script_data with (* Unit *) | Unit_t, Prim (_, D_Unit, [], _) -> return () @@ -1115,31 +1189,15 @@ let rec parse_data (* Maps *) | Map_t (tk, tv), (Seq (loc, vs, annot) as expr) -> fail_unexpected_annot loc annot >>=? fun () -> - (fold_left_s - (fun (last_value, map) -> function - | Prim (_, D_Elt, [ k; v ], _) -> - parse_comparable_data ?type_logger ctxt tk k >>=? fun k -> - parse_data ?type_logger ctxt tv v >>=? fun v -> - begin match last_value with - | Some value -> - if Compare.Int.(0 <= (compare_comparable tk value k)) - then - if Compare.Int.(0 = (compare_comparable tk value k)) - then fail (Duplicate_map_keys (loc, strip_locations expr)) - else fail (Unordered_map_keys (loc, strip_locations expr)) - else return () - | None -> return () - end >>=? fun () -> - return (Some k, map_update k (Some v) map) - | Prim (loc, D_Elt, l, _) -> - fail @@ Invalid_arity (loc, D_Elt, 2, List.length l) - | Prim (loc, name, _, _) -> - fail @@ Invalid_primitive (loc, [ D_Elt ], name) - | Int _ | String _ | Seq _ -> - fail (error ())) - (None, empty_map tk) vs) >>|? snd |> traced + parse_items ?type_logger loc ctxt expr tk tv vs (fun x -> x) | Map_t _, expr -> traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr))) + | Big_map_t (tk, tv), (Seq (loc, vs, annot) as expr) -> + fail_unexpected_annot loc annot >>=? fun () -> + parse_items ?type_logger loc ctxt expr tk tv vs (fun x -> Some x) >>|? fun diff -> + { diff ; key_type = ty_of_comparable_ty tk ; value_type = tv } + | Big_map_t (_tk, _tv), expr -> + traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr))) and parse_comparable_data : type a. ?type_logger:(int -> Script.expr list -> Script.expr list -> unit) -> @@ -1154,7 +1212,7 @@ and parse_returning fun tc_context ctxt ?type_logger (arg, arg_annot) ret script_instr -> parse_instr tc_context ctxt ?type_logger script_instr (Item_t (arg, Empty_t, arg_annot)) >>=? function - | Typed ({ loc ; aft = (Item_t (ty, Empty_t, _) as stack_ty) } as descr) -> + | Typed ({ loc ; aft = (Item_t (ty, Empty_t, _) as stack_ty)} as descr) -> trace (Bad_return (loc, stack_ty, ret)) (Lwt.return (ty_eq ty ret)) >>=? fun Eq -> @@ -1218,7 +1276,7 @@ and parse_instr return (typed loc (Swap, Item_t (w, Item_t (v, rest, cur_top_annot), annot))) | Prim (loc, I_PUSH, [ t ; d ], instr_annot), stack -> - (Lwt.return (parse_ty t)) >>=? fun (Ex_ty t, _) -> + (Lwt.return (parse_ty false t)) >>=? fun (Ex_ty t, _) -> parse_data ?type_logger ctxt t d >>=? fun v -> return (typed loc (Const v, Item_t (t, stack, instr_annot))) | Prim (loc, I_UNIT, [], instr_annot), @@ -1230,7 +1288,7 @@ and parse_instr return (typed loc (Cons_some, Item_t (Option_t t, rest, instr_annot))) | Prim (loc, I_NONE, [ t ], instr_annot), stack -> - (Lwt.return (parse_ty t)) >>=? fun (Ex_ty t, _) -> + (Lwt.return (parse_ty false t)) >>=? fun (Ex_ty t, _) -> return (typed loc (Cons_none t, Item_t (Option_t t, stack, instr_annot))) | Prim (loc, I_IF_NONE, [ bt ; bf ], instr_annot), (Item_t (Option_t t, rest, _) as bef) -> @@ -1256,11 +1314,11 @@ and parse_instr (* unions *) | Prim (loc, I_LEFT, [ tr ], instr_annot), Item_t (tl, rest, stack_annot) -> - (Lwt.return (parse_ty tr)) >>=? fun (Ex_ty tr, _) -> + (Lwt.return (parse_ty false tr)) >>=? fun (Ex_ty tr, _) -> return (typed loc (Left, Item_t (Union_t ((tl, stack_annot), (tr, None)), rest, instr_annot))) | Prim (loc, I_RIGHT, [ tl ], instr_annot), Item_t (tr, rest, stack_annot) -> - (Lwt.return (parse_ty tl)) >>=? fun (Ex_ty tl, _) -> + (Lwt.return (parse_ty false tl)) >>=? fun (Ex_ty tl, _) -> return (typed loc (Right, Item_t (Union_t ((tl, None), (tr, stack_annot)), rest, instr_annot))) | Prim (loc, I_IF_LEFT, [ bt ; bf ], instr_annot), (Item_t (Union_t ((tl, left_annot), (tr, right_annot)), rest, _) as bef) -> @@ -1275,7 +1333,7 @@ and parse_instr (* lists *) | Prim (loc, I_NIL, [ t ], instr_annot), stack -> - (Lwt.return (parse_ty t)) >>=? fun (Ex_ty t, _) -> + (Lwt.return (parse_ty false t)) >>=? fun (Ex_ty t, _) -> return (typed loc (Nil, Item_t (List_t t, stack, instr_annot))) | Prim (loc, I_CONS, [], instr_annot), Item_t (tv, Item_t (List_t t, rest, _), _) -> @@ -1376,7 +1434,7 @@ and parse_instr | Prim (loc, I_EMPTY_MAP, [ tk ; tv ], instr_annot), stack -> (Lwt.return (parse_comparable_ty tk)) >>=? fun (Ex_comparable_ty tk) -> - (Lwt.return (parse_ty tv)) >>=? fun (Ex_ty tv, _) -> + (Lwt.return (parse_ty false tv)) >>=? fun (Ex_ty tv, _) -> return (typed loc (Empty_map (tk, tv), Item_t (Map_t (tk, tv), stack, instr_annot))) | Prim (loc, I_MAP, [], instr_annot), Item_t (Lambda_t (Pair_t ((pk, _), (pv, _)), ret), @@ -1431,6 +1489,23 @@ and parse_instr | Prim (loc, I_SIZE, [], instr_annot), Item_t (Map_t (_, _), rest, _) -> return (typed loc (Map_size, Item_t (Nat_t, rest, instr_annot))) + (* big_map *) + | Prim (loc, I_MEM, [], instr_annot), + Item_t (set_key, Item_t (Big_map_t (map_key, _), rest, _), _) -> + let k = ty_of_comparable_ty map_key in + check_item_ty set_key k loc I_MEM 1 2 >>=? fun Eq -> + return (typed loc (Big_map_mem, Item_t (Bool_t, rest, instr_annot))) + | Prim (loc, I_GET, [], instr_annot), + Item_t (vk, Item_t (Big_map_t (ck, elt), rest, _), _) -> + let k = ty_of_comparable_ty ck in + check_item_ty vk k loc I_GET 1 2 >>=? fun Eq -> + return (typed loc (Big_map_get, Item_t (Option_t elt, rest, instr_annot))) + | Prim (loc, I_UPDATE, [], instr_annot), + Item_t (set_key, Item_t (Option_t set_value, Item_t (Big_map_t (map_key, map_value), rest, _), _), _) -> + let k = ty_of_comparable_ty map_key in + check_item_ty set_key k loc I_UPDATE 1 3 >>=? fun Eq -> + check_item_ty set_value map_value loc I_UPDATE 2 3 >>=? fun Eq -> + return (typed loc (Big_map_update, Item_t (Big_map_t (map_key, map_value), rest, instr_annot))) (* control *) | Seq (loc, [], annot), stack -> @@ -1504,8 +1579,8 @@ and parse_instr end | Prim (loc, I_LAMBDA, [ arg ; ret ; code ], instr_annot), stack -> - (Lwt.return (parse_ty arg)) >>=? fun (Ex_ty arg, arg_annot) -> - (Lwt.return (parse_ty ret)) >>=? fun (Ex_ty ret, _) -> + (Lwt.return (parse_ty false arg)) >>=? fun (Ex_ty arg, arg_annot) -> + (Lwt.return (parse_ty false ret)) >>=? fun (Ex_ty ret, _) -> check_kind [ Seq_kind ] code >>=? fun () -> parse_returning Lambda ?type_logger ctxt (arg, default_annot ~default:default_arg_annot arg_annot) @@ -1776,13 +1851,13 @@ and parse_instr Lwt.return (parse_toplevel cannonical_code) >>=? fun (arg_type, ret_type, storage_type, code_field) -> trace (Ill_formed_type (Some "parameter", cannonical_code, location arg_type)) - (Lwt.return (parse_ty arg_type)) >>=? fun (Ex_ty arg_type, param_annot) -> + (Lwt.return (parse_ty false arg_type)) >>=? fun (Ex_ty arg_type, param_annot) -> trace (Ill_formed_type (Some "return", cannonical_code, location ret_type)) - (Lwt.return (parse_ty ret_type)) >>=? fun (Ex_ty ret_type, _) -> + (Lwt.return (parse_ty false ret_type)) >>=? fun (Ex_ty ret_type, _) -> trace (Ill_formed_type (Some "storage", cannonical_code, location storage_type)) - (Lwt.return (parse_ty storage_type)) >>=? fun (Ex_ty storage_type, storage_annot) -> + (Lwt.return (parse_ty true storage_type)) >>=? fun (Ex_ty storage_type, storage_annot) -> let arg_type_full = Pair_t ((arg_type, default_annot ~default:default_param_annot param_annot), (storage_type, default_annot ~default:default_storage_annot storage_annot)) in let ret_type_full = Pair_t ((ret_type, None), (storage_type, None)) in @@ -1791,7 +1866,7 @@ and parse_instr (parse_returning (Toplevel { storage_type ; param_type = arg_type ; ret_type }) ctxt ?type_logger (arg_type_full, None) ret_type_full code_field) >>=? fun (Lam ({ bef = Item_t (arg, Empty_t, _) ; - aft = Item_t (ret, Empty_t, _) ; _ }, _) as lambda) -> + aft = Item_t (ret, Empty_t, _) }, _) as lambda) -> Lwt.return @@ ty_eq arg arg_type_full >>=? fun Eq -> Lwt.return @@ ty_eq ret ret_type_full >>=? fun Eq -> Lwt.return @@ ty_eq storage_type ginit >>=? fun Eq -> @@ -1820,15 +1895,15 @@ and parse_instr return (typed loc (Steps_to_quota, Item_t (Nat_t, stack, instr_annot))) | Prim (loc, I_SOURCE, [ ta; tb ], instr_annot), stack -> - (Lwt.return (parse_ty ta)) >>=? fun (Ex_ty ta, _) -> - (Lwt.return (parse_ty tb)) >>=? fun (Ex_ty tb, _) -> + (Lwt.return (parse_ty false ta)) >>=? fun (Ex_ty ta, _) -> + (Lwt.return (parse_ty false tb)) >>=? fun (Ex_ty tb, _) -> return (typed loc (Source (ta, tb), Item_t (Contract_t (ta, tb), stack, instr_annot))) | Prim (loc, I_SELF, [], instr_annot), stack -> let rec get_toplevel_type : tc_context -> bef judgement tzresult Lwt.t = function | Lambda -> fail (Self_in_lambda loc) | Dip (_, prev) -> get_toplevel_type prev - | Toplevel { param_type ; ret_type ; _ } -> + | Toplevel { param_type ; ret_type } -> return (typed loc (Self (param_type, ret_type), Item_t (Contract_t (param_type, ret_type), stack, instr_annot))) in get_toplevel_type tc_context @@ -1860,7 +1935,7 @@ and parse_instr as name), ([] | [ _ ] | _ :: _ :: _ :: _ as l), _), _ -> fail (Invalid_arity (loc, name, 2, List.length l)) - | Prim (loc, I_LAMBDA, ([] | [ _ ] | [ _ ; _ ] + | Prim (loc, I_LAMBDA, ([] | [ _ ] | _ :: _ :: _ :: _ :: _ as l), _), _ -> fail (Invalid_arity (loc, I_LAMBDA, 3, List.length l)) (* Stack errors *) @@ -1939,11 +2014,11 @@ and parse_contract let contract : (arg, ret) typed_contract = (arg, ret, contract) in ok contract) - | Some { code ; _ } -> + | Some { code } -> Lwt.return (parse_toplevel code >>? fun (arg_type, ret_type, _, _) -> - parse_ty arg_type >>? fun (Ex_ty targ, _) -> - parse_ty ret_type >>? fun (Ex_ty tret, _) -> + parse_ty false arg_type >>? fun (Ex_ty targ, _) -> + parse_ty false ret_type >>? fun (Ex_ty tret, _) -> ty_eq targ arg >>? fun Eq -> ty_eq tret ret >>? fun Eq -> let contract : (arg, ret) typed_contract = @@ -2003,13 +2078,13 @@ let parse_script Lwt.return (parse_toplevel code) >>=? fun (arg_type, ret_type, storage_type, code_field) -> trace (Ill_formed_type (Some "parameter", code, location arg_type)) - (Lwt.return (parse_ty arg_type)) >>=? fun (Ex_ty arg_type, param_annot) -> + (Lwt.return (parse_ty false arg_type)) >>=? fun (Ex_ty arg_type, param_annot) -> trace (Ill_formed_type (Some "return", code, location ret_type)) - (Lwt.return (parse_ty ret_type)) >>=? fun (Ex_ty ret_type, _) -> + (Lwt.return (parse_ty false ret_type)) >>=? fun (Ex_ty ret_type, _) -> trace (Ill_formed_type (Some "storage", code, location storage_type)) - (Lwt.return (parse_ty storage_type)) >>=? fun (Ex_ty storage_type, storage_annot) -> + (Lwt.return (parse_ty true storage_type)) >>=? fun (Ex_ty storage_type, storage_annot) -> let arg_type_full = Pair_t ((arg_type, default_annot ~default:default_param_annot param_annot), (storage_type, default_annot ~default:default_storage_annot storage_annot)) in let ret_type_full = Pair_t ((ret_type, None), (storage_type, None)) in @@ -2031,13 +2106,13 @@ let typecheck_code (* TODO: annotation checking *) trace (Ill_formed_type (Some "parameter", code, location arg_type)) - (Lwt.return (parse_ty arg_type)) >>=? fun (Ex_ty arg_type, param_annot) -> + (Lwt.return (parse_ty false arg_type)) >>=? fun (Ex_ty arg_type, param_annot) -> trace (Ill_formed_type (Some "return", code, location ret_type)) - (Lwt.return (parse_ty ret_type)) >>=? fun (Ex_ty ret_type, _) -> + (Lwt.return (parse_ty false ret_type)) >>=? fun (Ex_ty ret_type, _) -> trace (Ill_formed_type (Some "storage", code, location storage_type)) - (Lwt.return (parse_ty storage_type)) >>=? fun (Ex_ty storage_type, storage_annot) -> + (Lwt.return (parse_ty true storage_type)) >>=? fun (Ex_ty storage_type, storage_annot) -> let arg_type_full = Pair_t ((arg_type, default_annot ~default:default_param_annot param_annot), (storage_type, default_annot ~default:default_storage_annot storage_annot)) in let ret_type_full = Pair_t ((ret_type, None), (storage_type, None)) in @@ -2058,7 +2133,7 @@ let typecheck_data = fun ?type_logger ctxt (data, exp_ty) -> trace (Ill_formed_type (None, exp_ty, 0)) - (Lwt.return (parse_ty (root exp_ty))) >>=? fun (Ex_ty exp_ty, _) -> + (Lwt.return (parse_ty true (root exp_ty))) >>=? fun (Ex_ty exp_ty, _) -> trace (Ill_typed_data (None, data, exp_ty)) (parse_data ?type_logger ctxt exp_ty (root data)) >>=? fun _ -> @@ -2068,3 +2143,52 @@ let hash_data typ data = let unparsed = strip_annotations @@ unparse_data typ data in let bytes = Data_encoding.Binary.to_bytes expr_encoding (Micheline.strip_locations unparsed) in Tezos_hash.Script_expr_hash.(hash_bytes [ bytes ] |> to_b58check) + +(* ---------------- Big map -------------------------------------------------*) + +let big_map_mem ctx contract key { diff ; key_type } = + match map_get key diff with + | None -> Tezos_context.Contract.Big_map_storage.mem ctx contract (hash_data key_type key) + | Some None -> Lwt.return false + | Some (Some _) -> Lwt.return true + +let big_map_get ctx contract key { diff ; key_type ; value_type } = + match map_get key diff with + | Some x -> return x + | None -> + Tezos_context.Contract.Big_map_storage.get_opt + ctx contract + (hash_data key_type key) >>=? begin function + | None -> return None + | Some value -> parse_data ctx value_type (Micheline.root value) >>|? fun x -> Some x + end + +let big_map_update key value ({ diff } as map) = + { map with diff = map_set key value diff } + +let to_big_map_diff_list { key_type ; value_type ; diff } = + map_fold (fun key value acc -> + (hash_data key_type key, + Option.map ~f:(fun x -> Micheline.strip_locations @@ unparse_data value_type x) value) :: acc) + diff [] + +(* Get the big map from a contract's storage if one exists *) +let extract_big_map : type a. a ty -> a -> ex_big_map option = fun ty x -> + match (ty, x) with + | Pair_t ((Big_map_t (_, _), _), _), (map, _) -> Some (Ex_bm map) + | _, _ -> None + +let to_serializable_big_map (Ex_bm bm) = + to_big_map_diff_list bm + +let to_printable_big_map (Ex_bm { diff ; key_type ; value_type }) = + map_fold (fun key value acc -> + (Micheline.strip_locations @@ unparse_data key_type key, + Option.map ~f:(fun x -> Micheline.strip_locations @@ unparse_data value_type x) value) :: acc) diff [] + +let erase_big_map_initialization ctxt ({ code ; storage } : Script.t) = + Lwt.return (parse_toplevel code) >>=? fun (_, _, storage_type, _) -> + Lwt.return @@ parse_ty true storage_type >>=? fun (Ex_ty ty, _) -> + parse_data ctxt ty (Micheline.root storage) >>|? fun data -> + ({ code ; storage = Micheline.strip_locations @@ unparse_data ty data }, + Option.map ~f:to_serializable_big_map (extract_big_map ty data)) diff --git a/src/proto_alpha/lib_protocol/src/script_ir_translator.mli b/src/proto_alpha/lib_protocol/src/script_ir_translator.mli index 2f890534e..8a0ee818b 100644 --- a/src/proto_alpha/lib_protocol/src/script_ir_translator.mli +++ b/src/proto_alpha/lib_protocol/src/script_ir_translator.mli @@ -17,7 +17,6 @@ type ex_ty = Ex_ty : 'a Script_typed_ir.ty -> ex_ty type ex_stack_ty = Ex_stack_ty : 'a Script_typed_ir.stack_ty -> ex_stack_ty type ex_script = Ex_script : ('a, 'b, 'c) Script_typed_ir.script -> ex_script - (* ---- Sets and Maps -------------------------------------------------------*) val empty_set : 'a Script_typed_ir.comparable_ty -> 'a Script_typed_ir.set @@ -39,6 +38,14 @@ val map_get : 'key -> ('key, 'value) Script_typed_ir.map -> 'value option val map_key_ty : ('a, 'b) Script_typed_ir.map -> 'a Script_typed_ir.comparable_ty val map_size : ('a, 'b) Script_typed_ir.map -> Script_int.n Script_int.num +val big_map_mem : context -> Tezos_context.Contract.t -> 'key -> ('key, 'value) Script_typed_ir.big_map -> bool Lwt.t +val big_map_get : + context -> Tezos_context.Contract.t -> 'key -> ('key, 'value) Script_typed_ir.big_map -> + 'value option tzresult Lwt.t +val big_map_update : + 'key -> 'value option -> ('key, 'value) Script_typed_ir.big_map -> + ('key, 'value) Script_typed_ir.big_map + val ty_eq : 'ta Script_typed_ir.ty -> 'tb Script_typed_ir.ty -> ('ta Script_typed_ir.ty, 'tb Script_typed_ir.ty) eq tzresult @@ -49,7 +56,7 @@ val parse_data : val unparse_data : 'a Script_typed_ir.ty -> 'a -> Script.node -val parse_ty : +val parse_ty : bool -> Script.node -> (ex_ty * Script_typed_ir.annot) tzresult val unparse_ty : string option -> 'a Script_typed_ir.ty -> Script.node @@ -69,3 +76,12 @@ val parse_script : context -> Script.t -> ex_script tzresult Lwt.t val hash_data : 'a Script_typed_ir.ty -> 'a -> string + +val extract_big_map : 'a Script_typed_ir.ty -> 'a -> Script_typed_ir.ex_big_map option + +val to_serializable_big_map : Script_typed_ir.ex_big_map -> Contract_storage.big_map_diff + +val to_printable_big_map : Script_typed_ir.ex_big_map -> (Script.expr * Script.expr option) list + +val erase_big_map_initialization : context -> Script.t -> + (Script.t * Contract_storage.big_map_diff option) tzresult Lwt.t diff --git a/src/proto_alpha/lib_protocol/src/script_tc_errors.ml b/src/proto_alpha/lib_protocol/src/script_tc_errors.ml index 4360fd329..a3b1ee15a 100644 --- a/src/proto_alpha/lib_protocol/src/script_tc_errors.ml +++ b/src/proto_alpha/lib_protocol/src/script_tc_errors.ml @@ -26,6 +26,7 @@ type error += Invalid_primitive of Script.location * prim list * prim type error += Invalid_kind of Script.location * kind list * kind type error += Missing_field of prim type error += Duplicate_field of Script.location * prim +type error += Unexpected_big_map of Script.location (* Instruction typing errors *) type error += Fail_not_in_tail_position of Script.location diff --git a/src/proto_alpha/lib_protocol/src/script_tc_errors_registration.ml b/src/proto_alpha/lib_protocol/src/script_tc_errors_registration.ml index 0c514cd25..19d4336d0 100644 --- a/src/proto_alpha/lib_protocol/src/script_tc_errors_registration.ml +++ b/src/proto_alpha/lib_protocol/src/script_tc_errors_registration.ml @@ -30,7 +30,7 @@ let ex_ty_enc = Data_encoding.conv (fun (Ex_ty ty) -> strip_locations (unparse_ty None ty)) (fun expr -> - match parse_ty (root expr) with + match parse_ty true (root expr) with | Ok (Ex_ty ty, _) -> Ex_ty ty | _ -> Ex_ty Unit_t (* FIXME: ? *)) Script.expr_encoding @@ -164,6 +164,18 @@ let () = (req "prim" prim_encoding)) (function Duplicate_field (loc, prim) -> Some (loc, prim) | _ -> None) (fun (loc, prim) -> Duplicate_field (loc, prim)) ; + (* Unexpected big_map *) + register_error_kind + `Permanent + ~id:"unexpectedBigMap" + ~title: "Big map in unauthorized position (type error)" + ~description: + "When parsing script, a big_map type was found somewhere else \ + than in the left component of the toplevel storage pair." + (obj1 + (req "loc" location_encoding)) + (function Unexpected_big_map loc -> Some loc | _ -> None) + (fun loc -> Unexpected_big_map loc) ; (* -- Value typing errors ---------------------- *) (* Unordered map keys *) register_error_kind diff --git a/src/proto_alpha/lib_protocol/src/script_typed_ir.ml b/src/proto_alpha/lib_protocol/src/script_typed_ir.ml index 10e16c2b9..964f36bba 100644 --- a/src/proto_alpha/lib_protocol/src/script_typed_ir.ml +++ b/src/proto_alpha/lib_protocol/src/script_typed_ir.ml @@ -41,6 +41,8 @@ end type ('key, 'value) map = (module Boxed_map with type key = 'key and type value = 'value) +type annot = string option + type ('arg, 'ret, 'storage) script = { code : (('arg, 'storage) pair, ('ret, 'storage) pair) lambda ; arg_type : 'arg ty ; @@ -60,8 +62,6 @@ and ('arg, 'ret) lambda = and ('arg, 'ret) typed_contract = 'arg ty * 'ret ty * Contract.t -and annot = string option - and 'ty ty = | Unit_t : unit ty | Int_t : z num ty @@ -80,12 +80,17 @@ and 'ty ty = | List_t : 'v ty -> 'v list ty | Set_t : 'v comparable_ty -> 'v set ty | Map_t : 'k comparable_ty * 'v ty -> ('k, 'v) map ty + | Big_map_t : 'k comparable_ty * 'v ty -> ('k, 'v) big_map ty | Contract_t : 'arg ty * 'ret ty -> ('arg, 'ret) typed_contract ty and 'ty stack_ty = | Item_t : 'ty ty * 'rest stack_ty * annot -> ('ty * 'rest) stack_ty | Empty_t : end_of_stack stack_ty +and ('key, 'value) big_map = { diff : ('key, 'value option) map ; + key_type : 'key ty ; + value_type : 'value ty } + (* ---- Instructions --------------------------------------------------------*) (* The low-level, typed instructions, as a GADT whose parameters @@ -176,6 +181,13 @@ and ('bef, 'aft) instr = | Map_update : ('a * ('v option * (('a, 'v) map * 'rest)), ('a, 'v) map * 'rest) instr | Map_size : (('a, 'b) map * 'rest, n num * 'rest) instr + (* big maps *) + | Big_map_mem : + ('a * (('a, 'v) big_map * 'rest), bool * 'rest) instr + | Big_map_get : + ('a * (('a, 'v) big_map * 'rest), 'v option * 'rest) instr + | Big_map_update : + ('key * ('value option * (('key, 'value) big_map * 'rest)), ('key, 'value) big_map * 'rest) instr (* string operations *) | Concat : (string * (string * 'rest), string * 'rest) instr @@ -343,3 +355,5 @@ and ('bef, 'aft) descr = bef : 'bef stack_ty ; aft : 'aft stack_ty ; instr : ('bef, 'aft) instr } + +type ex_big_map = Ex_bm : ('key, 'value) big_map -> ex_big_map diff --git a/src/proto_alpha/lib_protocol/src/services.ml b/src/proto_alpha/lib_protocol/src/services.ml index b731157d5..5f003e76b 100644 --- a/src/proto_alpha/lib_protocol/src/services.ml +++ b/src/proto_alpha/lib_protocol/src/services.ml @@ -445,9 +445,10 @@ module Helpers = struct ~query: RPC_query.empty ~input: run_code_input_encoding ~output: (wrap_tzerror - (obj2 + (obj3 (req "storage" Script.expr_encoding) - (req "output" Script.expr_encoding))) + (req "output" Script.expr_encoding) + (opt "big_map_diff" (list (tup2 Script.expr_encoding (option Script.expr_encoding)))))) ~error: Data_encoding.empty RPC_path.(custom_root / "helpers" / "run_code") @@ -473,14 +474,15 @@ module Helpers = struct ~query: RPC_query.empty ~input: run_code_input_encoding ~output: (wrap_tzerror - (obj3 + (obj4 (req "storage" Script.expr_encoding) (req "output" Script.expr_encoding) (req "trace" (list @@ obj3 (req "location" Script.location_encoding) (req "gas" Gas.encoding) - (req "stack" (list (Script.expr_encoding))))))) + (req "stack" (list (Script.expr_encoding))))) + (opt "big_map_diff" (list (tup2 Script.expr_encoding (option Script.expr_encoding)))))) ~error: Data_encoding.empty RPC_path.(custom_root / "helpers" / "trace_code") @@ -509,12 +511,12 @@ module Helpers = struct RPC_service.post_service ~description: "Computes the hash of some data expression \ using the same algorithm as script instruction H" - ~query: RPC_query.empty ~input: (obj2 (req "data" Script.expr_encoding) (req "type" Script.expr_encoding)) ~output: (wrap_tzerror @@ obj1 (req "hash" string)) ~error: Data_encoding.empty + ~query: RPC_query.empty RPC_path.(custom_root / "helpers" / "hash_data") let level custom_root = diff --git a/src/proto_alpha/lib_protocol/src/services_registration.ml b/src/proto_alpha/lib_protocol/src/services_registration.ml index 7fd4b0101..26bd6fabd 100644 --- a/src/proto_alpha/lib_protocol/src/services_registration.ml +++ b/src/proto_alpha/lib_protocol/src/services_registration.ml @@ -297,8 +297,8 @@ let () = contract (* transaction initiator *) contract (* script owner *) ctxt { storage ; code } amount input - (Gas.of_int gas) >>=? fun (sto, ret, _gas, _ctxt, _) -> - Error_monad.return (sto, ret)) ; + (Gas.of_int gas) >>=? fun (sto, ret, _gas, _ctxt, _, maybe_big_map_diff) -> + Error_monad.return (sto, ret, Option.map ~f:Script_ir_translator.to_printable_big_map maybe_big_map_diff)) ; register1 Services.Helpers.trace_code (fun ctxt () parameters -> let (code, storage, input, amount, contract, gas, origination_nonce) = @@ -308,8 +308,8 @@ let () = contract (* transaction initiator *) contract (* script owner *) ctxt { storage ; code } amount input - (Gas.of_int gas) >>=? fun ((sto, ret, _gas, _ctxt, _), trace) -> - Error_monad.return (sto, ret, trace)) + (Gas.of_int gas) >>=? fun ((sto, ret, _gas, _ctxt, _, maybe_big_map_diff), trace) -> + Error_monad.return (sto, ret, trace, Option.map ~f:Script_ir_translator.to_printable_big_map maybe_big_map_diff)) let () = register1 Services.Helpers.typecheck_code @@ -323,7 +323,7 @@ let () = register1 Services.Helpers.hash_data (fun ctxt () (expr, typ) -> let open Script_ir_translator in - Lwt.return @@ parse_ty (Micheline.root typ) >>=? fun (Ex_ty typ, _) -> + Lwt.return @@ parse_ty false (Micheline.root typ) >>=? fun (Ex_ty typ, _) -> parse_data ctxt typ (Micheline.root expr) >>=? fun data -> return (Script_ir_translator.hash_data typ data)) diff --git a/src/proto_alpha/lib_protocol/src/storage.ml b/src/proto_alpha/lib_protocol/src/storage.ml index eb9e6a881..cd1c822dd 100644 --- a/src/proto_alpha/lib_protocol/src/storage.ml +++ b/src/proto_alpha/lib_protocol/src/storage.ml @@ -20,6 +20,15 @@ module Bool = struct let encoding = Data_encoding.bool end +module String_index = struct + type t = string + let path_length = 1 + let to_path c l = c :: l + let of_path = function + | [ c ] -> Some c + | [] | _ :: _ :: _ -> None +end + (** Contracts handling *) module Contract = struct @@ -86,6 +95,18 @@ module Contract = struct type t = Script_repr.expr let encoding = Script_repr.expr_encoding end)) + type bigmap_key = Raw_context.t * Contract_repr.t + + module Big_map = + Storage_functors.Make_indexed_data_storage + (Make_subcontext + (Indexed_context.Raw_context) + (struct let name = ["big_map"] end)) + (String_index) + (Make_value (struct + type t = Script_repr.expr + let encoding = Script_repr.expr_encoding + end)) module Code_fees = Indexed_context.Make_map diff --git a/src/proto_alpha/lib_protocol/src/storage.mli b/src/proto_alpha/lib_protocol/src/storage.mli index dca24d30d..203b08f07 100644 --- a/src/proto_alpha/lib_protocol/src/storage.mli +++ b/src/proto_alpha/lib_protocol/src/storage.mli @@ -147,6 +147,13 @@ module Contract : sig and type value = Tez_repr.t and type t := Raw_context.t + type bigmap_key = Raw_context.t * Contract_repr.t + + module Big_map : Indexed_data_storage + with type key = string + and type value = Script_repr.expr + and type t := bigmap_key + end (** Votes *) diff --git a/src/proto_alpha/lib_protocol/src/tezos_context.ml b/src/proto_alpha/lib_protocol/src/tezos_context.ml index d5a23cc7b..fbdfbe237 100644 --- a/src/proto_alpha/lib_protocol/src/tezos_context.ml +++ b/src/proto_alpha/lib_protocol/src/tezos_context.ml @@ -107,6 +107,14 @@ end module Contract = struct include Contract_repr include Contract_storage + + module Big_map_storage = struct + let set ctx contract = Contract_storage.Big_map.set (ctx, contract) + let remove ctx contract = Contract_storage.Big_map.remove (ctx, contract) + let mem ctx contract = Contract_storage.Big_map.mem (ctx, contract) + let get_opt ctx contract = Contract_storage.Big_map.get_opt (ctx, contract) + end + end module Roll = struct include Roll_repr diff --git a/src/proto_alpha/lib_protocol/src/tezos_context.mli b/src/proto_alpha/lib_protocol/src/tezos_context.mli index 926970d91..a8f3245ec 100644 --- a/src/proto_alpha/lib_protocol/src/tezos_context.mli +++ b/src/proto_alpha/lib_protocol/src/tezos_context.mli @@ -216,6 +216,7 @@ module Script : sig | T_lambda | T_list | T_map + | T_big_map | T_nat | T_option | T_or @@ -466,7 +467,8 @@ module Contract : sig context -> contract -> Tez.t -> context tzresult Lwt.t val update_script_storage_and_fees: - context -> contract -> Tez.t -> Script.expr -> context tzresult Lwt.t + context -> contract -> Tez.t -> Script.expr -> + (string * Script.expr option) list option -> context tzresult Lwt.t val increment_counter: context -> contract -> context tzresult Lwt.t @@ -474,6 +476,17 @@ module Contract : sig val check_counter_increment: context -> contract -> int32 -> unit tzresult Lwt.t + module Big_map_storage : sig + val set : + context -> contract -> + string -> Script.expr -> context tzresult Lwt.t + val remove : + context -> contract -> string -> context tzresult Lwt.t + val mem : context -> contract -> string -> bool Lwt.t + val get_opt : + context -> contract -> string -> Script_repr.expr option tzresult Lwt.t + end + end module Vote : sig diff --git a/src/proto_alpha/lib_protocol/test/helpers/helpers_script.mli b/src/proto_alpha/lib_protocol/test/helpers/helpers_script.mli index 66fb26f81..e47040f19 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/helpers_script.mli +++ b/src/proto_alpha/lib_protocol/test/helpers/helpers_script.mli @@ -13,6 +13,6 @@ open Tezos_context val init_amount : int val execute_code_pred : ?tc:Tezos_context.t -> Helpers_block.result -> Script.t -> Script.expr -> - (Script.expr * Script.expr * Gas.t * context * Contract.origination_nonce) + (Script.expr * Script.expr * Gas.t * context * Contract.origination_nonce * Script_typed_ir.ex_big_map option) proto_tzresult Lwt.t diff --git a/src/proto_alpha/lib_protocol/test/jbuild b/src/proto_alpha/lib_protocol/test/jbuild index e4a4e2ae9..0f9887775 100644 --- a/src/proto_alpha/lib_protocol/test/jbuild +++ b/src/proto_alpha/lib_protocol/test/jbuild @@ -4,11 +4,13 @@ ((name main) (libraries (tezos-base tezos-test-helpers + tezos-micheline tezos_proto_alpha_isolate_helpers tezos_proto_alpha_isolate_michelson_parser)) (flags (:standard -w -9-32 -safe-string -open Tezos_base__TzPervasives -open Tezos_test_helpers + -open Tezos_micheline -open Tezos_proto_alpha_isolate_michelson_parser)))) (alias diff --git a/src/proto_alpha/lib_protocol/test/test_michelson.ml b/src/proto_alpha/lib_protocol/test/test_michelson.ml index ea2199cb1..f4b7897c2 100644 --- a/src/proto_alpha/lib_protocol/test/test_michelson.ml +++ b/src/proto_alpha/lib_protocol/test/test_michelson.ml @@ -25,8 +25,6 @@ open Shorthands let (>>??) = Assert.(>>??) let (>>=??) = Assert.(>>=??) -open Tezos_micheline - let parse_param s : Proto_alpha.Tezos_context.Script.expr = let (parsed, _) = Michelson_v1_parser.parse_expression s in parsed.expanded @@ -50,9 +48,9 @@ let quote s = "\"" ^ s ^ "\"" let parse_execute sb ?tc code_str param_str storage_str = let param = parse_param param_str in let script = parse_script code_str storage_str in - Script.execute_code_pred ?tc sb script param >>=?? fun (ret, st, _, tc, nonce) -> + Script.execute_code_pred ?tc sb script param >>=?? fun (ret, st, _, tc, nonce, bgm) -> let contracts = Contract.originated_contracts nonce in - return (ret, st, tc, contracts) + return (ret, st, tc, contracts, bgm) let test ctxt ?tc (file_name: string) (storage: string) (input: string) = let full_path = contract_path // file_name ^ ".tz" in @@ -79,7 +77,7 @@ let string_of_canon output_prim = output let test_print ctxt fn s i = - test ctxt fn s i >>=? fun (sp, op, _, _) -> + test ctxt fn s i >>=? fun (sp, op, _, _, _bgm) -> let ss = string_of_canon sp in let os = string_of_canon op in debug "Storage : %s" ss ; @@ -88,7 +86,7 @@ let test_print ctxt fn s i = let test_output ctxt ?location (file_name: string) (storage: string) (input: string) (expected_output: string) = - test ctxt file_name storage input >>=? fun (_storage_prim, output_prim, _tc, _contracts) -> + test ctxt file_name storage input >>=? fun (_storage_prim, output_prim, _tc, _contracts, _bgm) -> let output = string_of_canon output_prim in let msg = Option.unopt ~default:"strings aren't equal" location in Assert.equal_string ~msg expected_output output ; @@ -96,18 +94,18 @@ let test_output ctxt ?location (file_name: string) (storage: string) (input: str let test_tc ctxt ?tc (file_name: string) (storage: string) (input: string) = - test ctxt ?tc file_name storage input >>=? fun (_storage_prim, _output_prim, tc, _contracts) -> + test ctxt ?tc file_name storage input >>=? fun (_storage_prim, _output_prim, tc, _contracts, _bgm) -> return (tc) let test_contract ctxt ?tc (file_name: string) (storage: string) (input: string) = - test ctxt ?tc file_name storage input >>=? fun (_storage_prim, _output_prim, tc, contracts) -> + test ctxt ?tc file_name storage input >>=? fun (_storage_prim, _output_prim, tc, contracts, _bgm) -> return (contracts, tc) let test_storage ctxt ?location (file_name: string) (storage: string) (input: string) (expected_storage: string) = - test ctxt file_name storage input >>=? fun (storage_prim, _output_prim, _tc, _contracts) -> + test ctxt file_name storage input >>=? fun (storage_prim, _output_prim, _tc, _contracts, _bgm) -> let storage = string_of_canon storage_prim in let msg = Option.unopt ~default:"strings aren't equal" location in Assert.equal_string ~msg expected_storage storage ; @@ -439,7 +437,7 @@ let test_example () = let contract = List.hd cs in Proto_alpha.Tezos_context.Contract.get_script tc contract >>=?? fun res -> let script = Option.unopt_exn (Failure "get_script") res in - Script.execute_code_pred ~tc sb script (parse_param "\"abc\"") >>=?? fun (_, ret, _, _, _) -> + Script.execute_code_pred ~tc sb script (parse_param "\"abc\"") >>=?? fun (_, ret, _, _, _, _) -> Assert.equal_string ~msg: __LOC__ "\"abc\"" @@ string_of_canon ret ; (* Test DEFAULT_ACCOUNT *)