diff --git a/src/proto_alpha/lib_protocol/test/helpers/assert.ml b/src/proto_alpha/lib_protocol/test/helpers/assert.ml index 61b929cdaf48b3ca61501094157451dcebe00073..da3e4892c0df4b824fee3a0d852006b40181be33 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/assert.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/assert.ml @@ -199,3 +199,14 @@ let pp_print_list pp out xs = let assert_equal_list ~loc eq msg pp = equal ~loc (List.equal eq) msg (pp_print_list pp) + +let to_json_string encoding x = + x + |> Data_encoding.Json.construct encoding + |> Format.asprintf "\n%a\n" Data_encoding.Json.pp + +let equal_with_encoding ~loc encoding a b = + equal_string ~loc (to_json_string encoding a) (to_json_string encoding b) + +let not_equal_with_encoding ~loc encoding a b = + not_equal_string ~loc (to_json_string encoding a) (to_json_string encoding b) diff --git a/src/proto_alpha/lib_protocol/test/helpers/context.ml b/src/proto_alpha/lib_protocol/test/helpers/context.ml index 8102f559f9d23e5aae09dba5a194e5342752e6ef..be21de4af4f215fd2c79338c3e10927b91efc27e 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/context.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/context.ml @@ -365,6 +365,17 @@ module Tx_rollup = struct Tx_rollup_services.commitment rpc_ctxt ctxt tx_rollup end +module Sc_rollup = struct + let inbox ctxt sc_rollup = + Environment.RPC_context.make_call1 + Plugin.RPC.Sc_rollup.S.inbox + rpc_ctxt + ctxt + sc_rollup + () + () +end + type (_, _) tup = | T1 : ('a, 'a) tup | T2 : ('a, 'a * 'a) tup diff --git a/src/proto_alpha/lib_protocol/test/helpers/context.mli b/src/proto_alpha/lib_protocol/test/helpers/context.mli index c11e6c1020213f4857eede9db5d9e3aedbce3adc..9e796caed477cc1c17be2e51af23023486bda1c2 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/context.mli +++ b/src/proto_alpha/lib_protocol/test/helpers/context.mli @@ -213,6 +213,10 @@ module Tx_rollup : sig Tx_rollup_commitment.Submitted_commitment.t option tzresult Lwt.t end +module Sc_rollup : sig + val inbox : t -> Sc_rollup.t -> Sc_rollup.Inbox.t tzresult Lwt.t +end + type (_, _) tup = | T1 : ('a, 'a) tup | T2 : ('a, 'a * 'a) tup diff --git a/src/proto_alpha/lib_protocol/test/helpers/contract_helpers.ml b/src/proto_alpha/lib_protocol/test/helpers/contract_helpers.ml index aced2a46bffc95b270f49313429d27342f469308..4053b8f6b9b59ddc9c504e196e044583d720c52b 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/contract_helpers.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/contract_helpers.ml @@ -116,14 +116,14 @@ let run_script ctx ?logger ?(step_constants = default_step_constants) ~internal >>=?? fun res -> return res -let originate_contract_from_string ~script ~storage ~source_contract ~baker +let originate_contract_from_string_hash ~script ~storage ~source_contract ~baker block = let code = Expr.toplevel_from_string script in let storage = Expr.from_string storage in let script = Alpha_context.Script.{code = lazy_expr code; storage = lazy_expr storage} in - Op.contract_origination + Op.contract_origination_hash (B block) source_contract ~fee:(Test_tez.of_int 10) @@ -133,3 +133,13 @@ let originate_contract_from_string ~script ~storage ~source_contract ~baker >>=? fun incr -> Incremental.add_operation incr operation >>=? fun incr -> Incremental.finalize_block incr >|=? fun b -> (dst, script, b) + +let originate_contract_from_string ~script ~storage ~source_contract ~baker + block = + originate_contract_from_string_hash + ~script + ~storage + ~source_contract + ~baker + block + >|=? fun (dst, script, b) -> (Contract.Originated dst, script, b) diff --git a/src/proto_alpha/lib_protocol/test/helpers/ticket_helpers.ml b/src/proto_alpha/lib_protocol/test/helpers/ticket_helpers.ml new file mode 100644 index 0000000000000000000000000000000000000000..2d324a79f5b33318af09bd74a7ba50e88900d183 --- /dev/null +++ b/src/proto_alpha/lib_protocol/test/helpers/ticket_helpers.ml @@ -0,0 +1,47 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2022 Trili Tech, *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) + +open Protocol +open Alpha_context + +let assert_balance ctxt ~loc key expected = + let open Lwt_result_syntax in + let* balance, _ = + Ticket_balance.get_balance ctxt key >|= Environment.wrap_tzresult + in + match (balance, expected) with + | Some b, Some eb -> Assert.equal_int ~loc (Z.to_int b) eb + | None, Some eb -> failwith "Expected balance %d" eb + | Some eb, None -> failwith "Expected None but got %d" (Z.to_int eb) + | None, None -> return_unit + +let string_ticket_token ticketer content = + let open Lwt_result_syntax in + let contents = + Result.value_f ~default:(fun _ -> assert false) + @@ Script_string.of_string content + in + let*? ticketer = Environment.wrap_tzresult @@ Contract.of_b58check ticketer in + return + (Ticket_token.Ex_token + {ticketer; contents_type = Script_typed_ir.string_t; contents}) diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_accounting.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_accounting.ml index c51b48575f4507d74418473202ff31f5a447efc0..ca3b2d839afc9a676273feed7defcb467f95457b 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_accounting.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_accounting.ml @@ -445,14 +445,7 @@ let assert_ticket_diffs ctxt ~loc ~arg_type ~storage_type ~arg ~old_storage in assert_equal_ticket_diffs ~loc ctxt ticket_diffs expected -let assert_balance ctxt ~loc key expected = - let open Lwt_result_syntax in - let* balance, _ = wrap @@ Ticket_balance.get_balance ctxt key in - match (balance, expected) with - | Some b, Some eb -> Assert.equal_int ~loc (Z.to_int b) eb - | None, Some eb -> failwith "Expected balance %d" eb - | Some eb, None -> failwith "Expected None but got %d" (Z.to_int eb) - | None, None -> return () +let assert_balance = Ticket_helpers.assert_balance let string_ticket ticketer contents amount = let amount = Script_int.abs @@ Script_int.of_int amount in @@ -466,16 +459,7 @@ let string_ticket ticketer contents amount = in Script_typed_ir.{ticketer; contents; amount} -let string_ticket_token ticketer content = - let open Lwt_result_syntax in - let contents = - Result.value_f ~default:(fun _ -> assert false) - @@ Script_string.of_string content - in - let*? ticketer = Environment.wrap_tzresult @@ Contract.of_b58check ticketer in - return - (Ticket_token.Ex_token - {ticketer; contents_type = Script_typed_ir.string_t; contents}) +let string_ticket_token = Ticket_helpers.string_ticket_token let test_diffs_empty () = let open Lwt_result_syntax in diff --git a/src/proto_alpha/lib_protocol/test/integration/operations/main.ml b/src/proto_alpha/lib_protocol/test/integration/operations/main.ml index d7944e194a8ee48e4554b1474ff41ea456d67510..7c4bb9450620b1f7b9fe3bf95f044c057a26f0d6 100644 --- a/src/proto_alpha/lib_protocol/test/integration/operations/main.ml +++ b/src/proto_alpha/lib_protocol/test/integration/operations/main.ml @@ -43,5 +43,6 @@ let () = ("failing_noop operation", Test_failing_noop.tests); ("tx rollup", Test_tx_rollup.tests); ("sc rollup", Test_sc_rollup.tests); + ("sc rollup transfer", Test_sc_rollup_transfer.tests); ] |> Lwt_main.run diff --git a/src/proto_alpha/lib_protocol/test/integration/operations/test_sc_rollup.ml b/src/proto_alpha/lib_protocol/test/integration/operations/test_sc_rollup.ml index c0dec561d1e98ee495c8045a1c0da2fd0e47fa0c..c3fc19848a938db99535cbb791ea61165583e3f7 100644 --- a/src/proto_alpha/lib_protocol/test/integration/operations/test_sc_rollup.ml +++ b/src/proto_alpha/lib_protocol/test/integration/operations/test_sc_rollup.ml @@ -135,7 +135,6 @@ let sc_originate block contract parameters_ty = let kind = Sc_rollup.Kind.Example_arith in let* operation, rollup = Op.sc_rollup_origination - ~counter:(Z.of_int 0) (B block) contract kind diff --git a/src/proto_alpha/lib_protocol/test/integration/operations/test_sc_rollup_transfer.ml b/src/proto_alpha/lib_protocol/test/integration/operations/test_sc_rollup_transfer.ml new file mode 100644 index 0000000000000000000000000000000000000000..c3e004e07b53a4aa1f4c16557611f1f3d0ab8448 --- /dev/null +++ b/src/proto_alpha/lib_protocol/test/integration/operations/test_sc_rollup_transfer.ml @@ -0,0 +1,416 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2022 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Testing + ------- + Component: Sc rollup L1/L2 communication + Invocation: dune exec \ + src/proto_alpha/lib_protocol/test/integration/operations/main.exe \ + -- test "^sc rollup transfer$" + Subject: Test transfers from Michelson to smart contract rollups +*) + +open Protocol +open Alpha_context +open Lwt_result_syntax + +(* Helpers *) + +exception Unexpected_error + +let check_proto_error ~loc ~exp f trace = + let*? proto_trace = + List.map_e + (function + | Environment.Ecoproto_error e -> ok e + | e -> + error_with + "At %s, expected protocol error %s, got non-protocol error %a in \ + trace %a" + loc + exp + Error_monad.pp + e + Error_monad.pp_print_trace + trace) + trace + in + try f proto_trace + with Unexpected_error -> + failwith + "At %s, expected error %s, got %a" + loc + exp + Error_monad.pp_print_trace + trace + +let sc_originate = Test_sc_rollup.sc_originate + +(* A contract with four entrypoints: + - [transfer_non_zero] takes a [contract int] and attempts to transfer with a + non-zero amount to it. Expected to fail. + + - [transfer_int] takes a [contract int] and transfers an int to it. Expected + to succeed. + + - [transfer_zero_ticket] takes a [contract (ticket string)] and transfers a + zero-amount ticket to it. Expected to fail. + + - [transfer_ticket] takes a [contract (ticket string)] and transfers a + ticket to it. Expected to succeed. +*) +let contract_originate block account = + let script = + {| + parameter (or (contract %transfer_non_zero int) + (or (contract %transfer_int int) + (or (contract %transfer_zero_ticket (ticket string)) + (or (contract %transfer_ticket (ticket string)) + never)))); + storage unit; + code { + UNPAIR; + IF_LEFT { + # transfer_non_zero + PUSH mutez 1; + PUSH int 42; + TRANSFER_TOKENS; + } { + IF_LEFT { + # transfer_int + PUSH mutez 0; + PUSH int 42; + TRANSFER_TOKENS; + } { + IF_LEFT { + # transfer_zero_ticket + PUSH mutez 0; + PUSH nat 0; + PUSH string "ticket payload"; + TICKET; + TRANSFER_TOKENS; + } { + IF_LEFT { + # transfer ticket + PUSH mutez 0; + PUSH nat 137; + PUSH string "G"; + TICKET; + TRANSFER_TOKENS; + } { + NEVER + } + } + } + }; + NIL operation; + SWAP; + CONS; + PAIR } +|} + in + Contract_helpers.originate_contract_from_string_hash + ~baker:(Context.Contract.pkh account) + ~source_contract:account + ~script + ~storage:"Unit" + block + +let context_init ty = + let* b, c = Test_sc_rollup.context_init T1 in + let* contract, _script, b = contract_originate b c in + let* b, rollup = sc_originate b c ty in + return (b, c, contract, rollup) + +let transfer ?expect_apply_failure b ~from ~to_ ~param ~entrypoint = + let parameters = Script.lazy_expr (Expr.from_string param) in + let* op = + Op.transaction + (B b) + from + (Contract.Originated to_) + Tez.zero + ~parameters + ~entrypoint:(Entrypoint.of_string_strict_exn entrypoint) + ~gas_limit:High + in + let* inc = Incremental.begin_construction b in + let* inc = Incremental.add_operation ?expect_apply_failure inc op in + Incremental.finalize_block inc + +(* Tests *) + +(* Test parsing a [contract] with a badly formatted scr1 address. *) +let test_transfer_to_bad_sc_rollup_address () = + let* b, c, contract, _rollup = context_init "unit" in + let not_an_sc_rollup_address = {|"scr1HLXM32GacPNDrhHDLAssZG88eWqCUbyL"|} in + let* _b = + transfer + b + ~from:c + ~to_:contract + ~param:not_an_sc_rollup_address + ~entrypoint:"transfer_non_zero" + ~expect_apply_failure: + (check_proto_error ~loc:__LOC__ ~exp:"Invalid_destination_b58check" + @@ function + | [ + Script_interpreter.Bad_contract_parameter _; + Script_tc_errors.Invalid_constant (_loc, _expr, ty); + Destination_repr.Invalid_destination_b58check _; + ] -> + Assert.equal_string + ~loc:__LOC__ + "(contract int)" + (Expr.to_string ty) + | _ -> raise Unexpected_error) + in + return_unit + +(* Now, the address is well-formatted but the rollup does not exist. *) +let test_transfer_to_unknown_sc_rollup_address () = + let* b, c, contract, _rollup = context_init "unit" in + let unknown_sc_rollup_address = {|"scr1HLXM32GacPNDrhHDLAssZG88eWqCUbyLF"|} in + let* _b = + transfer + b + ~from:c + ~to_:contract + ~param:unknown_sc_rollup_address + ~entrypoint:"transfer_non_zero" + ~expect_apply_failure: + (check_proto_error ~loc:__LOC__ ~exp:"Sc_rollup_does_not_exist" + @@ function + | [ + Script_interpreter.Bad_contract_parameter _; + Script_tc_errors.Invalid_constant _; + Sc_rollup_errors.Sc_rollup_does_not_exist _; + ] -> + return_unit + | _ -> raise Unexpected_error) + in + return_unit + +(* Now, let's originate an sc rollup, use its address but with a wrong type. *) +let test_transfer_to_wrongly_typed_sc_rollup () = + let* b, c, contract, rollup = context_init "unit" in + let param = Format.sprintf "%S" (Sc_rollup.Address.to_b58check rollup) in + let* _b = + transfer + b + ~from:c + ~to_:contract + ~param + ~entrypoint:"transfer_non_zero" + ~expect_apply_failure: + (check_proto_error ~loc:__LOC__ ~exp:"Inconsistent_types" @@ function + | [ + Script_interpreter.Bad_contract_parameter _; + Script_tc_errors.Invalid_constant _; + Script_tc_errors.Inconsistent_types _; + Script_tc_errors.Inconsistent_types _; + ] -> + return_unit + | _ -> raise Unexpected_error) + in + return_unit + +(* Use the correct type but with a non-zero amount. *) +let test_transfer_non_zero_amount () = + let* b, c, contract, rollup = context_init "int" in + let param = Format.sprintf "%S" (Sc_rollup.Address.to_b58check rollup) in + let* _b = + transfer + b + ~from:c + ~to_:contract + ~param + ~entrypoint:"transfer_non_zero" + ~expect_apply_failure: + (check_proto_error ~loc:__LOC__ ~exp:"Rollup_invalid_transaction_amount" + @@ function + | [ + Script_interpreter.Runtime_contract_error _; + Script_interpreter_defs.Rollup_invalid_transaction_amount; + ] -> + return_unit + | _ -> raise Unexpected_error) + in + return_unit + +(* Use the correct type through an entrypoint but with a non-zero amount. *) +let test_transfer_non_zero_amount_via_entrypoint () = + let* b, c, contract, rollup = + context_init "or (int %use_this_one) (unit %not_that_one)" + in + let param = + Format.sprintf "%S" (Sc_rollup.Address.to_b58check rollup ^ "%use_this_one") + in + let* _b = + transfer + b + ~from:c + ~to_:contract + ~param + ~entrypoint:"transfer_non_zero" + ~expect_apply_failure: + (check_proto_error ~loc:__LOC__ ~exp:"Rollup_invalid_transaction_amount" + @@ function + | [ + Script_interpreter.Runtime_contract_error _; + Script_interpreter_defs.Rollup_invalid_transaction_amount; + ] -> + return_unit + | _ -> raise Unexpected_error) + in + return_unit + +(* Now, transfer with a zero-amount and check that the inbox has been updated correctly. *) +let test_transfer_works () = + let* b, c, contract, rollup = context_init "int" in + let* inbox_before = Context.Sc_rollup.inbox (B b) rollup in + let* expected_inbox_after = + let* inc = Incremental.begin_construction b in + let ctxt = Incremental.alpha_ctxt inc in + let payload = Expr.from_string "42" in + let* expected_inbox_after, _size, _ctxt = + Sc_rollup.Inbox.add_internal_message + ctxt + rollup + ~payload + ~sender:contract + ~source:(Context.Contract.pkh c) + >|= Environment.wrap_tzresult + in + return expected_inbox_after + in + let param = Format.sprintf "%S" (Sc_rollup.Address.to_b58check rollup) in + let* b = transfer b ~from:c ~to_:contract ~param ~entrypoint:"transfer_int" in + let* inbox_after = Context.Sc_rollup.inbox (B b) rollup in + let* () = + Assert.not_equal_with_encoding + ~loc:__LOC__ + Sc_rollup.Inbox.encoding + inbox_before + inbox_after + in + Assert.equal_with_encoding + ~loc:__LOC__ + Sc_rollup.Inbox.encoding + inbox_after + expected_inbox_after + +(* Transfer of zero-amount ticket fails. *) +let test_transfer_zero_amount_ticket () = + let* b, c, contract, rollup = context_init "ticket string" in + let param = Format.sprintf "%S" (Sc_rollup.Address.to_b58check rollup) in + let* _b = + transfer + b + ~from:c + ~to_:contract + ~param + ~entrypoint:"transfer_zero_ticket" + ~expect_apply_failure: + (check_proto_error ~loc:__LOC__ ~exp:"Forbidden_zero_ticket_quantity" + @@ function + | [Ticket_scanner.Forbidden_zero_ticket_quantity] -> return_unit + | _ -> raise Unexpected_error) + in + return_unit + +(* Transfer of a non-zero-amount ticket works and the balance table is correctly updated. *) +let test_transfer_non_zero_amount_ticket () = + let* b, c, contract, rollup = context_init "ticket string" in + let param = Format.sprintf "%S" (Sc_rollup.Address.to_b58check rollup) in + let* b = + transfer b ~from:c ~to_:contract ~param ~entrypoint:"transfer_ticket" + in + let* ticket_key_for_contract, ticket_key_for_rollup, ctxt = + let* ticket_token = + Ticket_helpers.string_ticket_token + (Contract_hash.to_b58check contract) + "G" + in + let* inc = Incremental.begin_construction b in + let ctxt = Incremental.alpha_ctxt inc in + let* ticket_key_for_contract, ctxt = + Ticket_balance_key.of_ex_token + ctxt + ~owner:(Destination.Contract (Originated contract)) + ticket_token + >|= Environment.wrap_tzresult + in + let* ticket_key_for_rollup, _ctxt = + Ticket_balance_key.of_ex_token + ctxt + ~owner:(Destination.Sc_rollup rollup) + ticket_token + >|= Environment.wrap_tzresult + in + return (ticket_key_for_contract, ticket_key_for_rollup, ctxt) + in + (* The rollup is the owner of the tickets *) + let* () = + Ticket_helpers.assert_balance + ctxt + ~loc:__LOC__ + ticket_key_for_rollup + (Some 137) + in + (* The contract didn't retain any ticket in the operation *) + let* () = + Ticket_helpers.assert_balance ctxt ~loc:__LOC__ ticket_key_for_contract None + in + return_unit + +let tests = + [ + Tztest.tztest + "Transfer to a bad sc rollup address" + `Quick + test_transfer_to_bad_sc_rollup_address; + Tztest.tztest + "Transfer to an unknown rollup address" + `Quick + test_transfer_to_unknown_sc_rollup_address; + Tztest.tztest + "Transfer with a wrong type" + `Quick + test_transfer_to_wrongly_typed_sc_rollup; + Tztest.tztest + "Transfer with a non-zero amount" + `Quick + test_transfer_non_zero_amount_via_entrypoint; + Tztest.tztest "Transfer works" `Quick test_transfer_works; + Tztest.tztest + "Transfer of zero-amount ticket" + `Quick + test_transfer_zero_amount_ticket; + Tztest.tztest + "Transfer of non-zero-amount ticket" + `Quick + test_transfer_non_zero_amount_ticket; + ]