diff --git a/src/proto_alpha/lib_protocol/alpha_context.ml b/src/proto_alpha/lib_protocol/alpha_context.ml index d5ce87a64ef9a5f5610c160b39d2ee762309a75a..1479516c0b510dffa7a44c9f5657c7e477fd62d2 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.ml +++ b/src/proto_alpha/lib_protocol/alpha_context.ml @@ -269,8 +269,8 @@ module Tx_rollup_message = struct let make_batch string = make_message @@ Batch string - let make_deposit destination ticket_hash amount = - make_message @@ Deposit {destination; ticket_hash; amount} + let make_deposit sender destination ticket_hash amount = + make_message @@ Deposit {sender; destination; ticket_hash; amount} end module Tx_rollup_inbox = struct diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index 892c0b2d4583df1a4f534e1ce81c16d929c64b07..3d2f3d44759c8786ea28275f7a08f3e6bae533c6 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -2013,6 +2013,15 @@ module Ticket_hash : sig contents:Script.node -> owner:Script.node -> (t * context) tzresult + + module Internal_for_tests : sig + val make_uncarbonated : + ticketer:Script.node -> + ty:Script.node -> + contents:Script.node -> + owner:Script.node -> + t tzresult + end end module Tx_rollup_level : sig @@ -2143,6 +2152,7 @@ end (** This module re-exports definitions from {!Tx_rollup_message_repr}. *) module Tx_rollup_message : sig type deposit = { + sender : public_key_hash; destination : Tx_rollup_l2_address.Indexable.value; ticket_hash : Ticket_hash.t; amount : Tx_rollup_l2_qty.t; @@ -2160,6 +2170,7 @@ module Tx_rollup_message : sig along with its size in bytes. See {!Tx_rollup_message_repr.size}. *) val make_deposit : + public_key_hash -> Tx_rollup_l2_address.t Indexable.value -> Ticket_hash.t -> Tx_rollup_l2_qty.t -> diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index 0d0a51ac62acb1fa920df82ff9847f056b71cb7b..962011285f32c551bfe4abe1baaeff53788c44b6 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -1063,8 +1063,24 @@ let apply_manager_operation_content : -> Tx_rollup.hash_ticket ctxt dst ~contents ~ticketer ~ty >>?= fun (ticket_hash, ctxt) -> + (* The deposit is returned to the [payer] as a withdrawal + if it fails due to a Balance_overflow in the + recipient. The recipient of withdrawals are always + implicit. We set the withdrawal recipient to [payer]: + the protocol ensures that [payer] is implicit, yet we + must do this conversion. *) + Option.value_e + ~error: + (Error_monad.trace_of_error + Tx_rollup_operation_with_non_implicit_contract) + (Contract.is_implicit payer) + >>?= fun payer_implicit -> let (deposit, message_size) = - Tx_rollup_message.make_deposit destination ticket_hash amount + Tx_rollup_message.make_deposit + payer_implicit + destination + ticket_hash + amount in Tx_rollup_state.get ctxt dst >>=? fun (ctxt, state) -> Tx_rollup_state.burn_cost ~limit:None state message_size diff --git a/src/proto_alpha/lib_protocol/indexable.ml b/src/proto_alpha/lib_protocol/indexable.ml index f2c95de4e8d7c5cf2f931ba0e12073327f6018a7..627d318334c7bc90e6d39d352cb83366d71e1a6d 100644 --- a/src/proto_alpha/lib_protocol/indexable.ml +++ b/src/proto_alpha/lib_protocol/indexable.ml @@ -97,6 +97,10 @@ let to_int32 = function Index x -> x let to_value = function Value x -> x +let is_value_e : error:'trace -> ('state, 'a) t -> ('a, 'trace) result = + fun ~error v -> + match destruct v with Left _ -> Result.error error | Right v -> Result.ok v + let compact val_encoding = Data_encoding.Compact.( conv diff --git a/src/proto_alpha/lib_protocol/indexable.mli b/src/proto_alpha/lib_protocol/indexable.mli index 9c4f4d80a55a5e1da8816463b223a8732649a21e..fa631ae1f10c2e280d6ba99ce920ed55435a9714 100644 --- a/src/proto_alpha/lib_protocol/indexable.mli +++ b/src/proto_alpha/lib_protocol/indexable.mli @@ -115,6 +115,10 @@ val to_int32 : 'a index -> int32 (** [to_value x] unwraps and returns the value behind [x]. *) val to_value : 'a value -> 'a +(** [is_value_e err x] unwraps and returns the value behind [x], and + throws an [err] if [x] is an index. *) +val is_value_e : error:'trace -> ('state, 'a) t -> ('a, 'trace) result + (** [in_memory_size a] returns the number of bytes allocated in RAM for [a]. *) val in_memory_size : ('a -> Cache_memory_helpers.sint) -> diff --git a/src/proto_alpha/lib_protocol/test/helpers/tx_rollup_l2_helpers.ml b/src/proto_alpha/lib_protocol/test/helpers/tx_rollup_l2_helpers.ml index 3c8f8f66d3a3d933a6e478fe54be1c6ef9d6b294..611a99257ef992689065524da37b8f700a2a9abe 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/tx_rollup_l2_helpers.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/tx_rollup_l2_helpers.ml @@ -94,6 +94,8 @@ let empty_context : Context_l2.t = empty_storage let rng_state = Random.State.make_self_init () +let gen_l1_address ?seed () = Signature.generate_key ~algo:Ed25519 ?seed () + let gen_l2_address () = let seed = Bytes.init 32 (fun _ -> char_of_int @@ Random.State.int rng_state 255) @@ -102,7 +104,9 @@ let gen_l2_address () = let public_key = Bls12_381.Signature.MinPk.derive_pk secret_key in (secret_key, public_key, Tx_rollup_l2_address.of_bls_pk public_key) -let make_unit_ticket_key ctxt ticketer address = +(** [make_unit_ticket_key ctxt ticketer tx_rollup] computes the key hash of + the unit ticket crafted by [ticketer] and owned by [tx_rollup]. *) +let make_unit_ticket_key ticketer tx_rollup = let open Tezos_micheline.Micheline in let open Michelson_v1_primitives in let ticketer = @@ -115,11 +119,14 @@ let make_unit_ticket_key ctxt ticketer address = let ty = Prim (0, T_unit, [], []) in let contents = Prim (0, D_Unit, [], []) in let owner = - String (dummy_location, Tx_rollup_l2_address.to_b58check address) + String (dummy_location, Tx_rollup_l2_address.to_b58check tx_rollup) in - match Alpha_context.Ticket_hash.make ctxt ~ticketer ~ty ~contents ~owner with - | Ok (x, _) -> x - | Error _ -> raise (Invalid_argument "make_unit_ticket_key") + Alpha_context.Ticket_hash.Internal_for_tests.make_uncarbonated + ~ticketer + ~ty + ~contents + ~owner + |> WithExceptions.Result.get_ok ~loc:__LOC__ let gen_n_address n = List.init ~when_negative_length:[] n (fun _ -> gen_l2_address ()) |> function @@ -129,15 +136,13 @@ let gen_n_address n = let gen_n_ticket_hash n = let x = Lwt_main.run - ( Context.init n >>=? fun (b, contracts) -> - Incremental.begin_construction b >|=? Incremental.alpha_ctxt - >>=? fun ctxt -> + ( Context.init n >>=? fun (_, contracts) -> let addressess = gen_n_address n in let tickets = List.map2 ~when_different_lengths:[] (fun contract (_, _, address) -> - make_unit_ticket_key ctxt contract address) + make_unit_ticket_key contract address) contracts addressess in diff --git a/src/proto_alpha/lib_protocol/test/integration/operations/test_tx_rollup.ml b/src/proto_alpha/lib_protocol/test/integration/operations/test_tx_rollup.ml index e9e5526ff27548317dc02653db823669d971a119..8f1966e67d9ec39bb32bb0071ab9a2530ace5be9 100644 --- a/src/proto_alpha/lib_protocol/test/integration/operations/test_tx_rollup.ml +++ b/src/proto_alpha/lib_protocol/test/integration/operations/test_tx_rollup.ml @@ -120,6 +120,14 @@ let context_init n = } n +(** [context_init1] initializes a context with no consensus rewards + to not interfere with balances prediction. It returns the created + context and 1 contract. *) +let context_init1 () = + context_init 1 >|=? function + | (_, []) -> assert false + | (b, contract_1 :: _) -> (b, contract_1) + (** [originate b contract] originates a tx_rollup from [contract], and returns the new block and the tx_rollup address. *) let originate b contract = @@ -637,6 +645,7 @@ let test_valid_deposit () = let ticket_hash = make_unit_ticket_key ctxt contract tx_rollup in let (message, _size) = Tx_rollup_message.make_deposit + (is_implicit_exn account) (Tx_rollup_l2_address.Indexable.value pkh) ticket_hash (Tx_rollup_l2_qty.of_int64_exn 10L) diff --git a/src/proto_alpha/lib_protocol/test/pbt/test_tx_rollup_l2_encoding.ml b/src/proto_alpha/lib_protocol/test/pbt/test_tx_rollup_l2_encoding.ml index 5155a5ff3f56efb3b129472b9ed68a019d47d33f..dd9171d83dda40f7c9cc86839328e9620fc741bc 100644 --- a/src/proto_alpha/lib_protocol/test/pbt/test_tx_rollup_l2_encoding.ml +++ b/src/proto_alpha/lib_protocol/test/pbt/test_tx_rollup_l2_encoding.ml @@ -51,9 +51,11 @@ let bls_pk_gen = let signer_gen : Signer_indexable.either QCheck2.Gen.t = let open QCheck2.Gen in - let* choice = bool in - if choice then (fun pk -> from_value pk) <$> bls_pk_gen - else (fun x -> from_index_exn x) <$> ui32 + frequency + [ + (1, (fun pk -> from_value pk) <$> bls_pk_gen); + (9, (fun x -> from_index_exn x) <$> ui32); + ] let signer_index_gen : Signer_indexable.index QCheck2.Gen.t = let open QCheck2.Gen in @@ -63,23 +65,43 @@ let l2_address_gen = let open QCheck2.Gen in Protocol.Tx_rollup_l2_address.of_bls_pk <$> bls_pk_gen +let public_key_hash = + Signature.Public_key_hash.of_b58check_exn + "tz1Ke2h7sDdakHJQh8WX4Z372du1KChsksyU" + let destination_gen = let open QCheck2.Gen in let* choice = bool in - if choice then - return - @@ Layer1 - (Signature.Public_key_hash.of_b58check_exn - "tz1Ke2h7sDdakHJQh8WX4Z372du1KChsksyU") + if choice then return (Layer1 public_key_hash) else let* choice = bool in if choice then (fun x -> Layer2 (from_index_exn x)) <$> ui32 else (fun x -> Layer2 (from_value x)) <$> l2_address_gen -let ticket_hash_gen = +let ticket_hash_gen : Protocol.Alpha_context.Ticket_hash.t QCheck2.Gen.t = + let open QCheck2.Gen in + (* TODO: https://gitlab.com/tezos/tezos/-/issues/2592 + we could introduce a bit more randomness here *) + let ticketer_b58 = "tz1Ke2h7sDdakHJQh8WX4Z372du1KChsksyU" in + let ticketer_pkh = Signature.Public_key_hash.of_b58check_exn ticketer_b58 in + let ticketer = + Protocol.Alpha_context.Contract.implicit_contract ticketer_pkh + in + let+ tx_rollup = l2_address_gen in + Tx_rollup_l2_helpers.make_unit_ticket_key ticketer tx_rollup + +let idx_ticket_hash_idx_gen : Ticket_indexes.key either QCheck2.Gen.t = let open QCheck2.Gen in from_index_exn <$> ui32 +let idx_ticket_hash_value_gen : Ticket_indexes.key either QCheck2.Gen.t = + let open QCheck2.Gen in + from_value <$> ticket_hash_gen + +let idx_ticket_hash_gen : Ticket_indexes.key either QCheck2.Gen.t = + let open QCheck2.Gen in + oneof [idx_ticket_hash_idx_gen; idx_ticket_hash_value_gen] + let qty_gen = let open QCheck2.Gen in Protocol.Tx_rollup_l2_qty.of_int64_exn @@ -87,9 +109,14 @@ let qty_gen = let v1_operation_content_gen = let open QCheck2.Gen in - let+ destination = destination_gen - and+ ticket_hash = ticket_hash_gen - and+ qty = qty_gen in + let* destination = destination_gen and+ qty = qty_gen in + (* in valid [operation_content]s, the ticket_hash is a value when the + destination is layer1 *) + let+ ticket_hash = + match destination with + | Layer1 _ -> idx_ticket_hash_value_gen + | Layer2 _ -> idx_ticket_hash_gen + in V1.{destination; ticket_hash; qty} let v1_operation_gen = @@ -190,7 +217,7 @@ let batch_v1_result_gen : Message_result.Batch_V1.t QCheck2.Gen.t = let+ indexes = indexes_gen in Message_result.Batch_V1.Batch_result {results; indexes} -let message_result : Message_result.t QCheck2.Gen.t = +let message_result : Message_result.message_result QCheck2.Gen.t = let open QCheck2.Gen in let open Message_result in let batch_v1_result_gen = @@ -199,6 +226,19 @@ let message_result : Message_result.t QCheck2.Gen.t = in frequency [(2, deposit_result_gen); (8, batch_v1_result_gen)] +let withdrawal : Message_result.withdrawal QCheck2.Gen.t = + let open QCheck2.Gen in + let open Message_result in + let destination = public_key_hash in + let* ticket_hash = ticket_hash_gen in + let* amount = qty_gen in + return {destination; ticket_hash; amount} + +let message_result_withdrawal : Message_result.t QCheck2.Gen.t = + let open QCheck2.Gen in + let+ mres = message_result and+ withdrawals = list withdrawal in + (mres, withdrawals) + let pp fmt _ = Format.fprintf fmt "{}" (* ------ test template ----------------------------------------------------- *) @@ -281,7 +321,7 @@ let () = test_roundtrip ~count:1_000 "message_result" - message_result + message_result_withdrawal ( = ) Protocol.Tx_rollup_l2_apply.Message_result.encoding; ] ); diff --git a/src/proto_alpha/lib_protocol/test/unit/test_tx_rollup_l2.ml b/src/proto_alpha/lib_protocol/test/unit/test_tx_rollup_l2.ml index 7337f7fb3182428861016665fe272755f0338273..ff92e7f3dcaa68f130cf80d4bcfe991fbc177588 100644 --- a/src/proto_alpha/lib_protocol/test/unit/test_tx_rollup_l2.ml +++ b/src/proto_alpha/lib_protocol/test/unit/test_tx_rollup_l2.ml @@ -36,7 +36,7 @@ open Tztest open Tx_rollup_l2_helpers open Protocol -open Tx_rollup_l2_context +open Tx_rollup_l2_context_sig (** {1. Storage and context tests. } *) @@ -514,67 +514,157 @@ end (* ------ L2 Batch encodings ------------------------------------------------ *) -let test_l2_operation_size () = - let open Protocol.Tx_rollup_l2_batch.V1 in - let open Data_encoding in +module Test_batch_encodings = struct + open Lwt_result_syntax + open Protocol.Tx_rollup_l2_batch.V1 + open Data_encoding + (* Encoding from compact encoding *) let operation_content_encoding = Compact.make ~tag_size:`Uint8 compact_operation_content - in - let operation_encoding = Compact.make ~tag_size:`Uint8 compact_operation in - let transaction_encoding = - Compact.make ~tag_size:`Uint8 compact_transaction - in + + let operation_encoding = Compact.make ~tag_size:`Uint8 compact_operation + + let transaction_encoding = Compact.make ~tag_size:`Uint8 compact_transaction + (* Helper functions to encode and decode *) - let encode_content op = Binary.to_bytes_exn operation_content_encoding op in + let encode_content op = Binary.to_bytes_exn operation_content_encoding op + let decode_content buffer = Data_encoding.Binary.of_bytes_exn operation_content_encoding buffer - in - let encode_operation op = Binary.to_bytes_exn operation_encoding op in - let decode_operation buffer = Binary.of_bytes_exn operation_encoding buffer in - let encode_transaction t = Binary.to_bytes_exn transaction_encoding t in + + let encode_operation op = Binary.to_bytes_exn operation_encoding op + + let decode_operation buffer = Binary.of_bytes_exn operation_encoding buffer + + let encode_transaction t = Binary.to_bytes_exn transaction_encoding t + let decode_transaction buffer = Binary.of_bytes_exn transaction_encoding buffer - in - (* Assert the smallest operation_content size is 4 *) - let opc = - { - destination = Layer2 (Indexable.from_index_exn 0l); - ticket_hash = Indexable.from_index_exn 1l; - qty = Tx_rollup_l2_qty.of_int64_exn 12L; - } - in - let buffer = encode_content opc in - let opc' = decode_content buffer in + let destination_pp fmt = + let open Protocol.Tx_rollup_l2_batch in + function + | Layer1 pkh -> Signature.Public_key_hash.pp fmt pkh + | Layer2 l2 -> Tx_rollup_l2_address.Indexable.pp fmt l2 + + let operation_content_pp fmt = function + | {destination; ticket_hash; qty} -> + Format.fprintf + fmt + "@[Operation:@ destination=%a,@ ticket_hash=%a,@ qty:%a@]" + destination_pp + destination + Tx_rollup_l2_context_sig.Ticket_indexable.pp + ticket_hash + Tx_rollup_l2_qty.pp + qty + + let test_l2_operation_size () = + (* Assert the smallest operation_content size is 4 *) + let opc = + { + destination = Layer2 (Indexable.from_index_exn 0l); + ticket_hash = Indexable.from_index_exn 1l; + qty = Tx_rollup_l2_qty.of_int64_exn 12L; + } + in + let buffer = encode_content opc in + let opc' = decode_content buffer in - Alcotest.(check int "smallest transfer content" 4 (Bytes.length buffer)) ; - assert (opc = opc') ; + Alcotest.(check int "smallest transfer content" 4 (Bytes.length buffer)) ; + assert (opc = opc') ; - (* Assert the smallest operation size is 7 *) - let op = - {signer = Indexable.from_index_exn 2l; counter = 0L; contents = [opc]} - in - let buffer = encode_operation op in - let op' = decode_operation buffer in + (* Assert the smallest operation size is 7 *) + let op = + {signer = Indexable.from_index_exn 2l; counter = 0L; contents = [opc]} + in + let buffer = encode_operation op in + let op' = decode_operation buffer in - Alcotest.(check int "smallest transfer" 7 (Bytes.length buffer)) ; - assert (op = op') ; + Alcotest.(check int "smallest transfer" 7 (Bytes.length buffer)) ; + assert (op = op') ; - (* Assert the smallest transaction size is 8 *) - let t = [op] in - let buffer = encode_transaction t in - let t' = decode_transaction buffer in + (* Assert the smallest transaction size is 8 *) + let t = [op] in + let buffer = encode_transaction t in + let t' = decode_transaction buffer in - Alcotest.(check int "smallest transaction" 8 (Bytes.length buffer)) ; - assert (t = t') ; + Alcotest.(check int "smallest transaction" 8 (Bytes.length buffer)) ; + assert (t = t') ; - return_unit + return_unit + + let test_l2_operation_encode_guard () = + let invalid_indexed_l2_to_l1_op = + { + destination = Layer1 Signature.Public_key_hash.zero; + ticket_hash = Indexable.from_index_exn 1l; + qty = Tx_rollup_l2_qty.of_int64_exn 12L; + } + in + let* _ = + try + let buffer = encode_content invalid_indexed_l2_to_l1_op in + Alcotest.failf + "Expected encoding of layer2-to-layer1 operation_content with \ + indexed ticket to fail. Binary output: %s" + Hex.(of_bytes buffer |> show) + with + | Data_encoding.Binary.Write_error + (Exception_raised_in_user_function + "(Invalid_argument\n\ + \ \"Attempted to decode layer2 operation containing ticket \ + index.\")") + -> + return_unit + in + return_unit + + let test_l2_operation_decode_guard () = + let invalid_indexed_l2_to_l1_op_serialized = + Hex.( + `Hex "00000000000000000000000000000000000000000000010c" |> to_bytes + |> Stdlib.Option.get) + in + let* _ = + try + let invalid_indexed_l2_to_l1_op = + decode_content invalid_indexed_l2_to_l1_op_serialized + in + Alcotest.failf + "Expected decoding of layer2-to-layer1 operation_content with \ + indexed ticket to fail. Got operation: %a" + operation_content_pp + invalid_indexed_l2_to_l1_op + with + | Data_encoding.Binary.Read_error + (Exception_raised_in_user_function + "(Invalid_argument\n\ + \ \"Attempted to decode layer2 operation containing ticket \ + index.\")") -> + return_unit + | e -> + Alcotest.failf "Got unexpected exception: %s" (Printexc.to_string e) + in + return_unit + + let tests = + [ + tztest "test layer-2 operation encoding size" `Quick test_l2_operation_size; + tztest + "test layer-2 operation encoding guard" + `Quick + test_l2_operation_encode_guard; + tztest + "test layer-2 operation decoding guard" + `Quick + test_l2_operation_decode_guard; + ] +end let tests = [tztest "test irmin storage" `Quick @@ wrap_test test_irmin_storage] @ Test_Address_index.tests @ Test_Ticket_index.tests @ Test_Address_medata.tests @ Test_Ticket_ledger.tests - @ [ - tztest "test layer-2 operation encoding size" `Quick test_l2_operation_size; - ] + @ Test_batch_encodings.tests diff --git a/src/proto_alpha/lib_protocol/test/unit/test_tx_rollup_l2_apply.ml b/src/proto_alpha/lib_protocol/test/unit/test_tx_rollup_l2_apply.ml index ee863b55b2c59f27c06c536c5eee0a26b125479d..15dc041ac94644a52b2e9be1aacdca9eb3ca4445 100644 --- a/src/proto_alpha/lib_protocol/test/unit/test_tx_rollup_l2_apply.ml +++ b/src/proto_alpha/lib_protocol/test/unit/test_tx_rollup_l2_apply.ml @@ -48,6 +48,8 @@ open Indexable (** {3. Various helpers to facilitate the tests. } *) +let pkh = Signature.Public_key_hash.zero + let ((_, pk1, addr1) as l2_addr1) = gen_l2_address () let ((_, pk2, addr2) as l2_addr2) = gen_l2_address () @@ -106,9 +108,10 @@ let signer_of_address_index : let eq_qty = Alcotest.of_pp Tx_rollup_l2_qty.pp -let check_balance ctxt name_account name_ticket description tidx aidx value = +let check_balance ctxt name_account name_ticket description tidx aidx + expected_value = let open Syntax in - let value = Tx_rollup_l2_qty.of_int64_exn value in + let expected_value = Tx_rollup_l2_qty.of_int64_exn expected_value in let* res = Ticket_ledger.get ctxt tidx aidx in Alcotest.( check @@ -118,8 +121,8 @@ let check_balance ctxt name_account name_ticket description tidx aidx value = name_account name_ticket description) - res - value) ; + expected_value + res) ; return () let pp_metadata fmt Tx_rollup_l2_context_sig.{counter; public_key} = @@ -154,6 +157,20 @@ let eq_addr_indexable = Alcotest.of_pp (Indexable.pp (fun _ _ -> ())) let eq_ticket_indexable = Alcotest.of_pp (Indexable.pp (fun _ _ -> ())) +let pp_withdrawal fmt = function + | Message_result.{destination; ticket_hash; amount} -> + Format.fprintf + fmt + "{destination=%a; ticket_hash=%a; amount=%a}" + Signature.Public_key_hash.pp + destination + Ticket_hash.pp + ticket_hash + Tx_rollup_l2_qty.pp + amount + +let eq_withdrawal = Alcotest.of_pp pp_withdrawal + let check_indexes addr_indexes ticket_indexes expected = let open Syntax in (* This is dirty but it orders the list by their indexes. *) @@ -217,6 +234,7 @@ let with_initial_setup tickets contracts = let* (ctxt, rev_contracts) = list_fold_left_m (fun (ctxt, rev_contracts) balances -> + let (pkh, _, _) = gen_l1_address () in let (sk, pk, addr) = gen_l2_address () in let* (ctxt, _, idx) = Address_index.get_or_associate_index ctxt addr in @@ -232,7 +250,7 @@ let with_initial_setup tickets contracts = balances in - return (ctxt, (sk, pk, addr, idx) :: rev_contracts)) + return (ctxt, (sk, pk, addr, idx, pkh) :: rev_contracts)) (ctxt, []) contracts in @@ -243,15 +261,13 @@ let with_initial_setup tickets contracts = let transfer ?(counter = 1L) ~signer ~dest ~ticket qty = let open Tx_rollup_l2_batch.V1 in let qty = Tx_rollup_l2_qty.of_int64_exn qty in - let content = - { - destination = Layer2 (from_value dest); - ticket_hash = from_value ticket; - qty; - } - in + let content = {destination = dest; ticket_hash = from_value ticket; qty} in {signer = from_value signer; counter; contents = [content]} +let l1addr pkh = Tx_rollup_l2_batch.Layer1 pkh + +let l2addr addr = Tx_rollup_l2_batch.Layer2 (from_value addr) + let transfers = List.map (fun (pk_source, dest, ticket, amount, counter) -> transfer ~signer:pk_source ~dest ~ticket ?counter amount) @@ -288,12 +304,14 @@ let test_simple_deposit () = let ctxt = empty_context in let amount = Tx_rollup_l2_qty.of_int64_exn 50L in - let deposit = {destination = value addr1; ticket_hash = ticket1; amount} in - let* (ctxt, result) = apply_deposit ctxt deposit in + let deposit = + {sender = pkh; destination = value addr1; ticket_hash = ticket1; amount} + in + let* (ctxt, result, withdrawal_opt) = apply_deposit ctxt deposit in (* Applying the deposit should create an idx for both [addr1] and [ticket]. *) - match result with - | Deposit_success indexes -> + match (result, withdrawal_opt) with + | (Deposit_success indexes, None) -> let* () = check_indexes [(addr1, index_exn 0l)] [(ticket1, index_exn 0l)] indexes in @@ -321,16 +339,17 @@ let test_deposit_with_existing_indexes () = let deposit = { + sender = pkh; destination = value addr1; ticket_hash = ticket1; amount = Tx_rollup_l2_qty.of_int64_exn 1L; } in - let* (ctxt, result) = apply_deposit ctxt deposit in + let* (ctxt, result, withdrawal_opt) = apply_deposit ctxt deposit in (* The indexes should not be considered as created *) - match result with - | Deposit_success indexes -> + match (result, withdrawal_opt) with + | (Deposit_success indexes, None) -> assert (indexes.address_indexes = Address_indexes.empty) ; assert (indexes.ticket_indexes = Ticket_indexes.empty) ; @@ -341,6 +360,54 @@ let test_deposit_with_existing_indexes () = return_unit | _ -> fail_msg "Unexpected operation result" +(** Test that deposit overflow withdraws the amount sent. *) +let test_returned_deposit () = + let open Context_l2.Syntax in + let balance = Int64.max_int in + let* (ctxt, tidxs, accounts) = + with_initial_setup [ticket1] [[(ticket1, balance)]] + in + let tidx1 = nth_exn tidxs 0 in + let (_sk1, _pk1, addr1, idx1, pkh) = nth_exn accounts 0 in + + (* my cup runneth over *) + let amount = Tx_rollup_l2_qty.one in + let deposit = + {sender = pkh; destination = value addr1; ticket_hash = ticket1; amount} + in + let* (ctxt, result, withdrawal_opt) = apply_deposit ctxt deposit in + + (* Applying the deposit will result in a Deposit_failure, an + unchanged context and a withdrawal of the deposit *) + match (result, withdrawal_opt) with + | (Deposit_failure Tx_rollup_l2_context_sig.Balance_overflow, Some withdrawal) + -> + (* balance is unchanged *) + let* balance' = Context_l2.Ticket_ledger.get ctxt tidx1 idx1 in + Alcotest.( + check + eq_qty + "An overflowing deposit should not modify balance" + (Tx_rollup_l2_qty.of_int64_exn balance) + balance') ; + Alcotest.( + check + eq_withdrawal + "Resulting withdrawal from overflowing L1->L2 deposit" + withdrawal + {destination = pkh; ticket_hash = ticket1; amount}) ; + return_unit + | (Deposit_failure reason, _) -> + let msg = + Format.asprintf + "Unexpected failure for overflowing deposit: %a" + Environment.Error_monad.pp + reason + in + fail_msg msg + | (Deposit_success _result, _) -> + fail_msg "Did not expect overflowing deposit to be succesful" + (** Test that all values used in a transaction creates indexes and they are packed in the final indexes. *) let test_indexes_creation () = @@ -357,16 +424,17 @@ let test_indexes_creation () = transfered between the other addresses. *) let deposit = { + sender = pkh; destination = value addr1; ticket_hash = ticket1; amount = Tx_rollup_l2_qty.of_int64_exn 100L; } in - let* (ctxt, result) = apply_deposit ctxt deposit in + let* (ctxt, result, withdrawal_opt) = apply_deposit ctxt deposit in let* () = - match result with - | Deposit_success indexes -> + match (result, withdrawal_opt) with + | (Deposit_success indexes, None) -> check_indexes [(addr1, index_exn 0l)] [(ticket1, index_exn 0l)] indexes | _ -> unexpected_result in @@ -374,16 +442,16 @@ let test_indexes_creation () = (* We create a transaction for each transfer, it makes the test of each transaction result easier. *) let transaction1 = - [transfer ~counter:1L ~signer:pk1 ~dest:addr2 ~ticket:ticket1 10L] + [transfer ~counter:1L ~signer:pk1 ~dest:(l2addr addr2) ~ticket:ticket1 10L] in let signature1 = sign_transaction [sk1] transaction1 in let transaction2 = - [transfer ~counter:2L ~signer:pk1 ~dest:addr3 ~ticket:ticket1 20L] + [transfer ~counter:2L ~signer:pk1 ~dest:(l2addr addr3) ~ticket:ticket1 20L] in let signature2 = sign_transaction [sk1] transaction2 in let transaction3 = - [transfer ~counter:3L ~signer:pk1 ~dest:addr4 ~ticket:ticket1 30L] + [transfer ~counter:3L ~signer:pk1 ~dest:(l2addr addr4) ~ticket:ticket1 30L] in let signature3 = sign_transaction [sk1] transaction3 in let batch = @@ -392,7 +460,9 @@ let test_indexes_creation () = [transaction1; transaction2; transaction3] in - let* (_ctxt, Batch_result {indexes; _}) = Batch_V1.apply_batch ctxt batch in + let* (_ctxt, Batch_result {indexes; _}, _withdrawals) = + Batch_V1.apply_batch ctxt batch + in let* () = check_indexes @@ -414,22 +484,30 @@ let test_indexes_creation_bad () = let deposit = { + sender = pkh; destination = value addr1; ticket_hash = ticket1; amount = Tx_rollup_l2_qty.of_int64_exn 20L; } in - let* (ctxt, _) = apply_deposit ctxt deposit in + let* (ctxt, _, _withdrawal_opt) = apply_deposit ctxt deposit in let transaction1 = (* This transaction will fail because the number of tickets required is more than its own. *) - [transfer ~counter:1L ~signer:pk1 ~dest:addr2 ~ticket:ticket1 10000L] + [ + transfer + ~counter:1L + ~signer:pk1 + ~dest:(l2addr addr2) + ~ticket:ticket1 + 10000L; + ] in let signature1 = sign_transaction [sk1] transaction1 in let transaction2 = (* This is ok *) - [transfer ~counter:2L ~signer:pk1 ~dest:addr3 ~ticket:ticket1 1L] + [transfer ~counter:2L ~signer:pk1 ~dest:(l2addr addr3) ~ticket:ticket1 1L] in let signature2 = sign_transaction [sk1] transaction2 in @@ -437,7 +515,7 @@ let test_indexes_creation_bad () = batch (List.concat [signature1; signature2]) [transaction1; transaction2] in - let* (ctxt, Batch_result {results; indexes}) = + let* (ctxt, Batch_result {results; indexes}, _withdrawals) = Batch_V1.apply_batch ctxt batch in @@ -462,7 +540,7 @@ let test_indexes_creation_bad () = (** The test consists of [addr1] sending [ticket1] to [addr2]. In exchange [addr2] will send [ticket2] to [addr1]. We check both the transaction's status and the balances afterwards. *) -let test_simple_transaction () = +let test_simple_l2_transaction () = let open Context_l2.Syntax in let* (ctxt, tidxs, accounts) = with_initial_setup [ticket1; ticket2] [[(ticket1, 10L)]; [(ticket2, 20L)]] @@ -471,24 +549,29 @@ let test_simple_transaction () = let tidx1 = nth_exn tidxs 0 in let tidx2 = nth_exn tidxs 1 in - let (sk1, pk1, addr1, idx1) = nth_exn accounts 0 in - let (sk2, pk2, addr2, idx2) = nth_exn accounts 1 in + let (sk1, pk1, addr1, idx1, _) = nth_exn accounts 0 in + let (sk2, pk2, addr2, idx2, _) = nth_exn accounts 1 in (* Then, we build a transaction with: [addr1] -> [addr2] & [addr2] -> [addr1]. *) let transaction = transfers - [(pk1, addr2, ticket1, 10L, None); (pk2, addr1, ticket2, 20L, None)] + [ + (pk1, l2addr addr2, ticket1, 10L, None); + (pk2, l2addr addr1, ticket2, 20L, None); + ] in let batch = create_batch_v1 [transaction] [[sk1; sk2]] in - let* (ctxt, Batch_result {results; _}) = Batch_V1.apply_batch ctxt batch in + let* (ctxt, Batch_result {results; _}, _withdrawals) = + Batch_V1.apply_batch ctxt batch + in let status = nth_exn results 0 |> snd in - match status with - | Transaction_success -> - (* Check the balance after the transaction has been applied, we ommit + match (status, _withdrawals) with + | (Transaction_success, []) -> + (* Check the balance after the transaction has been applied, we omit the check the indexes to not pollute this test. *) let* () = check_balance @@ -532,9 +615,382 @@ let test_simple_transaction () = 20L in return_unit - | Transaction_failure _ -> fail_msg "The transaction should be a success" + | (Transaction_success, _) -> fail_msg "Did not expect any withdrawals" + | (Transaction_failure _, _) -> fail_msg "The transaction should be a success" + +(** The test consists of [pk1] sending [ticket1] to [pkh2]. + This results in a withdrawal. *) +let test_simple_l1_transaction () = + let open Context_l2.Syntax in + let* (ctxt, tidxs, accounts) = + with_initial_setup [ticket1] [[(ticket1, 10L)]; []] + in + + let tidx1 = nth_exn tidxs 0 in + + let (sk1, pk1, _addr1, idx1, _pkh1) = nth_exn accounts 0 in + let (_sk2, _pk2, _addr2, _idx2, pkh2) = nth_exn accounts 1 in + + (* Then, we build a transaction with: + [addr1] -> [pkh2] *) + let transaction = transfers [(pk1, l1addr pkh2, ticket1, 10L, None)] in + let batch = create_batch_v1 [transaction] [[sk1]] in + + let* (ctxt, Batch_result {results; _}, withdrawals) = + Batch_V1.apply_batch ctxt batch + in + + let status = nth_exn results 0 |> snd in + + match (status, withdrawals) with + | (Transaction_success, [withdrawal]) -> + (* Check the balance after the transaction has been applied, we omit + the check the indexes to not pollute this test. *) + let* () = + check_balance + ctxt + "addr1" + "ticket1" + "addr1.ticket1 should be emptied" + tidx1 + idx1 + 0L + in + Alcotest.( + check + eq_withdrawal + "Resulting withdrawal from L2->L1 transfer" + withdrawal + { + destination = pkh2; + ticket_hash = ticket1; + amount = Tx_rollup_l2_qty.of_int64_exn 10L; + }) ; + return_unit + | (Transaction_success, _) -> fail_msg "Expected exactly one withdrawal" + | (Transaction_failure _, _) -> fail_msg "The transaction should be a success" + +(** Test that [Missing_ticket] is raised if a transfer is attempted to + a ticket absent from the rollup. *) +let test_l1_transaction_inexistant_ticket () = + let open Context_l2.Syntax in + (* empty context *) + let* (ctxt, _tidxs, accounts) = with_initial_setup [] [[]; []] in + + let (sk1, pk1, _addr1, _idx1, _pkh1) = nth_exn accounts 0 in + let (_sk2, _pk2, _addr2, _idx2, pkh2) = nth_exn accounts 1 in + + (* We build an invalid transaction with: [addr1] -> [pkh2] *) + let transaction = transfers [(pk1, l1addr pkh2, ticket1, 10L, None)] in + let batch = create_batch_v1 [transaction] [[sk1]] in + + let* (_ctxt, Batch_result {results; _}, withdrawals) = + Batch_V1.apply_batch ctxt batch + in + + (* Expect no withdrawals *) + Alcotest.( + check + (list eq_withdrawal) + "Resulting withdrawal from L2->L1 transfer" + withdrawals + []) ; + + (* Expect error returned *) + let status = nth_exn results 0 |> snd in + expect_error_status + ~msg:"an invalid transaction must fail" + (Tx_rollup_l2_apply.Missing_ticket ticket1) + status + return_unit + +(** If the signer of a L2->L1 transaction does not exist (has no balance), + then batch application fails with Balance_too_low. *) +let test_l1_transaction_inexistant_signer () = + let open Context_l2.Syntax in + let* (ctxt, _tidxs, accounts) = + with_initial_setup [ticket1; ticket2] [[(ticket1, 10L)]; [(ticket2, 20L)]] + in + + let (_sk1, _pk1, _addr1, _idx1, _pkh1) = nth_exn accounts 0 in + let (_sk2, _pk2, _addr2, _idx2, pkh2) = nth_exn accounts 1 in + let (sk_unknown, pk_unknown, _) = gen_l2_address () in + + (* Then, we build an invalid transaction with: + [pk_unknown] -> [pkh2] *) + let transaction = transfers [(pk_unknown, l1addr pkh2, ticket1, 10L, None)] in + let batch = create_batch_v1 [transaction] [[sk_unknown]] in + + let* (_ctxt, Batch_result {results; _}, withdrawals) = + Batch_V1.apply_batch ctxt batch + in + + (* Expect no withdrawals *) + Alcotest.( + check + (list eq_withdrawal) + "Resulting withdrawal from L2->L1 transfer" + withdrawals + []) ; + + (* Expect error returned *) + let status = nth_exn results 0 |> snd in + expect_error_status + ~msg:"an invalid transaction must fail" + Tx_rollup_l2_context_sig.Balance_too_low + status + return_unit + +(** Test that [Balance_too_low] is raised if a transfer is attempted with a + quantity superior to the senders balance. *) +let test_l1_transaction_overdraft () = + let open Context_l2.Syntax in + let initial_balances = [[(ticket1, 10L)]; [(ticket2, 20L)]] in + let* (ctxt, tidxs, accounts) = + with_initial_setup [ticket1; ticket2] initial_balances + in + + let (sk1, pk1, _addr1, idx1, _pkh1) = nth_exn accounts 0 in + let (_sk2, _pk2, _addr2, idx2, pkh2) = nth_exn accounts 1 in + + let tidx1 = nth_exn tidxs 0 in + let tidx2 = nth_exn tidxs 1 in + + (* Then, we build an transaction with: [addr1] -> [pkh2] where addr1 attempts to spend too much*) + let transaction = transfers [(pk1, l1addr pkh2, ticket1, 30L, None)] in + let batch = create_batch_v1 [transaction] [[sk1]] in + + let* (ctxt, Batch_result {results; _}, withdrawals) = + Batch_V1.apply_batch ctxt batch + in + + (* Expect no withdrawals *) + Alcotest.( + check + (list eq_withdrawal) + "Resulting withdrawal from L2->L1 transfer" + withdrawals + []) ; + + (* Expect error returned *) + let status = nth_exn results 0 |> snd in + expect_error_status + ~msg:"an invalid transaction must fail" + Tx_rollup_l2_context_sig.Balance_too_low + status + (let* () = + check_balance + ctxt + "addr1" + "ticket1" + "addr1.ticket1 should be unchanged" + tidx1 + idx1 + 10L + in + let* () = + check_balance + ctxt + "addr2" + "ticket1" + "addr2.ticket1 should be unchanged" + tidx2 + idx2 + 20L + in + + let* () = + check_balance + ctxt + "addr2" + "ticket2" + "addr1.ticket2 should be unchanged (empty)" + tidx2 + idx1 + 0L + in + let* () = + check_balance + ctxt + "addr1" + "ticket2" + "addr2.ticket1 should be unchanged (empty)" + tidx1 + idx2 + 0L + in + return_unit) + +(** Test that withdrawals with quantity zero are possible. + + TODO: https://gitlab.com/tezos/tezos/-/issues/2593 + Should they be possible? + *) +let test_l1_transaction_zero () = + let open Context_l2.Syntax in + let initial_balances = [[(ticket1, 10L)]; [(ticket2, 20L)]] in + let* (ctxt, tidxs, accounts) = + with_initial_setup [ticket1; ticket2] initial_balances + in + + let (sk1, pk1, _addr1, idx1, _pkh1) = nth_exn accounts 0 in + let (_sk2, _pk2, _addr2, idx2, pkh2) = nth_exn accounts 1 in + + let tidx1 = nth_exn tidxs 0 in + let tidx2 = nth_exn tidxs 1 in + + (* Then, we build an transaction with: [addr1] -> [pkh2] with amount 0 *) + let transaction = transfers [(pk1, l1addr pkh2, ticket1, 0L, None)] in + let batch = create_batch_v1 [transaction] [[sk1]] in + + let* (ctxt, Batch_result {results; _}, withdrawals) = + Batch_V1.apply_batch ctxt batch + in + + (* Expect one zero-withdrawal *) + Alcotest.( + check + (list eq_withdrawal) + "Resulting withdrawal from L2->L1 transfer" + withdrawals + [ + { + destination = pkh2; + ticket_hash = ticket1; + amount = Tx_rollup_l2_qty.zero; + }; + ]) ; + + match results with + | [([_], Transaction_success)] -> + let* () = + check_balance + ctxt + "addr1" + "ticket1" + "addr1.ticket1 should be unchanged" + tidx1 + idx1 + 10L + in + let* () = + check_balance + ctxt + "addr2" + "ticket1" + "addr2.ticket2 should be unchanged" + tidx2 + idx2 + 20L + in + + let* () = + check_balance + ctxt + "addr2" + "ticket2" + "addr1.ticket2 should be unchanged (empty)" + tidx2 + idx1 + 0L + in + let* () = + check_balance + ctxt + "addr1" + "ticket2" + "addr2.ticket1 should be unchanged (empty)" + tidx1 + idx2 + 0L + in + return_unit + | _ -> fail_msg "Zero-transactions should be successful" + +(** Test partial L2 to L1 transaction. Ensure that a withdrawal is emitted + for the transferred amount and that the remainder is in the sender's + account. *) +let test_l1_transaction_partial () = + let open Context_l2.Syntax in + let* (ctxt, tidxs, accounts) = + with_initial_setup [ticket1; ticket2] [[(ticket1, 10L)]; [(ticket2, 20L)]] + in + + let (sk1, pk1, _addr1, idx1, _pkh1) = nth_exn accounts 0 in + let (_sk2, _pk2, _addr2, idx2, pkh2) = nth_exn accounts 1 in + + let tidx1 = nth_exn tidxs 0 in + let tidx2 = nth_exn tidxs 1 in + + (* Then, we build an transaction with: [addr1] -> [pkh2] , addr1 spending the ticket partially *) + let transaction = transfers [(pk1, l1addr pkh2, ticket1, 5L, None)] in + let batch = create_batch_v1 [transaction] [[sk1]] in + + let* (ctxt, Batch_result {results; _}, withdrawals) = + Batch_V1.apply_batch ctxt batch + in + + (* Expect one partial withdrawal *) + Alcotest.( + check + (list eq_withdrawal) + "Resulting withdrawal from L2->L1 transfer" + withdrawals + [ + { + destination = pkh2; + ticket_hash = ticket1; + amount = Tx_rollup_l2_qty.of_int64_exn 5L; + }; + ]) ; + + match results with + | [([_], Transaction_success)] -> + let* () = + check_balance + ctxt + "addr1" + "ticket1" + "addr1.ticket1 should be debited" + tidx1 + idx1 + 5L + in + let* () = + check_balance + ctxt + "addr2" + "ticket1" + "addr2.ticket2 should be unchanged" + tidx2 + idx2 + 20L + in + + let* () = + check_balance + ctxt + "addr2" + "ticket2" + "addr1.ticket2 should be unchanged (empty)" + tidx2 + idx1 + 0L + in + let* () = + check_balance + ctxt + "addr1" + "ticket2" + "addr2.ticket1 should be unchanged (empty)" + tidx1 + idx2 + 0L + in + return_unit + | _ -> fail_msg "Zero-transactions should be successful" -(** Thest that a valid transaction containing both indexes and values is a +(** Test that a valid transaction containing both indexes and values is a success. *) let test_transaction_with_unknown_indexable () = let open Context_l2.Syntax in @@ -546,8 +1002,8 @@ let test_transaction_with_unknown_indexable () = let tidx1 = nth_exn tidxs 0 in let tidx2 = nth_exn tidxs 1 in - let (sk1, pk1, addr1, aidx1) = nth_exn accounts 0 in - let (sk2, pk2, addr2, aidx2) = nth_exn accounts 1 in + let (sk1, pk1, addr1, aidx1, _) = nth_exn accounts 0 in + let (sk2, pk2, addr2, aidx2, _) = nth_exn accounts 1 in (* Note that {!with_initial_setup} does not initialize metadatas for the public keys. If it was the case, we could not use this function @@ -600,13 +1056,15 @@ let test_transaction_with_unknown_indexable () = let signatures = sign_transaction [sk1; sk2] transaction in let batch = batch signatures [transaction] in - let* (ctxt, Batch_result {results; _}) = Batch_V1.apply_batch ctxt batch in + let* (ctxt, Batch_result {results; _}, withdrawals) = + Batch_V1.apply_batch ctxt batch + in let status = nth_exn results 0 |> snd in - match status with - | Transaction_success -> - (* Check the balance after the transaction has been applied, we ommit + match (status, withdrawals) with + | (Transaction_success, []) -> + (* Check the balance after the transaction has been applied, we omit the check the indexes to not pollute this test. *) let* () = check_balance @@ -650,11 +1108,12 @@ let test_transaction_with_unknown_indexable () = 20L in return_unit - | Transaction_failure _ -> fail_msg "The transaction should be a success" + | (Transaction_success, _) -> fail_msg "Did not expect any withdrawals" + | (Transaction_failure _, _) -> fail_msg "The transaction should be a success" (** Test that a transaction containing at least one invalid operation fails and does not change the context. It is similar to - {!test_simple_transaction} but the second addr does not + {!test_simple_l2_transaction} but the second addr does not possess the tickets. *) let test_invalid_transaction () = let open Context_l2.Syntax in @@ -664,25 +1123,30 @@ let test_invalid_transaction () = let tidx1 = nth_exn tidxs 0 in - let (sk1, pk1, addr1, idx1) = nth_exn accounts 0 in - let (sk2, pk2, addr2, idx2) = nth_exn accounts 1 in + let (sk1, pk1, addr1, idx1, _) = nth_exn accounts 0 in + let (sk2, pk2, addr2, idx2, _) = nth_exn accounts 1 in (* Then, we build a transaction with: [addr1] -> [addr2] & [addr2] -> [addr1]. *) let transaction = transfers - [(pk1, addr2, ticket1, 10L, None); (pk2, addr1, ticket2, 20L, None)] + [ + (pk1, l2addr addr2, ticket1, 10L, None); + (pk2, l2addr addr1, ticket2, 20L, None); + ] in let batch = create_batch_v1 [transaction] [[sk1; sk2]] in - let* (ctxt, Batch_result {results; _}) = Batch_V1.apply_batch ctxt batch in + let* (ctxt, Batch_result {results; _}, _withdrawals) = + Batch_V1.apply_batch ctxt batch + in let status = nth_exn results 0 |> snd in let* () = expect_error_status ~msg:"an invalid transaction must fail" - Tx_rollup_l2_context.Balance_too_low + Tx_rollup_l2_context_sig.Balance_too_low status (let* () = check_balance @@ -714,13 +1178,17 @@ let test_invalid_counter () = let open Context_l2.Syntax in let* (ctxt, _, accounts) = with_initial_setup [ticket1] [[]] in - let (sk1, pk1, addr1, _idx1) = nth_exn accounts 0 in + let (sk1, pk1, addr1, _idx1, _) = nth_exn accounts 0 in let counter = 10L in - let transaction = transfers [(pk1, addr2, ticket1, 10L, Some counter)] in + let transaction = + transfers [(pk1, l2addr addr2, ticket1, 10L, Some counter)] + in let batch = create_batch_v1 [transaction] [[sk1]] in - let* (_ctxt, Batch_result {results; _}) = Batch_V1.apply_batch ctxt batch in + let* (_ctxt, Batch_result {results; _}, _withdrawals) = + Batch_V1.apply_batch ctxt batch + in let status = nth_exn results 0 |> snd in @@ -740,16 +1208,16 @@ let test_update_counter () = let open Context_l2.Syntax in let* (ctxt, _, accounts) = with_initial_setup [ticket1] [[]] in - let (sk1, pk1, _addr1, _idx1) = nth_exn accounts 0 in + let (sk1, pk1, _addr1, _idx1, _) = nth_exn accounts 0 in let transactions = transfers [ - (pk1, addr2, ticket1, 10L, Some 1L); - (pk1, addr2, ticket1, 20L, Some 2L); - (pk1, addr2, ticket1, 30L, Some 3L); - (pk1, addr2, ticket1, 40L, Some 4L); - (pk1, addr2, ticket1, 50L, Some 5L); + (pk1, l2addr addr2, ticket1, 10L, Some 1L); + (pk1, l2addr addr2, ticket1, 20L, Some 2L); + (pk1, l2addr addr2, ticket1, 30L, Some 3L); + (pk1, l2addr addr2, ticket1, 40L, Some 4L); + (pk1, l2addr addr2, ticket1, 50L, Some 5L); ] |> List.map (fun x -> [x]) in @@ -758,13 +1226,16 @@ let test_update_counter () = create_batch_v1 transactions [[sk1]; [sk1]; [sk1]; [sk1]; [sk1]] in - let* (ctxt, Batch_result {results; _}) = Batch_V1.apply_batch ctxt batch in + let* (ctxt, Batch_result {results; _}, withdrawals) = + Batch_V1.apply_batch ctxt batch + in let status = nth_exn results 0 |> snd in - match status with - | Transaction_failure - {reason = Tx_rollup_l2_apply.Incorrect_aggregated_signature; _} -> + match (status, withdrawals) with + | ( Transaction_failure + {reason = Tx_rollup_l2_apply.Incorrect_aggregated_signature; _}, + _ ) -> fail_msg "This test should not raise [Incorrect_aggregated_signature]" | _ -> let* () = @@ -783,12 +1254,15 @@ let test_pre_apply_batch () = with_initial_setup [ticket1; ticket2] [[(ticket1, 10L)]; [(ticket2, 20L)]] in - let (sk1, pk1, addr1, _idx1) = nth_exn accounts 0 in - let (sk2, pk2, addr2, _idx2) = nth_exn accounts 1 in + let (sk1, pk1, addr1, _idx1, _) = nth_exn accounts 0 in + let (sk2, pk2, addr2, _idx2, _) = nth_exn accounts 1 in let transaction = transfers - [(pk1, addr2, ticket1, 10L, None); (pk2, addr1, ticket2, 20L, None)] + [ + (pk1, l2addr addr2, ticket1, 10L, None); + (pk2, l2addr addr1, ticket2, 20L, None); + ] in let batch1 = create_batch_v1 [transaction] [[sk1; sk2]] in let* (ctxt, _indexes, _) = Batch_V1.check_signature ctxt batch1 in @@ -831,14 +1305,17 @@ let test_apply_message_batch () = with_initial_setup [ticket1; ticket2] [[(ticket1, 10L)]; [(ticket2, 20L)]] in - let (sk1, pk1, addr1, _) = nth_exn accounts 0 in - let (sk2, pk2, addr2, _) = nth_exn accounts 1 in + let (sk1, pk1, addr1, _, _) = nth_exn accounts 0 in + let (sk2, pk2, addr2, _, _) = nth_exn accounts 1 in (* Then, we build a transaction with: [addr1] -> [addr2] & [addr2] -> [addr1]. *) let transaction = transfers - [(pk1, addr2, ticket1, 10L, None); (pk2, addr1, ticket2, 20L, None)] + [ + (pk1, l2addr addr2, ticket1, 10L, None); + (pk2, l2addr addr1, ticket2, 20L, None); + ] in let batch = create_batch_v1 [transaction] [[sk1; sk2]] in let (msg, _) = @@ -851,12 +1328,148 @@ let test_apply_message_batch () = let* (_ctxt, result) = apply_message ctxt msg in match result with - | Message_result.Batch_V1_result _ -> + | (Message_result.Batch_V1_result _, []) -> (* We do not check the result inside as we consider it is covered by other tests. *) return_unit | _ -> fail_msg "Invalid apply message result" +(** Test a batch of transfers where some of the transfers will emit + withdrawals. *) +let test_apply_message_batch_withdrawals () = + let open Context_l2.Syntax in + let* (ctxt, tidxs, accounts) = + with_initial_setup [ticket1; ticket2] [[(ticket1, 10L)]; [(ticket2, 20L)]] + in + + let (sk1, pk1, addr1, idx1, pkh1) = nth_exn accounts 0 in + let (sk2, pk2, addr2, idx2, pkh2) = nth_exn accounts 1 in + + let tidx1 = nth_exn tidxs 0 in + let tidx2 = nth_exn tidxs 1 in + + (* Then, we build a transaction with: + - [pk1] -> [addr2] + - [pk1] -> [pkh2] (-> withdrawal) + - [pk2] -> [addr1] + - [pk2] -> [pkh1] (-> withdrawal) + *) + let transactions = + [ + transfers [(pk1, l2addr addr2, ticket1, 5L, Some 1L)]; + transfers [(pk1, l1addr pkh2, ticket1, 5L, Some 2L)]; + transfers [(pk2, l2addr addr1, ticket2, 10L, Some 1L)]; + transfers [(pk2, l1addr pkh1, ticket2, 10L, Some 2L)]; + ] + in + let batch = create_batch_v1 transactions [[sk1]; [sk1]; [sk2]; [sk2]] in + let (msg, _) = + Tx_rollup_message.make_batch + (Data_encoding.Binary.to_string_exn + Tx_rollup_l2_batch.encoding + (V1 batch)) + in + + let* (ctxt, result) = apply_message ctxt msg in + + match result with + | ( Message_result.Batch_V1_result + (Message_result.Batch_V1.Batch_result + { + results = + [ + (_, Transaction_success); + (_, Transaction_success); + (_, Transaction_success); + (_, Transaction_success); + ]; + _; + }), + withdrawals ) -> + Alcotest.( + check + (list eq_withdrawal) + "Resulting withdrawal from L2->L1 batch" + withdrawals + [ + { + destination = pkh2; + ticket_hash = ticket1; + amount = Tx_rollup_l2_qty.of_int64_exn 5L; + }; + { + destination = pkh1; + ticket_hash = ticket2; + amount = Tx_rollup_l2_qty.of_int64_exn 10L; + }; + ]) ; + let* () = + check_balance + ctxt + "addr1" + "ticket1" + "addr1.ticket1 should be spent" + tidx1 + idx1 + 0L + in + let* () = + check_balance + ctxt + "addr2" + "ticket1" + "addr2.ticket1 should be credited" + tidx1 + idx2 + 5L + in + + let* () = + check_balance + ctxt + "addr2" + "ticket2" + "addr1.ticket2 should be credited" + tidx2 + idx1 + 10L + in + let* () = + check_balance + ctxt + "addr1" + "ticket2" + "addr2.ticket2 should be spent" + tidx2 + idx2 + 0L + in + return_unit + | ( Message_result.Batch_V1_result + (Message_result.Batch_V1.Batch_result {results; _}), + _ ) -> + let* () = + if List.length results <> 4 then + fail_msg + ("Expected 4 results, got " ^ string_of_int @@ List.length results) + else return_unit + in + List.iter_es + (fun res -> + match res with + | (_, Message_result.Transaction_success) -> return_unit + | (_, Transaction_failure {index; reason}) -> + let msg = + Format.asprintf + "Result at position %d unexpectedly failed: %a" + index + Environment.Error_monad.pp + reason + in + fail_msg msg) + results + | _ -> fail_msg "Unexpected apply message result" + let test_apply_message_deposit () = let open Context_l2.Syntax in let ctxt = empty_context in @@ -864,6 +1477,7 @@ let test_apply_message_deposit () = let (msg, _) = Tx_rollup_message.make_deposit + pkh (value addr1) ticket1 (Tx_rollup_l2_qty.of_int64_exn amount) @@ -872,7 +1486,7 @@ let test_apply_message_deposit () = let* (_ctxt, result) = apply_message ctxt msg in match result with - | Message_result.Deposit_result _ -> + | (Message_result.Deposit_result _, []) -> (* We do not check the result inside as we consider it is covered by other tests. *) return_unit @@ -882,8 +1496,17 @@ let tests = wrap_tztest_tests [ ("simple transaction", test_simple_deposit); + ("returned transaction", test_returned_deposit); ("deposit with existing indexes", test_deposit_with_existing_indexes); - ("test simple transaction", test_simple_transaction); + ("test simple l1 transaction", test_simple_l1_transaction); + ( "test simple l1 transaction: inexistant ticket", + test_l1_transaction_inexistant_ticket ); + ( "test simple l1 transaction: inexistant signer", + test_l1_transaction_inexistant_signer ); + ("test simple l1 transaction: overdraft", test_l1_transaction_overdraft); + ("test simple l1 transaction: zero", test_l1_transaction_zero); + ("test simple l1 transaction: partial", test_l1_transaction_partial); + ("test simple l2 transaction", test_simple_l2_transaction); ( "test simple transaction with indexes and values", test_transaction_with_unknown_indexable ); ("invalid transaction", test_invalid_transaction); @@ -893,5 +1516,7 @@ let tests = ("update counter", test_update_counter); ("pre apply batch", test_pre_apply_batch); ("apply batch from message", test_apply_message_batch); + ( "apply batch from message with withdrawals", + test_apply_message_batch_withdrawals ); ("apply deposit from message", test_apply_message_deposit); ] diff --git a/src/proto_alpha/lib_protocol/ticket_hash_builder.ml b/src/proto_alpha/lib_protocol/ticket_hash_builder.ml index b382e27d49d8c941b1190a1e9ffcba37256d8c78..fc7f79181e1838f526442cd1ea06e53dd8630829 100644 --- a/src/proto_alpha/lib_protocol/ticket_hash_builder.ml +++ b/src/proto_alpha/lib_protocol/ticket_hash_builder.ml @@ -51,14 +51,30 @@ let hash_of_node ctxt node = Raw_context.consume_gas ctxt (Script_repr.strip_locations_cost node) >>? fun ctxt -> let node = Micheline.strip_locations node in - match Data_encoding.Binary.to_bytes_opt Script_repr.expr_encoding node with - | Some bytes -> - Raw_context.consume_gas ctxt (hash_bytes_cost bytes) >|? fun ctxt -> - ( Ticket_hash_repr.of_script_expr_hash - @@ Script_expr_hash.hash_bytes [bytes], - ctxt ) - | None -> error Failed_to_hash_node + Result.of_option + ~error:(Error_monad.trace_of_error Failed_to_hash_node) + (Data_encoding.Binary.to_bytes_opt Script_repr.expr_encoding node) + >>? fun bytes -> + Raw_context.consume_gas ctxt (hash_bytes_cost bytes) >|? fun ctxt -> + ( Ticket_hash_repr.of_script_expr_hash @@ Script_expr_hash.hash_bytes [bytes], + ctxt ) + +let hash_of_node_uncarbonated node = + let node = Micheline.strip_locations node in + Result.of_option + ~error:(Error_monad.trace_of_error Failed_to_hash_node) + (Data_encoding.Binary.to_bytes_opt Script_repr.expr_encoding node) + >|? fun bytes -> + Ticket_hash_repr.of_script_expr_hash @@ Script_expr_hash.hash_bytes [bytes] let make ctxt ~ticketer ~ty ~contents ~owner = hash_of_node ctxt @@ Micheline.Seq (Micheline.dummy_location, [ticketer; ty; contents; owner]) + +let make_uncarbonated ~ticketer ~ty ~contents ~owner = + hash_of_node_uncarbonated + @@ Micheline.Seq (Micheline.dummy_location, [ticketer; ty; contents; owner]) + +module Internal_for_tests = struct + let make_uncarbonated = make_uncarbonated +end diff --git a/src/proto_alpha/lib_protocol/ticket_hash_builder.mli b/src/proto_alpha/lib_protocol/ticket_hash_builder.mli index 98ff6847e8353e1a1009c3b990a2ffe23a7445f2..1ade9e0dda8deafa24525c4069d16f7d35720d0d 100644 --- a/src/proto_alpha/lib_protocol/ticket_hash_builder.mli +++ b/src/proto_alpha/lib_protocol/ticket_hash_builder.mli @@ -35,3 +35,13 @@ val make : contents:Script_repr.node -> owner:Script_repr.node -> (Ticket_hash_repr.t * Raw_context.t) tzresult + +module Internal_for_tests : sig + (** As [make] but do not account for gas consumption *) + val make_uncarbonated : + ticketer:Script_repr.node -> + ty:Script_repr.node -> + contents:Script_repr.node -> + owner:Script_repr.node -> + Ticket_hash_repr.t tzresult +end diff --git a/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml b/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml index 147c5688cccaaa0984bad8bf0136a3ede5104e18..9e0959b4ed698a73055399fdabe08589928f8beb 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml @@ -40,7 +40,8 @@ type error += | Multiple_operations_for_signer of Bls_signature.pk | Invalid_transaction_encoding | Invalid_batch_encoding - | Invalid_operation_destination + | Unexpectedly_indexed_ticket + | Missing_ticket of Ticket_hash.t let () = let open Data_encoding in @@ -111,15 +112,26 @@ let () = empty (function Invalid_batch_encoding -> Some () | _ -> None) (function () -> Invalid_batch_encoding) ; - (* Invalid operation destination *) + (* Unexpectedly indexed ticket *) register_error_kind `Permanent - ~id:"tx_rollup_invalid_operation_destination" - ~title:"Invalid operation destination" - ~description:"The withdraw operation is not implemented yet" + ~id:"tx_rollup_unexpectedly_indexed_ticket" + ~title:"Unexpected indexed ticket in deposit or transfer" + ~description: + "Tickets in layer2-to-layer1 transfers must be referenced by value." empty - (function Invalid_operation_destination -> Some () | _ -> None) - (function () -> Invalid_operation_destination) + (function Unexpectedly_indexed_ticket -> Some () | _ -> None) + (function () -> Unexpectedly_indexed_ticket) ; + (* Missing ticket *) + register_error_kind + `Temporary + ~id:"tx_rollup_missing_ticket" + ~title:"Attempted to withdraw from a ticket missing in the rollup" + ~description: + "A withdrawal must reference a ticket that already exists in the rollup." + (obj1 (req "ticket_hash" Ticket_hash.encoding)) + (function Missing_ticket ticket_hash -> Some ticket_hash | _ -> None) + (function ticket_hash -> Missing_ticket ticket_hash) module Address_indexes = Map.Make (Tx_rollup_l2_address) module Ticket_indexes = Map.Make (Ticket_hash) @@ -170,6 +182,24 @@ let encoding_indexes : indexes Data_encoding.t = Tx_rollup_l2_context_sig.Ticket_indexable.index_encoding)) module Message_result = struct + type withdrawal = { + destination : Signature.Public_key_hash.t; + ticket_hash : Ticket_hash.t; + amount : Tx_rollup_l2_qty.t; + } + + let withdrawal_encoding : withdrawal Data_encoding.t = + let open Data_encoding in + conv + (fun {destination; ticket_hash; amount} -> + (destination, ticket_hash, amount)) + (fun (destination, ticket_hash, amount) -> + {destination; ticket_hash; amount}) + (obj3 + (req "destination" Signature.Public_key_hash.encoding) + (req "ticket_hash" Ticket_hash.encoding) + (req "amount" Tx_rollup_l2_qty.encoding)) + type transaction_result = | Transaction_success | Transaction_failure of {index : int; reason : error} @@ -249,9 +279,11 @@ module Message_result = struct (req "allocated_indexes" encoding_indexes)) end - type t = Deposit_result of deposit_result | Batch_V1_result of Batch_V1.t + type message_result = + | Deposit_result of deposit_result + | Batch_V1_result of Batch_V1.t - let encoding = + let message_result_encoding = let open Data_encoding in union [ @@ -270,6 +302,11 @@ module Message_result = struct (function Batch_V1_result result -> Some result | _ -> None) (fun result -> Batch_V1_result result)); ] + + type t = message_result * withdrawal list + + let encoding = + Data_encoding.(tup2 message_result_encoding (list withdrawal_encoding)) end module Make (Context : CONTEXT) = struct @@ -537,23 +574,43 @@ module Make (Context : CONTEXT) = struct on the [ctxt]. The validity of the transfer is checked in the context itself, e.g. for an invalid balance. - It also returns the potential created indexes: + It returns the potential created indexes: {ul {li The destination address index.} {li The ticket exchanged index.}} + + If the transfer is layer2-to-layer1, then it also returns + the resulting withdrawal. *) let apply_operation_content : ctxt -> indexes -> Signer_indexable.index -> 'content operation_content -> - (ctxt * indexes) m = + (ctxt * indexes * withdrawal option) m = fun ctxt indexes source_idx {destination; ticket_hash; qty} -> match destination with - | Layer1 _ -> - (* FIXME/TORU: https://gitlab.com/tezos/tezos/-/issues/2259 - Implement the withdraw. *) - fail Invalid_operation_destination + | Layer1 l1_dest -> + (* To withdraw, the ticket must be given in the form of a + value. Furthermore, the ticket must already exist in the + rollup and be indexed (the ticket must have already been + assigned an index in the content: otherwise the ticket has + not been seen before and we can't withdraw from + it). Therefore, we do not create any new associations in + the ticket index. *) + let*? ticket_hash = + Indexable.is_value_e ~error:Unexpectedly_indexed_ticket ticket_hash + in + let* tidx_opt = Ticket_index.get ctxt ticket_hash in + let*? tidx = + Option.value_e ~error:(Missing_ticket ticket_hash) tidx_opt + in + let source_idx = address_of_signer_index source_idx in + (* spend the ticket -- this is responsible for checking that + the source has the required balance *) + let* ctxt = Ticket_ledger.spend ctxt tidx source_idx qty in + let withdrawal = {destination = l1_dest; ticket_hash; amount = qty} in + return (ctxt, indexes, Some withdrawal) | Layer2 l2_dest -> let* (ctxt, created_addr, dest_idx) = address_index ctxt l2_dest in let* (ctxt, created_ticket, tidx) = ticket_index ctxt ticket_hash in @@ -562,7 +619,7 @@ module Make (Context : CONTEXT) = struct let indexes = add_indexes indexes (created_addr, dest_idx) (created_ticket, tidx) in - return (ctxt, indexes) + return (ctxt, indexes, None) (** [check_counter ctxt signer counter] asserts that the provided [counter] is the successor of the one associated to the [signer] in the [ctxt]. *) @@ -585,15 +642,21 @@ module Make (Context : CONTEXT) = struct ctxt -> indexes -> (Indexable.index_only, Indexable.unknown) operation -> - (ctxt * indexes) m = + (ctxt * indexes * withdrawal list) m = fun ctxt indexes {signer; counter; contents} -> (* Before applying any operation, we check the counter *) let* () = check_counter ctxt signer counter in - list_fold_left_m - (fun (ctxt, indexes) content -> - apply_operation_content ctxt indexes signer content) - (ctxt, indexes) - contents + let* (ctxt, indexes, rev_withdrawals) = + list_fold_left_m + (fun (ctxt, indexes, withdrawals) content -> + let* (ctxt, indexes, withdrawal_opt) = + apply_operation_content ctxt indexes signer content + in + return (ctxt, indexes, Option.to_list withdrawal_opt @ withdrawals)) + (ctxt, indexes, []) + contents + in + return (ctxt, indexes, rev_withdrawals |> List.rev) (** [apply_transaction ctxt indexes transaction] applies each operation in the [transaction]. It returns a {!transaction_result}, i.e. either @@ -605,25 +668,30 @@ module Make (Context : CONTEXT) = struct ctxt -> indexes -> (Indexable.index_only, Indexable.unknown) transaction -> - (ctxt * indexes * transaction_result) m = + (ctxt * indexes * transaction_result * withdrawal list) m = fun initial_ctxt initial_indexes transaction -> - let rec fold (ctxt, prev_indexes) index ops = + let rec fold (ctxt, prev_indexes, withdrawals) index ops = match ops with - | [] -> return (ctxt, prev_indexes, Transaction_success) + | [] -> return (ctxt, prev_indexes, Transaction_success, withdrawals) | op :: rst -> - let* (ctxt, indexes, status) = + let* (ctxt, indexes, status, withdrawals) = catch (apply_operation ctxt prev_indexes op) - (fun (ctxt, indexes) -> fold (ctxt, indexes) (index + 1) rst) + (fun (ctxt, indexes, op_withdrawals) -> + fold + (ctxt, indexes, withdrawals @ op_withdrawals) + (index + 1) + rst) (fun reason -> return ( initial_ctxt, initial_indexes, - Transaction_failure {index; reason} )) + Transaction_failure {index; reason}, + [] )) in - return (ctxt, indexes, status) + return (ctxt, indexes, status, withdrawals) in - fold (initial_ctxt, initial_indexes) 0 transaction + fold (initial_ctxt, initial_indexes, []) 0 transaction (** [update_counters ctxt status transaction] updates the counters for the signers of operations in [transaction]. If the [transaction] @@ -644,28 +712,37 @@ module Make (Context : CONTEXT) = struct let apply_batch : ctxt -> (Indexable.unknown, Indexable.unknown) t -> - (ctxt * Message_result.Batch_V1.t) m = + (ctxt * Message_result.Batch_V1.t * withdrawal list) m = fun ctxt batch -> let* (ctxt, indexes, batch) = check_signature ctxt batch in let {contents; _} = batch in - let* (ctxt, indexes, rev_results) = + let* (ctxt, indexes, rev_results, withdrawals) = list_fold_left_m - (fun (prev_ctxt, prev_indexes, results) transaction -> - let* (new_ctxt, new_indexes, status) = + (fun (prev_ctxt, prev_indexes, results, withdrawals) transaction -> + let* (new_ctxt, new_indexes, status, transaction_withdrawals) = apply_transaction prev_ctxt prev_indexes transaction in let* new_ctxt = update_counters new_ctxt status transaction in - return (new_ctxt, new_indexes, (transaction, status) :: results)) - (ctxt, indexes, []) + return + ( new_ctxt, + new_indexes, + (transaction, status) :: results, + withdrawals @ transaction_withdrawals )) + (ctxt, indexes, [], []) contents in let results = List.rev rev_results in - return (ctxt, Message_result.Batch_V1.Batch_result {results; indexes}) + return + ( ctxt, + Message_result.Batch_V1.Batch_result {results; indexes}, + withdrawals ) end let apply_deposit : - ctxt -> Tx_rollup_message.deposit -> (ctxt * deposit_result) m = - fun initial_ctxt Tx_rollup_message.{destination; ticket_hash; amount} -> + ctxt -> + Tx_rollup_message.deposit -> + (ctxt * deposit_result * withdrawal option) m = + fun initial_ctxt Tx_rollup_message.{sender; destination; ticket_hash; amount} -> let apply_deposit () = let* (ctxt, created_addr, aidx) = address_index initial_ctxt destination @@ -681,8 +758,13 @@ module Make (Context : CONTEXT) = struct in catch (apply_deposit ()) - (fun (ctxt, indexes) -> return (ctxt, Deposit_success indexes)) - (fun reason -> return (initial_ctxt, Deposit_failure reason)) + (fun (ctxt, indexes) -> return (ctxt, Deposit_success indexes, None)) + (fun reason -> + (* Should there be an error during the deposit, then return + the full [amount] to [sender] in the form of a + withdrawal. *) + let withdrawal = {destination = sender; ticket_hash; amount} in + return (initial_ctxt, Deposit_failure reason, Some withdrawal)) let apply_message : ctxt -> Tx_rollup_message.t -> (ctxt * Message_result.t) m = @@ -690,16 +772,18 @@ module Make (Context : CONTEXT) = struct let open Tx_rollup_message in match msg with | Deposit deposit -> - let* (ctxt, result) = apply_deposit ctxt deposit in - return (ctxt, Deposit_result result) + let* (ctxt, result, withdrawl_opt) = apply_deposit ctxt deposit in + return (ctxt, (Deposit_result result, Option.to_list withdrawl_opt)) | Batch str -> ( let batch = Data_encoding.Binary.of_string_opt Tx_rollup_l2_batch.encoding str in match batch with | Some (V1 batch) -> - let* (ctxt, result) = Batch_V1.apply_batch ctxt batch in - return (ctxt, Batch_V1_result result) + let* (ctxt, result, withdrawals) = + Batch_V1.apply_batch ctxt batch + in + return (ctxt, (Batch_V1_result result, withdrawals)) | None -> fail Invalid_batch_encoding) end diff --git a/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.mli b/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.mli index 017792034ecb7ae0c2ba8e325a34a6c444d37889..4b58afd7f1f898bd551c86dbaa40e9bad07a7b5d 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.mli +++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.mli @@ -59,7 +59,8 @@ type error += | Multiple_operations_for_signer of Bls_signature.pk | Invalid_transaction_encoding | Invalid_batch_encoding - | Invalid_operation_destination + | Unexpectedly_indexed_ticket + | Missing_ticket of Ticket_hash.t module Address_indexes : Map.S with type key = Tx_rollup_l2_address.t @@ -79,7 +80,14 @@ type indexes = { } module Message_result : sig + type withdrawal = { + destination : Signature.Public_key_hash.t; + ticket_hash : Ticket_hash.t; + amount : Tx_rollup_l2_qty.t; + } + (** A transaction inside a batch can either be a success or a failure. + In the case of a failure, we store the operation's index which failed with the reason it failed. *) type transaction_result = @@ -105,7 +113,14 @@ module Message_result : sig } end - type t = Deposit_result of deposit_result | Batch_V1_result of Batch_V1.t + type message_result = + | Deposit_result of deposit_result + | Batch_V1_result of Batch_V1.t + + (* In addition to [message_result] the result contains the list of + withdrawals that result from failing deposits and layer2-to-layer1 + transfers. *) + type t = message_result * withdrawal list val encoding : t Data_encoding.t end @@ -121,7 +136,7 @@ module Make (Context : CONTEXT) : sig module Batch_V1 : sig open Tx_rollup_l2_batch.V1 - (** [apply_batch ctxt batch] interpets the batch {Tx_rollup_l2_batch.V1.t}. + (** [apply_batch ctxt batch] interprets the batch {Tx_rollup_l2_batch.V1.t}. By construction, a failing transaction will not affect the [ctxt] and other transactions will still be interpreted. @@ -133,11 +148,14 @@ module Make (Context : CONTEXT) : sig that is correctly signed and whose every operations have the expected counter. In particular, the result of the application is not important (i.e. the counters are updated even if the transaction failed). + + In addition, the list of withdrawals resulting from each + layer2-to-layer1 transfer message in the batch is returned. *) val apply_batch : ctxt -> (Indexable.unknown, Indexable.unknown) t -> - (ctxt * Message_result.Batch_V1.t) m + (ctxt * Message_result.Batch_V1.t * Message_result.withdrawal list) m (** [check_signature ctxt batch] asserts that [batch] is correctly signed. @@ -176,13 +194,15 @@ module Make (Context : CONTEXT) : sig (** [apply_deposit ctxt deposit] credits a quantity of tickets to a layer2 address in [ctxt]. - This function can fail if the [deposit.amount] is not strictly-positive - or if the [deposit.quantity] caused an overflow in the context. + This function can fail if the [deposit.amount] is not strictly-positive. + + If the [deposit] causes an error, then a withdrawal returning + the funds to the deposit's sender is returned. *) val apply_deposit : ctxt -> Tx_rollup_message.deposit -> - (ctxt * Message_result.deposit_result) m + (ctxt * Message_result.deposit_result * Message_result.withdrawal option) m (** [apply_message ctxt message] interpets the [message] in the [ctxt]. @@ -192,11 +212,14 @@ module Make (Context : CONTEXT) : sig {li Decodes the batch and interprets it for the correct batch version. }} - The function can fail with {!Invalid_batch_encoding} if its not able + The function can fail with {!Invalid_batch_encoding} if it's not able to decode the batch. The function can also return errors from subsequent functions, see {!apply_deposit} and batch interpretations for various versions. + + The list of withdrawals in the message result followed the ordering + of the contents in the message. *) val apply_message : ctxt -> Tx_rollup_message.t -> (ctxt * Message_result.t) m end diff --git a/src/proto_alpha/lib_protocol/tx_rollup_l2_batch.ml b/src/proto_alpha/lib_protocol/tx_rollup_l2_batch.ml index bfc33f16c27f2c6ad073f5db14e55fc27dc105b8..e51d0e7b4f1a8c57e18264e6f8388a30b214bd99 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_l2_batch.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_batch.ml @@ -39,6 +39,21 @@ let signer_encoding = | None -> Error "not a BLS public key") (Fixed.bytes Bls_signature.pk_size_in_bytes) +(* A version of Data_encoding.Compact.conv that can check an invariant + at encoding and decoding. + + It is used at runtime to enforce the invariant that transfers to L1 + accounts should reference tickets by value. + + TODO: does this makes sense? Wouldn't it be easier to have the + type of operation_content enforce this invariant? +*) +let with_coding_guard guard encoding = + let guard_conv x = + match guard x with Ok () -> x | Error s -> raise (Invalid_argument s) + in + Data_encoding.Compact.conv guard_conv guard_conv encoding + module Signer_indexable = Indexable.Make (struct type t = Bls_signature.pk @@ -106,6 +121,19 @@ module V1 = struct (req "ticket_hash" Ticket_indexable.compact) (req "qty" Tx_rollup_l2_qty.compact_encoding)) + let compact_operation_content = + with_coding_guard + (function + | {destination; ticket_hash; _} -> ( + match (destination, Indexable.destruct ticket_hash) with + | (Layer1 _, Left _) -> + (* Layer2-to-layer1 transfers must include the value of the ticket_hash *) + Result.error + "Attempted to decode layer2 operation containing ticket \ + index." + | _ -> Result.ok ())) + compact_operation_content + let operation_content_encoding = Data_encoding.Compact.make ~tag_size compact_operation_content diff --git a/src/proto_alpha/lib_protocol/tx_rollup_l2_batch.mli b/src/proto_alpha/lib_protocol/tx_rollup_l2_batch.mli index ef4f62e244d6c07b406d41a7c1e89dd31a1b9b1a..222b4111fe0e56e6e3f3fdbccd80dd3088572fcf 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_l2_batch.mli +++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_batch.mli @@ -208,7 +208,20 @@ module V1 : sig {li [01] means an integer fitting on 2 bytes.} {li [10] means an integer fitting on 4 bytes.} {li [11] means an integer fitting on 8 bytes.} - } *) + } + + If used to read, respectively write, a value where the + the [destination] is a layer-1 address and the ticket_hash is an + index, which is not allowed by the layer-2 protocol, then a + + - [Data_encoding.Binary.Read_error (Exception_raised_in_user_function ...)], + + respectively + + - [Data_encoding.Binary.Write_error (Exception_raised_in_user_function ...)] + + exception is raised. + *) val compact_operation_content : Indexable.unknown operation_content Data_encoding.Compact.t end diff --git a/src/proto_alpha/lib_protocol/tx_rollup_l2_context.ml b/src/proto_alpha/lib_protocol/tx_rollup_l2_context.ml index 7ea8fb664b2dd3cfde588bba0166f154cd5ab0b5..c51ca025662423ae6a6589e5512fe6467886e187 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_l2_context.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_context.ml @@ -46,100 +46,6 @@ let metadata_encoding = (fun (counter, public_key) -> {counter; public_key}) (obj2 (req "counter" int64) (req "public_key" pk_encoding))) -type error += - | Unknown_address_index of address_index - | Balance_too_low - | Balance_overflow - | Invalid_quantity - | Metadata_already_initialized of address_index - | Too_many_l2_addresses - | Too_many_l2_tickets - | Counter_overflow - -let () = - let open Data_encoding in - (* Unknown address index *) - register_error_kind - `Temporary - ~id:"tx_rollup_unknown_address_index" - ~title:"Unknown address index" - ~description:"Tried to increment the counter of an unknown address index" - (obj1 (req "index" Tx_rollup_l2_address.Indexable.index_encoding)) - (function Unknown_address_index x -> Some x | _ -> None) - (fun x -> Unknown_address_index x) ; - (* Balance too low *) - register_error_kind - `Temporary - ~id:"tx_rollup_balance_too_low" - ~title:"Balance too low" - ~description: - "Tried to spend a ticket index from an index without the required balance" - empty - (function Balance_too_low -> Some () | _ -> None) - (fun () -> Balance_too_low) ; - (* Balance overflow *) - register_error_kind - `Temporary - ~id:"tx_rollup_balance_overflow" - ~title:"Balance overflow" - ~description: - "Tried to credit a ticket index to an index to a new balance greater \ - than the integer 32 limit" - empty - (function Balance_overflow -> Some () | _ -> None) - (fun () -> Balance_overflow) ; - (* Invalid_quantity *) - register_error_kind - `Permanent - ~id:"tx_rollup_invalid_quantity" - ~title:"Invalid quantity" - ~description: - "Tried to credit a ticket index to an index with a quantity non-strictly \ - positive" - empty - (function Invalid_quantity -> Some () | _ -> None) - (fun () -> Invalid_quantity) ; - (* Metadata already initialized *) - register_error_kind - `Branch - ~id:"tx_rollup_metadata_already_initialized" - ~title:"Metadata already initiliazed" - ~description: - "Tried to initialize a metadata for an index which was already \ - initiliazed" - (obj1 (req "index" Tx_rollup_l2_address.Indexable.index_encoding)) - (function Metadata_already_initialized x -> Some x | _ -> None) - (fun x -> Metadata_already_initialized x) ; - (* Too many l2 addresses associated *) - register_error_kind - `Branch - ~id:"tx_rollup_too_many_l2_addresses" - ~title:"Too many l2 addresses" - ~description:"The number of l2 addresses has reached the integer 32 limit" - empty - (function Too_many_l2_addresses -> Some () | _ -> None) - (fun () -> Too_many_l2_addresses) ; - (* Too many l2 tickets associated *) - register_error_kind - `Branch - ~id:"tx_rollup_too_many_l2_tickets" - ~title:"Too many l2 tickets" - ~description:"The number of l2 tickets has reached the integer 32 limit" - empty - (function Too_many_l2_tickets -> Some () | _ -> None) - (fun () -> Too_many_l2_tickets) ; - (* Counter overflow *) - register_error_kind - `Branch - ~id:"tx_rollup_counter_overflow" - ~title:"Counter overflow" - ~description: - "Tried to increment the counter of an address and reached the integer 64 \ - limit" - empty - (function Counter_overflow -> Some () | _ -> None) - (fun () -> Counter_overflow) - (** {1 Type-Safe Storage Access and Gas Accounting} *) (** A value of type ['a key] identifies a value of type ['a] in an @@ -273,6 +179,9 @@ struct module Syntax = struct include S.Syntax + let ( let*? ) res f = + match res with Result.Ok v -> f v | Result.Error error -> fail error + let fail_unless cond error = let open S.Syntax in if cond then return () else fail error diff --git a/src/proto_alpha/lib_protocol/tx_rollup_l2_context_sig.ml b/src/proto_alpha/lib_protocol/tx_rollup_l2_context_sig.ml index 8d106aa516d2f6e6524b83fe0f9ecff57b3aaa08..20a7f760d50f8f3ec07339c5f1a2c28695ba4ee4 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_l2_context_sig.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_context_sig.ml @@ -73,6 +73,90 @@ type error += | Too_many_l2_tickets | Counter_overflow +let () = + let open Data_encoding in + (* Unknown address index *) + register_error_kind + `Temporary + ~id:"tx_rollup_unknown_address_index" + ~title:"Unknown address index" + ~description:"Tried to increment the counter of an unknown address index" + (obj1 (req "index" Tx_rollup_l2_address.Indexable.index_encoding)) + (function Unknown_address_index x -> Some x | _ -> None) + (fun x -> Unknown_address_index x) ; + (* Balance too low *) + register_error_kind + `Temporary + ~id:"tx_rollup_balance_too_low" + ~title:"Balance too low" + ~description: + "Tried to spend a ticket index from an index without the required balance" + empty + (function Balance_too_low -> Some () | _ -> None) + (fun () -> Balance_too_low) ; + (* Balance overflow *) + register_error_kind + `Temporary + ~id:"tx_rollup_balance_overflow" + ~title:"Balance overflow" + ~description: + "Tried to credit a ticket index to an index to a new balance greater \ + than the integer 32 limit" + empty + (function Balance_overflow -> Some () | _ -> None) + (fun () -> Balance_overflow) ; + (* Invalid_quantity *) + register_error_kind + `Permanent + ~id:"tx_rollup_invalid_quantity" + ~title:"Invalid quantity" + ~description: + "Tried to credit a ticket index to an index with a quantity non-strictly \ + positive" + empty + (function Invalid_quantity -> Some () | _ -> None) + (fun () -> Invalid_quantity) ; + (* Metadata already initialized *) + register_error_kind + `Branch + ~id:"tx_rollup_metadata_already_initialized" + ~title:"Metadata already initiliazed" + ~description: + "Tried to initialize a metadata for an index which was already \ + initiliazed" + (obj1 (req "index" Tx_rollup_l2_address.Indexable.index_encoding)) + (function Metadata_already_initialized x -> Some x | _ -> None) + (fun x -> Metadata_already_initialized x) ; + (* Too many l2 addresses associated *) + register_error_kind + `Branch + ~id:"tx_rollup_too_many_l2_addresses" + ~title:"Too many l2 addresses" + ~description:"The number of l2 addresses has reached the integer 32 limit" + empty + (function Too_many_l2_addresses -> Some () | _ -> None) + (fun () -> Too_many_l2_addresses) ; + (* Too many l2 tickets associated *) + register_error_kind + `Branch + ~id:"tx_rollup_too_many_l2_tickets" + ~title:"Too many l2 tickets" + ~description:"The number of l2 tickets has reached the integer 32 limit" + empty + (function Too_many_l2_tickets -> Some () | _ -> None) + (fun () -> Too_many_l2_tickets) ; + (* Counter overflow *) + register_error_kind + `Branch + ~id:"tx_rollup_counter_overflow" + ~title:"Counter overflow" + ~description: + "Tried to increment the counter of an address and reached the integer 64 \ + limit" + empty + (function Counter_overflow -> Some () | _ -> None) + (fun () -> Counter_overflow) + (** This module type describes the API of the [Tx_rollup] context, which is used to implement the semantics of the L2 operations. *) module type CONTEXT = sig @@ -100,6 +184,10 @@ module type CONTEXT = sig val ( let* ) : 'a m -> ('a -> 'b m) -> 'b m + (** [let*?] is for binding the value from Result-only + expressions into the storage monad. *) + val ( let*? ) : ('a, error) result -> ('a -> 'b m) -> 'b m + (** [fail err] shortcuts the current computation by raising an error. diff --git a/src/proto_alpha/lib_protocol/tx_rollup_message_repr.ml b/src/proto_alpha/lib_protocol/tx_rollup_message_repr.ml index ba2a55e82e60da5c229458b7f647c7317b759344..f0fc905264b115055975d14f4a1766b26b6101d4 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_message_repr.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_message_repr.ml @@ -26,6 +26,7 @@ (*****************************************************************************) type deposit = { + sender : Signature.Public_key_hash.t; destination : Tx_rollup_l2_address.Indexable.value; ticket_hash : Ticket_hash_repr.t; amount : Tx_rollup_l2_qty.t; @@ -34,11 +35,12 @@ type deposit = { let deposit_encoding = let open Data_encoding in conv - (fun {destination; ticket_hash; amount} -> - (destination, ticket_hash, amount)) - (fun (destination, ticket_hash, amount) -> - {destination; ticket_hash; amount}) - @@ obj3 + (fun {sender; destination; ticket_hash; amount} -> + (sender, destination, ticket_hash, amount)) + (fun (sender, destination, ticket_hash, amount) -> + {sender; destination; ticket_hash; amount}) + @@ obj4 + (req "sender" Signature.Public_key_hash.encoding) (req "destination" Tx_rollup_l2_address.Indexable.value_encoding) (req "ticket_hash" Ticket_hash_repr.encoding) (req "amount" Tx_rollup_l2_qty.encoding) @@ -80,10 +82,13 @@ let pp fmt = "@[Batch:@ %s%s@]" (Hex.of_string str |> Hex.show) ellipsis - | Deposit {destination; ticket_hash; amount} -> + | Deposit {sender; destination; ticket_hash; amount} -> fprintf fmt - "@[Deposit:@ destination=%a,@ ticket_hash=%a,@ amount:%a@]" + "@[Deposit:@ sender=%a,@ destination=%a,@ ticket_hash=%a,@ \ + amount:%a@]" + Signature.Public_key_hash.pp + sender Tx_rollup_l2_address.Indexable.pp destination Ticket_hash_repr.pp @@ -93,7 +98,10 @@ let pp fmt = let size = function | Batch batch -> String.length batch - | Deposit {destination = d; ticket_hash = _; amount = _} -> + | Deposit {sender = _; destination = d; ticket_hash = _; amount = _} -> + (* Size of a BLS public key, that is the underlying type of a + l2 address. See [Tx_rollup_l2_address] *) + let sender_size = Signature.Public_key_hash.size in (* Size of a BLS public key, that is the underlying type of a l2 address. See [Tx_rollup_l2_address] *) let destination_size = Tx_rollup_l2_address.Indexable.size d in @@ -102,7 +110,7 @@ let size = function let key_hash_size = 32 in (* [int64] *) let amount_size = 8 in - destination_size + key_hash_size + amount_size + sender_size + destination_size + key_hash_size + amount_size let hash_size = 32 diff --git a/src/proto_alpha/lib_protocol/tx_rollup_message_repr.mli b/src/proto_alpha/lib_protocol/tx_rollup_message_repr.mli index 911dafa842d1de94d31c7ec943ae65f27e45280e..daf43b3ed6407b89286916425ac671d97acb6be6 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_message_repr.mli +++ b/src/proto_alpha/lib_protocol/tx_rollup_message_repr.mli @@ -33,8 +33,12 @@ inboxes (see {!Tx_rollup_repr_storage.append_message}). *) (** Smart contract on the layer-1 can deposit tickets into a - transaction rollup, for the benefit of a {!Tx_rollup_l2_address.t}. *) + transaction rollup, for the benefit of a {!Tx_rollup_l2_address.t}. + The [sender] is an implicit account where the deposit is returned in form of + a withdrawal, should the application of the deposit fail. + *) type deposit = { + sender : Signature.Public_key_hash.t; destination : Tx_rollup_l2_address.Indexable.value; ticket_hash : Ticket_hash_repr.t; amount : Tx_rollup_l2_qty.t; diff --git a/tezt/_regressions/rpc/alpha.client.mempool.out b/tezt/_regressions/rpc/alpha.client.mempool.out index 359dd48c76abb0cf30253104698853a65d9a1b22..dba8ee4355cd925c6be8cba5a8f898c905fbabc8 100644 --- a/tezt/_regressions/rpc/alpha.client.mempool.out +++ b/tezt/_regressions/rpc/alpha.client.mempool.out @@ -2140,6 +2140,9 @@ curl -s 'http://localhost:[PORT]/describe/chains/main/mempool?recurse=yes' "deposit": { "type": "object", "properties": { + "sender": { + "$ref": "#/definitions/Signature.Public_key_hash" + }, "destination": { "$ref": "#/definitions/Tx_rollup_l2_address" }, @@ -2232,7 +2235,8 @@ curl -s 'http://localhost:[PORT]/describe/chains/main/mempool?recurse=yes' "required": [ "amount", "ticket_hash", - "destination" + "destination", + "sender" ], "additionalProperties": false } @@ -2920,6 +2924,18 @@ curl -s 'http://localhost:[PORT]/describe/chains/main/mempool?recurse=yes' }, "encoding": { "fields": [ + { + "name": "sender", + "layout": { + "name": "public_key_hash", + "kind": "Ref" + }, + "data_kind": { + "size": 21, + "kind": "Float" + }, + "kind": "named" + }, { "name": "destination", "layout": { @@ -8399,6 +8415,9 @@ curl -s 'http://localhost:[PORT]/describe/chains/main/mempool?recurse=yes' "deposit": { "type": "object", "properties": { + "sender": { + "$ref": "#/definitions/Signature.Public_key_hash" + }, "destination": { "$ref": "#/definitions/Tx_rollup_l2_address" }, @@ -8491,7 +8510,8 @@ curl -s 'http://localhost:[PORT]/describe/chains/main/mempool?recurse=yes' "required": [ "amount", "ticket_hash", - "destination" + "destination", + "sender" ], "additionalProperties": false } diff --git a/tezt/_regressions/rpc/alpha.proxy.mempool.out b/tezt/_regressions/rpc/alpha.proxy.mempool.out index 774f139222e9a5a14bcda298bf38e04cee2050a8..9a213073a9a183f79e8a00cd6000f0bba3ef99f3 100644 --- a/tezt/_regressions/rpc/alpha.proxy.mempool.out +++ b/tezt/_regressions/rpc/alpha.proxy.mempool.out @@ -2161,6 +2161,9 @@ curl -s 'http://localhost:[PORT]/describe/chains/main/mempool?recurse=yes' "deposit": { "type": "object", "properties": { + "sender": { + "$ref": "#/definitions/Signature.Public_key_hash" + }, "destination": { "$ref": "#/definitions/Tx_rollup_l2_address" }, @@ -2253,7 +2256,8 @@ curl -s 'http://localhost:[PORT]/describe/chains/main/mempool?recurse=yes' "required": [ "amount", "ticket_hash", - "destination" + "destination", + "sender" ], "additionalProperties": false } @@ -2941,6 +2945,18 @@ curl -s 'http://localhost:[PORT]/describe/chains/main/mempool?recurse=yes' }, "encoding": { "fields": [ + { + "name": "sender", + "layout": { + "name": "public_key_hash", + "kind": "Ref" + }, + "data_kind": { + "size": 21, + "kind": "Float" + }, + "kind": "named" + }, { "name": "destination", "layout": { @@ -8420,6 +8436,9 @@ curl -s 'http://localhost:[PORT]/describe/chains/main/mempool?recurse=yes' "deposit": { "type": "object", "properties": { + "sender": { + "$ref": "#/definitions/Signature.Public_key_hash" + }, "destination": { "$ref": "#/definitions/Tx_rollup_l2_address" }, @@ -8512,7 +8531,8 @@ curl -s 'http://localhost:[PORT]/describe/chains/main/mempool?recurse=yes' "required": [ "amount", "ticket_hash", - "destination" + "destination", + "sender" ], "additionalProperties": false }