diff --git a/src/proto_alpha/lib_protocol/sc_rollup_management_protocol.ml b/src/proto_alpha/lib_protocol/sc_rollup_management_protocol.ml index fdb202b73a23158653c41d0d13e75c613cafda24..fb84a0575c39e9f4721f6113aff63a0f1db2338f 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_management_protocol.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_management_protocol.ml @@ -28,6 +28,8 @@ open Alpha_context type error += | (* `Permanent *) Error_encode_inbox_message | (* `Permanent *) Error_decode_inbox_message + | (* `Permanent *) Error_encode_outbox_message + | (* `Permanent *) Error_decode_outbox_message let () = let open Data_encoding in @@ -54,7 +56,31 @@ let () = ~description:msg unit (function Error_decode_inbox_message -> Some () | _ -> None) - (fun () -> Error_decode_inbox_message) + (fun () -> Error_decode_inbox_message) ; + let msg = + "Failed to encode a rollup management protocol outbox message value" + in + register_error_kind + `Permanent + ~id:"rollup_management_protocol.error_encoding_outbox_message" + ~title:msg + ~pp:(fun fmt () -> Format.fprintf fmt "%s" msg) + ~description:msg + unit + (function Error_encode_outbox_message -> Some () | _ -> None) + (fun () -> Error_encode_outbox_message) ; + let msg = + "Failed to decode a rollup management protocol outbox message value" + in + register_error_kind + `Permanent + ~id:"rollup_management_protocol.error_decoding_outbox_message" + ~title:msg + ~pp:(fun fmt () -> Format.fprintf fmt "%s" msg) + ~description:msg + unit + (function Error_decode_outbox_message -> Some () | _ -> None) + (fun () -> Error_decode_outbox_message) type sc_message = { payload : Script_repr.expr; @@ -66,6 +92,35 @@ type sc_message = { type inbox_message = Sc_message of sc_message +type transaction_internal = { + unparsed_parameters_ty : Script_repr.expr; (** The type of the parameters. *) + unparsed_parameters : Script_repr.expr; (** The payload. *) + destination : Destination.t; (** The recipient contract or rollup. *) + entrypoint : Entrypoint.t; (** Entrypoint of the destination. *) +} + +type atomic_message_batch_internal = { + transactions_internal : transaction_internal list; +} + +type outbox_message_internal = + | Atomic_transaction_batch_internal of atomic_message_batch_internal + +type transaction = + | Transaction : { + destination : Destination.t; + entrypoint : Entrypoint.t; + parameters_ty : ('a, _) Script_typed_ir.ty; + parameters : 'a; + unparsed_parameters_ty : Script.expr; + unparsed_parameters : Script.expr; + } + -> transaction + +type atomic_transaction_batch = {transactions : transaction list} + +type outbox_message = Atomic_transaction_batch of atomic_transaction_batch + let make_inbox_message ctxt ty ~payload ~sender ~source = let open Lwt_tzresult_syntax in let+ (payload, ctxt) = @@ -78,7 +133,7 @@ let make_inbox_message ctxt ty ~payload ~sender ~source = let payload = Micheline.strip_locations payload in (Sc_message {payload; sender; source}, ctxt) -let sc_inbox_message_encoding = +let sc_message_encoding = let open Data_encoding in conv (fun {payload; sender; source} -> (payload, sender, source)) @@ -88,21 +143,179 @@ let sc_inbox_message_encoding = (req "sender" Contract.encoding) (req "source" Signature.Public_key_hash.encoding) -let inbox_message_encoding = +let transaction_internal_encoding = let open Data_encoding in conv - (fun (Sc_message m) -> m) - (fun m -> Sc_message m) - sc_inbox_message_encoding + (fun {unparsed_parameters_ty; unparsed_parameters; destination; entrypoint} -> + (unparsed_parameters_ty, unparsed_parameters, destination, entrypoint)) + (fun (unparsed_parameters_ty, unparsed_parameters, destination, entrypoint) -> + {unparsed_parameters_ty; unparsed_parameters; destination; entrypoint}) + @@ obj4 + (req "parameters_ty" Script_repr.expr_encoding) + (req "parameters" Script_repr.expr_encoding) + (req "destination" Destination.encoding) + (req "entrypoint" Entrypoint.simple_encoding) + +let atomic_message_batch_encoding = + let open Data_encoding in + obj1 + (req + "transactions" + (conv + (fun {transactions_internal} -> transactions_internal) + (fun transactions_internal -> {transactions_internal}) + (list transaction_internal_encoding))) +let internal_outbox_message_encoding = + let open Data_encoding in + conv + (fun (Atomic_transaction_batch_internal m) -> m) + (fun m -> Atomic_transaction_batch_internal m) + atomic_message_batch_encoding + +let inbox_message_encoding = + let open Data_encoding in + conv (fun (Sc_message m) -> m) (fun m -> Sc_message m) sc_message_encoding + +(** TODO: #2951 + Carbonate [to_bytes] step. + Gas for encoding the value in binary format should be accounted for. + *) let bytes_of_inbox_message msg = let open Tzresult_syntax in match Data_encoding.Binary.to_bytes_opt inbox_message_encoding msg with | None -> fail Error_encode_inbox_message | Some bs -> return bs -let inbox_message_of_bytes bytes = - let open Tzresult_syntax in - match Data_encoding.Binary.of_bytes_opt inbox_message_encoding bytes with - | None -> fail Error_decode_inbox_message - | Some deposit -> return deposit +let transactions_batch_of_internal ctxt {transactions_internal} = + let open Lwt_tzresult_syntax in + let or_internal_transaction ctxt + {unparsed_parameters_ty; unparsed_parameters; destination; entrypoint} = + let*? (Ex_ty parameters_ty, ctxt) = + Script_ir_translator.parse_ty + ~legacy:false + ~allow_lazy_storage:false + ~allow_contract:false + ~allow_ticket:true + ~allow_operation:false + ctxt + (Micheline.root unparsed_parameters_ty) + in + (* TODO: #2964 + We should rule out big-maps. + [allow_forged] controls both tickets and big-maps. Here we only want to + allow tickets. *) + let* (parameters, ctxt) = + Script_ir_translator.parse_data + ctxt + ~legacy:false + ~allow_forged:true + parameters_ty + (Micheline.root unparsed_parameters) + in + return + ( Transaction + { + destination; + entrypoint; + parameters_ty; + parameters; + unparsed_parameters_ty; + unparsed_parameters; + }, + ctxt ) + in + let+ (ctxt, transactions) = + List.fold_left_map_es + (fun ctxt msg -> + let+ (t, ctxt) = or_internal_transaction ctxt msg in + (ctxt, t)) + ctxt + transactions_internal + in + ({transactions}, ctxt) + +(** TODO: #2951 + Carbonate [of_bytes] step. + Gas for decoding the binary values should be be accounted for. + *) +let outbox_message_of_bytes ctxt bytes = + let open Lwt_tzresult_syntax in + let*? (Atomic_transaction_batch_internal msg) = + match + Data_encoding.Binary.of_bytes_opt internal_outbox_message_encoding bytes + with + | Some x -> ok x + | None -> error Error_decode_inbox_message + in + let+ (ts, ctxt) = transactions_batch_of_internal ctxt msg in + (Atomic_transaction_batch ts, ctxt) + +module Internal_for_tests = struct + let make_transaction ctxt parameters_ty ~parameters ~destination ~entrypoint = + let open Lwt_tzresult_syntax in + let* (unparsed_parameters, ctxt) = + Script_ir_translator.unparse_data ctxt Optimized parameters_ty parameters + in + let*? (unparsed_parameters_ty, ctxt) = + Script_ir_translator.unparse_ty + ctxt + ~loc:Micheline.dummy_location + parameters_ty + in + let*? ctxt = + Gas.consume ctxt (Script.strip_locations_cost unparsed_parameters) + in + let unparsed_parameters = Micheline.strip_locations unparsed_parameters in + let*? ctxt = + Gas.consume ctxt (Script.strip_locations_cost unparsed_parameters_ty) + in + let unparsed_parameters_ty = + Micheline.strip_locations unparsed_parameters_ty + in + return + ( Transaction + { + destination; + entrypoint; + parameters_ty; + parameters; + unparsed_parameters_ty; + unparsed_parameters; + }, + ctxt ) + + let make_atomic_batch transactions = Atomic_transaction_batch {transactions} + + let bytes_of_outbox_message (Atomic_transaction_batch {transactions}) = + let open Tzresult_syntax in + let to_internal_transaction + (Transaction + { + destination; + entrypoint; + parameters_ty = _; + parameters = _; + unparsed_parameters_ty; + unparsed_parameters; + }) = + {unparsed_parameters; unparsed_parameters_ty; destination; entrypoint} + in + let output_message_internal = + Atomic_transaction_batch_internal + {transactions_internal = List.map to_internal_transaction transactions} + in + match + Data_encoding.Binary.to_bytes_opt + internal_outbox_message_encoding + output_message_internal + with + | Some x -> return x + | None -> fail Error_encode_inbox_message + + let inbox_message_of_bytes bytes = + let open Tzresult_syntax in + match Data_encoding.Binary.of_bytes_opt inbox_message_encoding bytes with + | None -> fail Error_decode_inbox_message + | Some deposit -> return deposit +end diff --git a/src/proto_alpha/lib_protocol/sc_rollup_management_protocol.mli b/src/proto_alpha/lib_protocol/sc_rollup_management_protocol.mli index dba8bba873334634e34ca96dac9a932240eb4b5b..d664602166fbd6332e8d9d5695957e504200fb50 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_management_protocol.mli +++ b/src/proto_alpha/lib_protocol/sc_rollup_management_protocol.mli @@ -36,6 +36,10 @@ - [source] the public key hash used for originating the transaction. The Layer 2 node is responsible for decoding and interpreting the messages. + + Another type {!outbox_message} representing messages from Layer 2 to Layer 1 + is also provided. An {!outbox_message} consists of a set of transactions + to L1 accounts. *) open Alpha_context @@ -43,6 +47,25 @@ open Alpha_context (** A type representing messages from Layer 1 to Layer 2. *) type inbox_message +(** A type representing a Layer 2 to Layer 1 transaction. *) +type transaction = private + | Transaction : { + destination : Destination.t; + entrypoint : Entrypoint.t; + parameters_ty : ('a, _) Script_typed_ir.ty; + parameters : 'a; + unparsed_parameters_ty : Script.expr; + unparsed_parameters : Script.expr; + } + -> transaction + +(** A type representing a batch of Layer 2 to Layer 1 transactions. *) +type atomic_transaction_batch = private {transactions : transaction list} + +(** A type representing messages from Layer 2 to Layer 1. *) +type outbox_message = private + | Atomic_transaction_batch of atomic_transaction_batch + (** [make_inbox_message ctxt ty ~payload ~sender ~source] constructs a SCORU [inbox message] (an L1 to L2 message) with the given [payload], [sender], and [source]. *) @@ -54,10 +77,40 @@ val make_inbox_message : source:public_key_hash -> (inbox_message * context) tzresult Lwt.t -(** [bytes_of_inbox_message msg] encodes an inbox message [msg] in binary +(** [bytes_of_inbox_message msg] encodes the inbox message [msg] in binary format. *) val bytes_of_inbox_message : inbox_message -> bytes tzresult -(** [inbox_message_of_bytes bs] decodes an inbox message from the given bytes - [bs]. *) -val inbox_message_of_bytes : bytes -> inbox_message tzresult +(** [outbox_message_of_bytes ctxt bs] decodes an outbox message value from the + given bytes [bs]. The function involves parsing Micheline expressions to + typed values. *) +val outbox_message_of_bytes : + context -> bytes -> (outbox_message * context) tzresult Lwt.t + +(** Function for constructing and encoding {!inbox_message} and + {!outbox_message} values. Since Layer 1 only ever consumes {!outbox_message} + values and produces {!inbox_message} values, these functions are used for + testing only. *) +module Internal_for_tests : sig + (** [make_transaction ctxt ty ~parameters ~destination ~entrypoint] creates a + Layer 1 to Layer 2 transaction. *) + val make_transaction : + context -> + ('a, _) Script_typed_ir.ty -> + parameters:'a -> + destination:Destination.t -> + entrypoint:Entrypoint.t -> + (transaction * context) tzresult Lwt.t + + (** [make_atomic_batch ts] creates an atomic batch with the given + transactions [ts]. *) + val make_atomic_batch : transaction list -> outbox_message + + (** [bytes_of_output_message msg] encodes the outbox message [msg] in binary + format. *) + val bytes_of_outbox_message : outbox_message -> bytes tzresult + + (** [inbox_message_of_bytes bs] decodes an inbox message from the given bytes + [bs]. *) + val inbox_message_of_bytes : bytes -> inbox_message tzresult +end diff --git a/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_management_protocol.ml b/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_management_protocol.ml index 41684fc5dc17942c39eb8ce5075f1e8023d20a0b..998f3cd76bc779dae0ac452bcbaca4823676d58d 100644 --- a/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_management_protocol.ml +++ b/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_management_protocol.ml @@ -36,19 +36,30 @@ open Alpha_context let wrap m = m >|= Environment.wrap_tzresult -let check_encode_decode_inbox_message effect = +let check_encode_decode_inbox_message message = let open Lwt_result_syntax in - let*? bytes = - Environment.wrap_tzresult - @@ Sc_rollup_management_protocol.bytes_of_inbox_message effect - in + let open Sc_rollup_management_protocol in + let*? bytes = Environment.wrap_tzresult @@ bytes_of_inbox_message message in let*? message' = + Environment.wrap_tzresult @@ Internal_for_tests.inbox_message_of_bytes bytes + in + let*? bytes' = Environment.wrap_tzresult @@ bytes_of_inbox_message message' in + Assert.equal_string + ~loc:__LOC__ + (Bytes.to_string bytes) + (Bytes.to_string bytes') + +let check_encode_decode_outbox_message ctxt message = + let open Lwt_result_syntax in + let open Sc_rollup_management_protocol in + let*? bytes = Environment.wrap_tzresult - @@ Sc_rollup_management_protocol.inbox_message_of_bytes bytes + @@ Internal_for_tests.bytes_of_outbox_message message in + let* (message', _ctxt) = wrap @@ outbox_message_of_bytes ctxt bytes in let*? bytes' = Environment.wrap_tzresult - @@ Sc_rollup_management_protocol.bytes_of_inbox_message message' + @@ Internal_for_tests.bytes_of_outbox_message message' in Assert.equal_string ~loc:__LOC__ @@ -70,7 +81,7 @@ let init_ctxt () = let+ incr = Incremental.begin_construction block in Incremental.alpha_ctxt incr -let test_encode_decode_deposit () = +let test_encode_decode_inbox_message () = let open WithExceptions in let open Lwt_result_syntax in let* ctxt = init_ctxt () in @@ -106,5 +117,62 @@ let test_encode_decode_deposit () = in check_encode_decode_inbox_message deposit +let test_encode_decode_outbox_message () = + let open Lwt_result_syntax in + let* ctxt = init_ctxt () in + let*? (Script_typed_ir.Ty_ex_c pair_nat_ticket_string_ty) = + Environment.wrap_tzresult + (let open Result_syntax in + let open Script_typed_ir in + let* ticket_t = ticket_t (-1) string_t in + pair_t (-1) nat_t ticket_t) + in + let parameters = + ( Script_int.(abs @@ of_int 42), + string_ticket "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1 ) + in + let* (transaction1, ctxt) = + let*? destination_contract = + Environment.wrap_tzresult + (Contract.of_b58check "KT1BuEZtb68c1Q4yjtckcNjGELqWt56Xyesc") + in + let destination = Destination.Contract destination_contract in + wrap + @@ Sc_rollup_management_protocol.Internal_for_tests.make_transaction + ctxt + pair_nat_ticket_string_ty + ~parameters + ~destination + ~entrypoint:Entrypoint.default + in + let* (transaction2, ctxt) = + let*? destination_contract = + Environment.wrap_tzresult + (Contract.of_b58check "KT1BuEZtb68c1Q4yjtckcNjGELqWt56Xyesc") + in + let destination = Destination.Contract destination_contract in + wrap + @@ Sc_rollup_management_protocol.Internal_for_tests.make_transaction + ctxt + Script_typed_ir.nat_t + ~parameters:Script_int.(abs @@ of_int 10) + ~destination + ~entrypoint:Entrypoint.default + in + let outbox_message = + Sc_rollup_management_protocol.Internal_for_tests.make_atomic_batch + [transaction1; transaction2] + in + check_encode_decode_outbox_message ctxt outbox_message + let tests = - [Tztest.tztest "Encode/decode deposit" `Quick test_encode_decode_deposit] + [ + Tztest.tztest + "Encode/decode inbox message" + `Quick + test_encode_decode_inbox_message; + Tztest.tztest + "Encode/decode outbox message" + `Quick + test_encode_decode_outbox_message; + ]