From a7617f527df9471f01104e0352b5fdb643d9917d Mon Sep 17 00:00:00 2001 From: Milo Davis Date: Wed, 13 Dec 2017 14:34:33 +0100 Subject: [PATCH] Michelson: Contract creation from literal --- .../src/script_interpreter.ml | 63 ++++++++++++------- .../src/script_ir_translator.ml | 40 +++++++++++- .../src/script_typed_ir.ml | 3 + test/contracts/create_contract_literal.tz | 14 +++++ 4 files changed, 96 insertions(+), 24 deletions(-) create mode 100644 test/contracts/create_contract_literal.tz diff --git a/lib_embedded_protocol_alpha/src/script_interpreter.ml b/lib_embedded_protocol_alpha/src/script_interpreter.ml index 0fd9c2d99..12a69e234 100644 --- a/lib_embedded_protocol_alpha/src/script_interpreter.ml +++ b/lib_embedded_protocol_alpha/src/script_interpreter.ml @@ -156,6 +156,35 @@ let rec interp let gas = Gas.consume gas (cost x1 x2) in Gas.check gas >>=? fun () -> logged_return descr (Item (Script_int.of_int @@ op x1 x2, rest), gas, ctxt) in + let create_contract : + type param return rest storage. + (_, (param, return) typed_contract * rest) descr -> + manager:public_key_hash -> delegate:public_key_hash option -> spendable:bool -> + delegatable:bool -> credit:Tez.t -> code:prim Micheline.canonical -> + init:storage -> param_type:param ty -> storage_type:storage ty -> + return_type:return ty -> + rest:rest stack -> + (((param, return) typed_contract * rest) stack * Gas.t * context * Contract.origination_nonce) tzresult Lwt.t = + fun descr ~manager ~delegate ~spendable ~delegatable + ~credit ~code ~init ~param_type ~storage_type ~return_type ~rest -> + let gas = Gas.consume gas Gas.Cost_of.create_contract in + Gas.check gas >>=? fun () -> + let code = + Micheline.strip_locations + (Seq (0, [ Prim (0, K_parameter, [ unparse_ty None param_type ], None) ; + Prim (0, K_return, [ unparse_ty None return_type ], None) ; + Prim (0, K_storage, [ unparse_ty None storage_type ], None) ; + Prim (0, K_code, [ Micheline.root code ], None) ], None)) in + let storage = Micheline.strip_locations (unparse_data storage_type init) in + Contract.spend_from_script ctxt source credit >>=? fun ctxt -> + Lwt.return Tez.(credit -? Constants.origination_burn) >>=? fun balance -> + Contract.originate ctxt + origination + ~manager ~delegate ~balance + ~script:({ code ; storage }, (dummy_code_fee, dummy_storage_fee)) + ~spendable ~delegatable + >>=? fun (ctxt, contract, origination) -> + logged_return descr ~origination (Item ((param_type, return_type, contract), rest), gas, ctxt) in let logged_return : ?origination:Contract.origination_nonce -> a stack * Gas.t * context -> (a stack * Gas.t * context * Contract.origination_nonce) tzresult Lwt.t = @@ -674,7 +703,7 @@ let rec interp Gas.check gas >>=? fun () -> let contract = Contract.default_contract key in logged_return (Item ((Unit_t, Unit_t, contract), rest), gas, ctxt) - | Create_contract (g, p, r), + | Create_contract (storage_type, param_type, return_type), Item (manager, Item (delegate, Item (spendable, Item @@ -682,24 +711,17 @@ let rec interp (credit, Item (Lam (_, code), Item (init, rest))))))) -> - let gas = Gas.consume gas Gas.Cost_of.create_contract in - Gas.check gas >>=? fun () -> - let code = - Micheline.strip_locations - (Seq (0, [ Prim (0, K_parameter, [ unparse_ty None p ], None) ; - Prim (0, K_return, [ unparse_ty None r ], None) ; - Prim (0, K_storage, [ unparse_ty None g ], None) ; - Prim (0, K_code, [ Micheline.root code ], None) ], None)) in - let storage = Micheline.strip_locations (unparse_data g init) in - Contract.spend_from_script ctxt source credit >>=? fun ctxt -> - Lwt.return Tez.(credit -? Constants.origination_burn) >>=? fun balance -> - Contract.originate ctxt - origination - ~manager ~delegate ~balance - ~script:({ code ; storage }, (dummy_code_fee, dummy_storage_fee)) - ~spendable ~delegatable - >>=? fun (ctxt, contract, origination) -> - logged_return ~origination (Item ((p, r, contract), rest), gas, ctxt) + create_contract descr ~manager ~delegate ~spendable ~delegatable ~credit ~code ~init + ~param_type ~return_type ~storage_type ~rest + | Create_contract_literal (storage_type, param_type, return_type, Lam (_, code)), + Item (manager, Item + (delegate, Item + (spendable, Item + (delegatable, Item + (credit, Item + (init, rest)))))) -> + create_contract descr ~manager ~delegate ~spendable ~delegatable ~credit ~code ~init + ~param_type ~return_type ~storage_type ~rest | Balance, rest -> let gas = Gas.consume gas Gas.Cost_of.balance in Gas.check gas >>=? fun () -> @@ -733,8 +755,7 @@ let rec interp | Amount, rest -> let gas = Gas.consume gas Gas.Cost_of.amount in Gas.check gas >>=? fun () -> - logged_return (Item (amount, rest), gas, ctxt) - in + logged_return (Item (amount, rest), gas, ctxt) in let stack = (Item (arg, Empty)) in begin match log with | None -> () diff --git a/lib_embedded_protocol_alpha/src/script_ir_translator.ml b/lib_embedded_protocol_alpha/src/script_ir_translator.ml index 1d39dbe51..4e01fa559 100644 --- a/lib_embedded_protocol_alpha/src/script_ir_translator.ml +++ b/lib_embedded_protocol_alpha/src/script_ir_translator.ml @@ -236,6 +236,7 @@ let number_of_generated_growing_types : type b a. (b, a) instr -> int = function | Create_account -> 0 | Default_account -> 0 | Create_contract _ -> 1 + | Create_contract_literal _ -> 1 | Now -> 0 | Balance -> 0 | Check_signature -> 0 @@ -980,6 +981,8 @@ let rec unparse_stack | Empty_t -> [] | Item_t (ty, rest, annot) -> strip_locations (unparse_ty annot ty) :: unparse_stack rest +type ex_script = Ex_script : ('a, 'b, 'c) script -> ex_script + let rec parse_data : type a. ?type_logger: (int -> Script.expr list -> Script.expr list -> unit) -> @@ -1814,6 +1817,39 @@ and parse_instr check_item_ty ginit gp loc I_CREATE_CONTRACT 6 7 >>=? fun (Eq _) -> return (typed loc (Create_contract (gp, p, r), Item_t (Contract_t (p, r), rest, instr_annot))) + | Prim (loc, I_CREATE_CONTRACT, [ (Seq (seq_loc, _, annot) as code)], instr_annot), + Item_t + (Key_hash_t, Item_t + (Option_t Key_hash_t, Item_t + (Bool_t, Item_t + (Bool_t, Item_t + (Tez_t, Item_t + (ginit, rest, _), _), _), _), _), _) -> + fail_unexpected_annot seq_loc annot >>=? fun () -> + let cannonical_code = fst @@ Micheline.extract_locations code in + 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) -> + trace + (Ill_formed_type (Some "return", cannonical_code, location ret_type)) + (Lwt.return (parse_ty 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) -> + 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 + trace + (Ill_typed_contract (cannonical_code, [])) + (parse_returning (Toplevel { storage_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) -> + 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 _) -> + return (typed loc (Create_contract_literal (storage_type, arg_type, ret_type, lambda), + Item_t (Contract_t (arg_type, ret_type), rest, instr_annot))) | Prim (loc, I_NOW, [], instr_annot), stack -> return (typed loc (Now, Item_t (Timestamp_t, stack, instr_annot))) @@ -1947,7 +1983,7 @@ 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, _) -> @@ -2004,8 +2040,6 @@ and parse_toplevel | (Some _, Some _, Some _, None) -> error (Missing_field K_code) | (Some p, Some r, Some s, Some c) -> ok (p, r, s, c) -type ex_script = Ex_script : ('a, 'b, 'c) script -> ex_script - let parse_script : ?type_logger: (int -> Script.expr list -> Script.expr list -> unit) -> context -> Script.t -> ex_script tzresult Lwt.t diff --git a/lib_embedded_protocol_alpha/src/script_typed_ir.ml b/lib_embedded_protocol_alpha/src/script_typed_ir.ml index 82cdba14f..3d702a479 100644 --- a/lib_embedded_protocol_alpha/src/script_typed_ir.ml +++ b/lib_embedded_protocol_alpha/src/script_typed_ir.ml @@ -318,6 +318,9 @@ and ('bef, 'aft) instr = (public_key_hash * (public_key_hash option * (bool * (bool * (Tez.t * (('p * 'g, 'r * 'g) lambda * ('g * 'rest)))))), ('p, 'r) typed_contract * 'rest) instr + | Create_contract_literal : 'g ty * 'p ty * 'r ty * ('p * 'g, 'r * 'g) lambda -> + (public_key_hash * (public_key_hash option * (bool * (bool * (Tez.t * ('g * 'rest))))), + ('p, 'r) typed_contract * 'rest) instr | Now : ('rest, Script_timestamp.t * 'rest) instr | Balance : diff --git a/test/contracts/create_contract_literal.tz b/test/contracts/create_contract_literal.tz new file mode 100644 index 000000000..4043ef1ff --- /dev/null +++ b/test/contracts/create_contract_literal.tz @@ -0,0 +1,14 @@ +parameter key_hash; +storage string; +return unit; +code { CAR; + DIP { UNIT; + PUSH tez "100.00"; PUSH bool False; + PUSH bool False; NONE key_hash }; + CREATE_CONTRACT { parameter string ; + storage unit ; + return string ; + code {CAR; UNIT; SWAP; PAIR } } ; + DIP{PUSH string ""}; PUSH tez "0.00"; + PUSH string "abcdefg"; TRANSFER_TOKENS; + DIP{DROP}; UNIT; PAIR};