From 197b29b0404c81e34153ac98848e225e6c852b34 Mon Sep 17 00:00:00 2001 From: Benjamin Canou Date: Thu, 14 Jun 2018 23:03:09 +0200 Subject: [PATCH] Michelson: add PACK and UNPACK --- docs/whitedoc/michelson.rst | 16 ++++++ .../lib_protocol/src/alpha_context.mli | 2 + .../lib_protocol/src/michelson_v1_gas.ml | 3 + .../lib_protocol/src/michelson_v1_gas.mli | 2 + .../src/michelson_v1_primitives.ml | 8 +++ .../src/michelson_v1_primitives.mli | 2 + .../lib_protocol/src/script_interpreter.ml | 16 ++++++ .../lib_protocol/src/script_ir_annot.ml | 2 + .../lib_protocol/src/script_ir_annot.mli | 2 + .../lib_protocol/src/script_ir_translator.ml | 56 ++++++++++++++++++- .../lib_protocol/src/script_ir_translator.mli | 1 + .../lib_protocol/src/script_typed_ir.ml | 4 ++ 12 files changed, 113 insertions(+), 1 deletion(-) diff --git a/docs/whitedoc/michelson.rst b/docs/whitedoc/michelson.rst index dc0600a1b..54aa0f826 100644 --- a/docs/whitedoc/michelson.rst +++ b/docs/whitedoc/michelson.rst @@ -1442,6 +1442,22 @@ Special operations :: 'S -> timestamp : 'S +Serialization +~~~~~~~~~~~~~ + +- ``PACK``: Serializes a piece of data to its optimized + binary representation. + +:: + + :: 'a : 'S -> bytes : 'S + +- ``UNPACK 'a``: Deserializes a piece of data, is valid. + +:: + + :: bytes : 'S -> option 'a : 'S + Cryptographic primitives ~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/src/proto_alpha/lib_protocol/src/alpha_context.mli b/src/proto_alpha/lib_protocol/src/alpha_context.mli index 453878bb4..0776d6b5d 100644 --- a/src/proto_alpha/lib_protocol/src/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/src/alpha_context.mli @@ -177,6 +177,8 @@ module Script : sig | D_Some | D_True | D_Unit + | I_PACK + | I_UNPACK | I_BLAKE2B | I_ABS | I_ADD diff --git a/src/proto_alpha/lib_protocol/src/michelson_v1_gas.ml b/src/proto_alpha/lib_protocol/src/michelson_v1_gas.ml index 1fec742fa..5649a0870 100644 --- a/src/proto_alpha/lib_protocol/src/michelson_v1_gas.ml +++ b/src/proto_alpha/lib_protocol/src/michelson_v1_gas.ml @@ -168,6 +168,9 @@ module Cost_of = struct let compare_res = step_cost 1 + let unpack bytes = 10 *@ step_cost (MBytes.length bytes) + let pack bytes = alloc_bytes_cost (MBytes.length bytes) + (* TODO: protocol operations *) let address = step_cost 3 let contract = Gas.read_bytes_cost Z.zero +@ step_cost 3 diff --git a/src/proto_alpha/lib_protocol/src/michelson_v1_gas.mli b/src/proto_alpha/lib_protocol/src/michelson_v1_gas.mli index 274dde44b..d7e3da74b 100644 --- a/src/proto_alpha/lib_protocol/src/michelson_v1_gas.mli +++ b/src/proto_alpha/lib_protocol/src/michelson_v1_gas.mli @@ -64,6 +64,8 @@ module Cost_of : sig val exec : Gas.cost val push : Gas.cost val compare_res : Gas.cost + val pack : MBytes.t -> Gas.cost + val unpack : MBytes.t -> Gas.cost val address : Gas.cost val contract : Gas.cost val manager : Gas.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 999434a39..d4e52875b 100644 --- a/src/proto_alpha/lib_protocol/src/michelson_v1_primitives.ml +++ b/src/proto_alpha/lib_protocol/src/michelson_v1_primitives.ml @@ -26,6 +26,8 @@ type prim = | D_Some | D_True | D_Unit + | I_PACK + | I_UNPACK | I_BLAKE2B | I_ABS | I_ADD @@ -154,6 +156,8 @@ let string_of_prim = function | D_Some -> "Some" | D_True -> "True" | D_Unit -> "Unit" + | I_PACK -> "PACK" + | I_UNPACK -> "UNPACK" | I_BLAKE2B -> "BLAKE2B" | I_ABS -> "ABS" | I_ADD -> "ADD" @@ -263,6 +267,8 @@ let prim_of_string = function | "Some" -> ok D_Some | "True" -> ok D_True | "Unit" -> ok D_Unit + | "PACK" -> ok I_PACK + | "UNPACK" -> ok I_UNPACK | "BLAKE2B" -> ok I_BLAKE2B | "ABS" -> ok I_ABS | "ADD" -> ok I_ADD @@ -417,6 +423,8 @@ let prim_encoding = ("Some", D_Some) ; ("True", D_True) ; ("Unit", D_Unit) ; + ("PACK", I_PACK) ; + ("UNPACK", I_UNPACK) ; ("BLAKE2B", I_BLAKE2B) ; ("ABS", I_ABS) ; ("ADD", I_ADD) ; 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 f86fc965c..54b6f7989 100644 --- a/src/proto_alpha/lib_protocol/src/michelson_v1_primitives.mli +++ b/src/proto_alpha/lib_protocol/src/michelson_v1_primitives.mli @@ -24,6 +24,8 @@ type prim = | D_Some | D_True | D_Unit + | I_PACK + | I_UNPACK | I_BLAKE2B | I_ABS | I_ADD diff --git a/src/proto_alpha/lib_protocol/src/script_interpreter.ml b/src/proto_alpha/lib_protocol/src/script_interpreter.ml index 686bb54f9..812c8dff1 100644 --- a/src/proto_alpha/lib_protocol/src/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/src/script_interpreter.ml @@ -598,6 +598,22 @@ let rec interp 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) -> + unparse_data ctxt Optimized t value >>=? fun (expr, ctxt) -> + let expr = (Micheline.strip_locations expr) in + let bytes = Data_encoding.Binary.to_bytes_exn Script.expr_encoding expr in + Lwt.return (Gas.consume ctxt (Interp_costs.unpack bytes)) >>=? fun ctxt -> + logged_return (Item (bytes, rest), ctxt) + | Unpack t, Item (bytes, rest) -> + Lwt.return (Gas.consume ctxt (Interp_costs.pack bytes)) >>=? fun ctxt -> + begin match Data_encoding.Binary.of_bytes Script.expr_encoding bytes with + | None -> + logged_return (Item (None, rest), ctxt) + | Some expr -> + parse_data ctxt t (Micheline.root expr) >>=? fun (value, ctxt) -> + logged_return (Item (Some value, rest), ctxt) + end (* protocol *) | Address, Item ((_, contract), rest) -> Lwt.return (Gas.consume ctxt Interp_costs.address) >>=? fun ctxt -> diff --git a/src/proto_alpha/lib_protocol/src/script_ir_annot.ml b/src/proto_alpha/lib_protocol/src/script_ir_annot.ml index 8a3a6e5b2..54825d0f2 100644 --- a/src/proto_alpha/lib_protocol/src/script_ir_annot.ml +++ b/src/proto_alpha/lib_protocol/src/script_ir_annot.ml @@ -28,6 +28,8 @@ let default_cdr_annot = Some (`Field_annot "cdr") let default_contract_annot = Some (`Field_annot "contract") let default_addr_annot = Some (`Field_annot "address") let default_manager_annot = Some (`Field_annot "manager") +let default_pack_annot = Some (`Field_annot "packed") +let default_unpack_annot = Some (`Field_annot "unpacked") let default_elt_annot = Some (`Field_annot "elt") let default_key_annot = Some (`Field_annot "key") diff --git a/src/proto_alpha/lib_protocol/src/script_ir_annot.mli b/src/proto_alpha/lib_protocol/src/script_ir_annot.mli index 7c08ca55f..228f31fad 100644 --- a/src/proto_alpha/lib_protocol/src/script_ir_annot.mli +++ b/src/proto_alpha/lib_protocol/src/script_ir_annot.mli @@ -28,6 +28,8 @@ val default_cdr_annot : field_annot option val default_contract_annot : field_annot option val default_addr_annot : field_annot option val default_manager_annot : field_annot option +val default_pack_annot : field_annot option +val default_unpack_annot : field_annot option val default_elt_annot : field_annot option val default_key_annot : field_annot option 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 12c18dc2f..0ef5b98b1 100644 --- a/src/proto_alpha/lib_protocol/src/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/src/script_ir_translator.ml @@ -209,6 +209,8 @@ let number_of_generated_growing_types : type b a. (b, a) instr -> int = function | Self _ -> 1 | Amount -> 0 | Set_delegate -> 0 + | Pack _ -> 0 + | Unpack _ -> 1 (* ---- Error helpers -------------------------------------------------------*) @@ -239,6 +241,8 @@ let namespace = function | D_Some | D_True | D_Unit -> Constant_namespace + | I_PACK + | I_UNPACK | I_BLAKE2B | I_ABS | I_ADD @@ -1060,6 +1064,35 @@ and parse_ty : T_string ; T_bytes ; T_mutez ; T_bool ; T_key ; T_key_hash ; T_timestamp ] +let check_no_big_map_or_operation loc root = + let rec check : type t. t ty -> unit tzresult = function + | Big_map_t _ -> error (Unexpected_big_map loc) + | Operation_t _ -> error (Unexpected_operation loc) + | Unit_t _ -> ok () + | Int_t _ -> ok () + | Nat_t _ -> ok () + | Signature_t _ -> ok () + | String_t _ -> ok () + | Bytes_t _ -> ok () + | Mutez_t _ -> ok () + | Key_hash_t _ -> ok () + | Key_t _ -> ok () + | Timestamp_t _ -> ok () + | Address_t _ -> ok () + | Bool_t _ -> ok () + | Pair_t ((l_ty, _, _), (r_ty, _, _), _) -> + check l_ty >>? fun () -> check r_ty + | Union_t ((l_ty, _), (r_ty, _), _) -> + check l_ty >>? fun () -> check r_ty + | Lambda_t (l_ty, r_ty, _) -> + check l_ty >>? fun () -> check r_ty + | Option_t ((v_ty, _), _, _) -> check v_ty + | List_t (elt_ty, _) -> check elt_ty + | Set_t (_, _) -> ok () + | Map_t (_, elt_ty, _) -> check elt_ty + | Contract_t (_, _) -> ok () in + check root + let rec unparse_stack : type a. a stack_ty -> (Script.expr * Script.annot) list = function @@ -2240,6 +2273,23 @@ and parse_instr Item_t (t, stack, _) -> parse_var_annot loc annot >>=? fun annot -> (* can erase annot *) typed ctxt loc Nop (Item_t (t, stack, annot)) + (* packing *) + | Prim (loc, I_PACK, [], annot), + Item_t (t, rest, unpacked_annot) -> + Lwt.return (check_no_big_map_or_operation loc t) >>=? fun () -> + parse_var_annot loc annot ~default:(gen_access_annot unpacked_annot default_pack_annot) + >>=? fun annot -> + typed ctxt loc (Pack t) + (Item_t (Bytes_t None, rest, annot)) + | Prim (loc, I_UNPACK, [ ty ], annot), + Item_t (Bytes_t _, rest, packed_annot) -> + Lwt.return @@ parse_ty ~allow_big_map:false ~allow_operation:false ty >>=? fun (Ex_ty t) -> + let stack_annot = gen_access_annot packed_annot default_unpack_annot in + parse_constr_annot loc annot + ~if_special_first:(var_to_field_annot stack_annot) + >>=? fun (annot, ty_name, some_field, none_field) -> + typed ctxt loc (Unpack t) + (Item_t (Option_t ((t, some_field), none_field, ty_name), rest, annot)) (* protocol *) | Prim (loc, I_ADDRESS, [], annot), Item_t (Contract_t _, rest, contract_annot) -> @@ -2802,10 +2852,14 @@ let unparse_script ctxt mode { code ; arg_type ; storage ; storage_type } = return ({ code = lazy_expr (strip_locations code) ; storage = lazy_expr (strip_locations storage) }, ctxt) -let hash_data ctxt typ data = +let pack_data ctxt typ data = unparse_data ctxt Optimized typ data >>=? fun (data, ctxt) -> let unparsed = strip_annotations @@ data in let bytes = Data_encoding.Binary.to_bytes_exn expr_encoding (Micheline.strip_locations unparsed) in + return (bytes, ctxt) + +let hash_data ctxt typ data = + pack_data ctxt typ data >>=? fun (bytes, ctxt) -> return (Script_expr_hash.(hash_bytes [ bytes ]), ctxt) (* ---------------- Big map -------------------------------------------------*) 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 323743dee..e478681e6 100644 --- a/src/proto_alpha/lib_protocol/src/script_ir_translator.mli +++ b/src/proto_alpha/lib_protocol/src/script_ir_translator.mli @@ -95,6 +95,7 @@ val parse_contract : context -> Script.location -> 'a Script_typed_ir.ty -> Contract.t -> (context * 'a Script_typed_ir.typed_contract) tzresult Lwt.t +val pack_data : context -> 'a Script_typed_ir.ty -> 'a -> (MBytes.t * context) tzresult Lwt.t val hash_data : context -> 'a Script_typed_ir.ty -> 'a -> (Script_expr_hash.t * context) tzresult Lwt.t val extract_big_map : 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 442d6d8cf..2535035e0 100644 --- a/src/proto_alpha/lib_protocol/src/script_typed_ir.ml +++ b/src/proto_alpha/lib_protocol/src/script_typed_ir.ml @@ -339,6 +339,10 @@ and ('bef, 'aft) instr = (public_key * (signature * (MBytes.t * 'rest)), bool * 'rest) instr | Hash_key : (public_key * 'rest, public_key_hash * 'rest) instr + | Pack : 'a ty -> + ('a * 'rest, MBytes.t * 'rest) instr + | Unpack : 'a ty -> + (MBytes.t * 'rest, 'a option * 'rest) instr | Blake2b : 'a ty -> ('a * 'rest, MBytes.t * 'rest) instr | Steps_to_quota : (* TODO: check that it always returns a nat *)