diff --git a/.gitlab/ci/test/unit.yml b/.gitlab/ci/test/unit.yml index 0dfb65e5aa50e9e43d5d0d093d0cf6c8b369f5b1..112d90221ceede1b4c57e438418dca75136c5c65 100644 --- a/.gitlab/ci/test/unit.yml +++ b/.gitlab/ci/test/unit.yml @@ -119,6 +119,7 @@ unit:014_PtKathma: proto_014_PtKathma__lib_protocol__2: > @src/proto_014_PtKathma/lib_protocol/test/integration/michelson/runtest @src/proto_014_PtKathma/lib_protocol/test/integration/operations/runtest + @src/proto_014_PtKathma/lib_protocol/test/integration/validate/runtest proto_014_PtKathma__lib_protocol__3: > @src/proto_014_PtKathma/lib_protocol/test/pbt/runtest @src/proto_014_PtKathma/lib_protocol/test/unit/runtest @@ -151,6 +152,7 @@ unit:alpha: proto_alpha__lib_protocol__2: > @src/proto_alpha/lib_protocol/test/integration/michelson/runtest @src/proto_alpha/lib_protocol/test/integration/operations/runtest + @src/proto_alpha/lib_protocol/test/integration/validate/runtest proto_alpha__lib_protocol__3: > @src/proto_alpha/lib_protocol/test/pbt/runtest @src/proto_alpha/lib_protocol/test/unit/runtest diff --git a/docs/alpha/randomness_generation.rst b/docs/alpha/randomness_generation.rst index 090b263bc82b23410db163c748cad1f8c918e7b2..80f9f9ab37513bf2ee84edf108ce71d73841598b 100644 --- a/docs/alpha/randomness_generation.rst +++ b/docs/alpha/randomness_generation.rst @@ -148,13 +148,13 @@ Randomness generation parameters * - ``BLOCKS_PER_COMMITMENT`` - 64 blocks * - ``NONCE_REVELATION_THRESHOLD`` - - 32 blocks + - 256 blocks * - ``MAX_ANON_OPS_PER_BLOCK`` - 132 revelations * - ``SEED_NONCE_REVELATION_TIP`` - 1/8 ꜩ * - ``VDF_DIFFICULTY`` - - 1,000,000,000 + - 8,000,000,000 The variables ``BLOCKS_PER_CYCLE`` and ``PRESERVED_CYCLES`` are already defined in the :doc:`proof of stake ` page. diff --git a/docs/kathmandu/randomness_generation.rst b/docs/kathmandu/randomness_generation.rst index 3677e53d9aadeddb0f00787174cf1e0da7493399..4d686bbd521ef98bd01b33e6f4f8f93bc3341c21 100644 --- a/docs/kathmandu/randomness_generation.rst +++ b/docs/kathmandu/randomness_generation.rst @@ -36,10 +36,10 @@ is discarded, otherwise it is accepted. Once the revelation phase is finished, nonces are combined to generate the seed. More precisely, the nonces are hashed together in the same order as the commitment publication. In the case of a rolling RANDAO, the previous seed may -be used to initilialise the hash. +be used to initialize the hash. We make the assumption that at least one participant is honest, that is, it -has indeed chosen a random value and this values was revealed. This is a +has indeed chosen a random value and this value was revealed. This is a necessary condition for the seed to be random. The randomness could however be biased as this protocol suffers from the following low-impact weakness: if a malicious participant can make sure she is the last revealer, then she @@ -49,9 +49,9 @@ two different predetermined seeds. Verifiable Delay Function ^^^^^^^^^^^^^^^^^^^^^^^^^ -Verifiable Delay Functions, also called VDF, are a recent cryptographic -primitive formalised in 2018. They can be seen as a trapdoor-less timelock: -the goal of VDF is making sure a party cannot compute a value before a +Verifiable Delay Functions, also called VDFs, are a recent cryptographic +primitive formalized in 2018. They can be seen as a trapdoor-less timelock: +the goal of a VDF is making sure a party cannot compute a value before a specific time. This new cryptographic building block is based on modular squaring in a group @@ -59,13 +59,13 @@ of unknown order (e.g. class groups or MPC-generated RSA groups) that is believed to be expensive and hard to parallelize. More precisely, the goal of a VDF is for a user to compute a certain value -h = g^2^T mod N ∈ G and a proof of correctness π_h by recursive modular -squarings of h. The variables g, h and T are respectively called the challenge, -solution, and difficulfy parameter. The main difference between VDF and -timelocks is that the latter offers a backdoor to efficiently generate the -challenge from the solution. +``h = g^2^T mod N ∈ G`` and a proof of correctness ``π_h`` by recursive modular +squarings of ``h``. The variables ``g``, ``h``, ``T`` and ``N`` are respectively the *challenge*, +*solution* (or *output*), the *difficulty parameter* and the -unknown- *group order*. The main +difference between VDF and timelocks is that the latter offers a backdoor to +efficiently generate the challenge from the solution. -To this day, two main schemes exist for generating the VDF proofs: +To this day, two main schemes exist for generating VDF proofs: `Wesolowski `_ and `Pietrzak `_. The former presents shorter proofs and is based on a stronger security @@ -78,9 +78,10 @@ Protocol Randomness generation overview ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -The randomness generation can be summed up as follows. We first use RANDAO to +The randomness generation uses both RANDAO and VDF, based on class groups and +using Wesolowski proofs. It can be summed up as follows. We first use RANDAO to produce biasable entropy which is used as a VDF challenge to generate an -unbiasable seed (given the adversary cannot compute the VDF before the reveal +unbiasable seed (given the adversary cannot compute the VDF solution before the reveal time ends). To ensure liveness, we fallback to RANDAO entropy if no VDF output was published and verified on-chain. @@ -114,11 +115,20 @@ with transactions for block space. Up to ``MAX_ANON_OPS_PER_BLOCK`` revelations, wallet activations and denunciations can be contained in any given block. During the rest of the cycle, informally called the VDF revelation period, any -party can query the protocol for the *seed computation status* to compute the -VDF solution and publish it on-chain together with a proof of randomness. -If the verification of the solution and proof succeeds, the seed for cycle -``n`` is then updated with the solution: its value is set to be the hash of -the RANDAO output and the solution. +party can query the protocol for the *seed computation status*, which can be +one of the following:(1) the VDF revelation period has not yet started, i.e. +the nonce revelation phase is still ongoing, (2) a VDF solution has already +been successfully submitted, and (3) no VDF solution has been submitted. In +this latter case, the status also provides the information needed to compute +the VDF solution: hash seeds for computing the VDF discriminant (a prime +number defining the class group) and the VDF challenge; more precisely the +random seed of cycle ``n-1`` for the VDF discriminant and the current RANDAO +output for the VDF challenge. Any party can compute a VDF solution and publish +it on-chain together with a proof of correctness. If the verification of the +solution and proof succeeds, the seed for cycle ``n`` is then updated with the +solution: its value is set to be the hash of the RANDAO output and the VDF +solution. + A *VDF revelation* is an operation. A reward ``SEED_NONCE_REVELATION_TIP`` is given for the first correct VDF revelation, subsequent VDF revelation @@ -138,13 +148,13 @@ Randomness generation parameters * - ``BLOCKS_PER_COMMITMENT`` - 64 blocks * - ``NONCE_REVELATION_THRESHOLD`` - - 64 blocks + - 256 blocks * - ``MAX_ANON_OPS_PER_BLOCK`` - 132 revelations * - ``SEED_NONCE_REVELATION_TIP`` - 1/8 ꜩ * - ``VDF_DIFFICULTY`` - - 1,000,000,000 + - 8,000,000,000 The variables ``BLOCKS_PER_CYCLE`` and ``PRESERVED_CYCLES`` are already defined in the :doc:`proof of stake ` page. diff --git a/manifest/main.ml b/manifest/main.ml index da049abec0c208b65b2617af6e31d0cce5c0a369..305713807f8cf9521baf4596dae0a0820c908ef7 100644 --- a/manifest/main.ml +++ b/manifest/main.ml @@ -1469,23 +1469,6 @@ let octez_scoru_wasm = data_encoding; ] -let _octez_scoru_wasm_tests = - test - "test_scoru_wasm" - ~path:"src/lib_scoru_wasm/test" - ~opam:"tezos-scoru-wasm-test" - ~synopsis:"Tests for the scoru-wasm functionality" - ~deps: - [ - octez_base |> open_ ~m:"TzPervasives"; - octez_base_unix; - octez_base_test_helpers |> open_; - octez_test_helpers; - octez_scoru_wasm; - qcheck_alcotest; - alcotest_lwt; - ] - let octez_context_encoding = public_lib "tezos-context.encoding" @@ -1561,6 +1544,24 @@ let octez_context_disk = octez_context_dump; ] +let _octez_scoru_wasm_tests = + test + "test_scoru_wasm" + ~path:"src/lib_scoru_wasm/test" + ~opam:"tezos-scoru-wasm-test" + ~synopsis:"Tests for the scoru-wasm functionality" + ~deps: + [ + octez_base |> open_ ~m:"TzPervasives"; + octez_base_unix; + octez_context_disk; + octez_base_test_helpers |> open_; + octez_test_helpers; + octez_scoru_wasm; + qcheck_alcotest; + alcotest_lwt; + ] + let octez_context = public_lib "tezos-context" @@ -3256,11 +3257,11 @@ end = struct octez_base_test_helpers |> open_; ] in - let _integration_precheck = + let _integration_validate = only_if N.(number >= 014) @@ fun () -> - test - "main" - ~path:(path // "lib_protocol/test/integration/precheck") + tests + ["main"; "test_1m_restriction"] + ~path:(path // "lib_protocol/test/integration/validate") ~opam:(sf "tezos-protocol-%s-tests" name_dash) ~deps: [ @@ -3268,6 +3269,7 @@ end = struct octez_base |> open_ ~m:"TzPervasives" |> open_ ~m:"TzPervasives.Error_monad.Legacy_monad_globals"; main |> open_; + qcheck_alcotest; client |> if_some |> open_; test_helpers |> if_some |> open_; octez_base_test_helpers |> open_; diff --git a/opam/tezos-protocol-014-PtKathma-tests.opam b/opam/tezos-protocol-014-PtKathma-tests.opam index 5cf1b84e0072d4c836e0f6a0d01beee1c90a7591..133d4d2e28121cca63e5805da93aa432c9935b7d 100644 --- a/opam/tezos-protocol-014-PtKathma-tests.opam +++ b/opam/tezos-protocol-014-PtKathma-tests.opam @@ -20,10 +20,10 @@ depends: [ "tezos-micheline" {with-test} "tezos-benchmark-014-PtKathma" {with-test} "tezos-benchmark-type-inference-014-PtKathma" {with-test} + "qcheck-alcotest" { with-test & >= "0.18" } "tezos-context" {with-test} "tezos-test-helpers" {with-test} "alcotest" { with-test & >= "1.5.0" } - "qcheck-alcotest" { with-test & >= "0.18" } "tezos-client-base" {with-test} "tezos-protocol-environment" {with-test} "tezos-stdlib-unix" {with-test} diff --git a/opam/tezos-protocol-alpha-tests.opam b/opam/tezos-protocol-alpha-tests.opam index 576a888398053aa08acb41a7287863949685b815..495c0121aa9ada1a8212972639d5db2979b2037f 100644 --- a/opam/tezos-protocol-alpha-tests.opam +++ b/opam/tezos-protocol-alpha-tests.opam @@ -20,10 +20,10 @@ depends: [ "tezos-micheline" {with-test} "tezos-benchmark-alpha" {with-test} "tezos-benchmark-type-inference-alpha" {with-test} + "qcheck-alcotest" { with-test & >= "0.18" } "tezos-context" {with-test} "tezos-test-helpers" {with-test} "alcotest" { with-test & >= "1.5.0" } - "qcheck-alcotest" { with-test & >= "0.18" } "tezos-client-base" {with-test} "tezos-protocol-environment" {with-test} "tezos-stdlib-unix" {with-test} diff --git a/opam/tezos-scoru-wasm-test.opam b/opam/tezos-scoru-wasm-test.opam index d1443fc3be51111d4e7921bc7f590d93e18e45af..a886e2b478432e5f63eb7be3c4fbb605ce5b0eb9 100644 --- a/opam/tezos-scoru-wasm-test.opam +++ b/opam/tezos-scoru-wasm-test.opam @@ -10,6 +10,7 @@ license: "MIT" depends: [ "dune" { >= "3.0" } "tezos-base" {with-test} + "tezos-context" {with-test} "tezos-base-test-helpers" {with-test} "tezos-test-helpers" {with-test} "tezos-scoru-wasm" {with-test} diff --git a/src/lib_scoru_wasm/test/dune b/src/lib_scoru_wasm/test/dune index 55051e2c33ceaf650074d16cb2b38b87c5b471ce..eeadad2175c6d09be42ac7a566d45ee3ecc2d6a6 100644 --- a/src/lib_scoru_wasm/test/dune +++ b/src/lib_scoru_wasm/test/dune @@ -6,6 +6,7 @@ (libraries tezos-base tezos-base.unix + tezos-context.disk tezos-base-test-helpers tezos-test-helpers tezos-scoru-wasm diff --git a/src/lib_scoru_wasm/test/test_encoding.ml b/src/lib_scoru_wasm/test/test_encoding.ml new file mode 100644 index 0000000000000000000000000000000000000000..774d64c3cfe64c37742c02c036cc0372fb2dfaad --- /dev/null +++ b/src/lib_scoru_wasm/test/test_encoding.ml @@ -0,0 +1,225 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +(** Testing + ------- + Component: Tree_encoding_decoding + Invocation: dune exec src/lib_scoru_wasm/test/test_scoru_wasm.exe \ + -- test "$Encodings^" + Subject: Encoding tests for the tezos-scoru-wasm library +*) + +open Tztest +open Tezos_webassembly_interpreter +open Tezos_scoru_wasm + +(* Use context-binary for testing. *) +module Context = Tezos_context_memory.Context_binary + +module Tree : + Tezos_context_sigs.Context.TREE + with type t = Context.t + and type tree = Context.tree + and type key = string list + and type value = bytes = struct + type t = Context.t + + type tree = Context.tree + + type key = Context.key + + type value = Context.value + + include Context.Tree +end + +module Map = + Lazy_map.Make + (Lazy_map.Effect.Lwt) + (struct + type t = string + + let compare = String.compare + + let to_string x = x + end) + +module Vector = + Lazy_vector.Make + (Lazy_vector.Effect.Lwt) + (struct + type t = int + + let compare = compare + + let unsigned_compare = compare + + let zero = 0 + + let add = ( + ) + + let sub = ( - ) + + let pred x = x - 1 + + let succ x = x + 1 + + let to_string = string_of_int + end) + +module Encoding = Tree_encoding_decoding.Make (Map) (Vector) (Tree) + +let empty_tree () = + let open Lwt_syntax in + let* index = Context.init "/tmp" in + let empty_store = Context.empty index in + return @@ Context.Tree.empty empty_store + +let test_encode_decode enc value f = + let open Lwt_result_syntax in + let*! empty_tree = empty_tree () in + let*! tree = Encoding.encode enc value empty_tree in + let*! value' = Encoding.decode enc tree in + f value' + +let assert_round_trip enc value equal = + test_encode_decode enc value (fun value' -> + let open Lwt_result_syntax in + assert (equal value' value) ; + return_unit) + +let test_string () = + let enc = Encoding.value ["key"] Data_encoding.string in + assert_round_trip enc "Hello" String.equal + +let test_int () = + let enc = Encoding.value ["key"] Data_encoding.int32 in + assert_round_trip enc 42l Int32.equal + +let test_tree () = + let enc = + Encoding.tree ["foo"] @@ Encoding.value ["key"] Data_encoding.int32 + in + assert_round_trip enc 42l Int32.equal + +let test_raw () = + let enc = Encoding.raw ["key"] in + assert_round_trip enc (Bytes.of_string "CAFEBABE") Bytes.equal + +let test_conv () = + let open Encoding in + let enc = + conv int_of_string string_of_int (value ["key"] Data_encoding.string) + in + assert_round_trip enc 42 Int.equal + +type contact = + | Email of string + | Address of {street : string; number : int} + | No_address + +let test_tagged_union () = + let open Encoding in + let open Lwt_result_syntax in + let enc = + tagged_union + (value [] Data_encoding.string) + [ + case + "Email" + (value [] Data_encoding.string) + (function Email s -> Some s | _ -> None) + (fun s -> Email s); + case + "Address" + (tup2 + (value ["street"] Data_encoding.string) + (value ["number"] Data_encoding.int31)) + (function + | Address {street; number} -> Some (street, number) | _ -> None) + (fun (street, number) -> Address {street; number}); + case + "No Address" + (value [] Data_encoding.unit) + (function No_address -> Some () | _ -> None) + (fun () -> No_address); + ] + in + let* () = assert_round_trip enc No_address Stdlib.( = ) in + let* () = assert_round_trip enc (Email "foo@bar.com") Stdlib.( = ) in + let* () = + assert_round_trip + enc + (Address {street = "Main Street"; number = 10}) + Stdlib.( = ) + in + return_unit + +let test_lazy_mapping () = + let open Encoding in + let open Lwt_result_syntax in + let enc = lazy_mapping (value ["key"] Data_encoding.string) in + let map = Map.create ~produce_value:(fun key -> Lwt.return key) () in + (* Load the key [K1] from the map. *) + let*! value = Map.get "K1" map in + assert (value = "K1") ; + test_encode_decode enc map (fun decoded_map -> + (* Load the key [K1] from the decoded map. *) + let*! value = Map.get "K1" decoded_map in + assert (value = "K1") ; + assert (Map.to_string Fun.id map = Map.to_string Fun.id decoded_map) ; + return_unit) + +let test_lazy_vector () = + let open Encoding in + let open Lwt_result_syntax in + let enc = + lazy_vector (value [] Data_encoding.int31) (value [] Data_encoding.string) + in + let vector = + Vector.create ~produce_value:(fun key -> Lwt.return (string_of_int key)) 100 + in + (* Load the key [K1] from the vector . *) + let*! value = Vector.get 42 vector in + assert (value = "42") ; + test_encode_decode enc vector (fun decoded_vector -> + (* Load the key [42] from the decoded vector. *) + let*! value = Vector.get 42 decoded_vector in + assert (value = "42") ; + assert ( + Vector.to_string Fun.id vector = Vector.to_string Fun.id decoded_vector) ; + return_unit) + +let tests = + [ + tztest "String" `Quick test_string; + tztest "Int" `Quick test_int; + tztest "Tree" `Quick test_tree; + tztest "Raw" `Quick test_raw; + tztest "Convert" `Quick test_conv; + tztest "Tagged-union" `Quick test_tagged_union; + tztest "Lazy mapping" `Quick test_lazy_mapping; + tztest "Lazy vector" `Quick test_lazy_vector; + ] diff --git a/src/lib_scoru_wasm/test/test_input.ml b/src/lib_scoru_wasm/test/test_input.ml new file mode 100644 index 0000000000000000000000000000000000000000..2caa45ee6b2ca7fde9d0fd9c60f4820619d149d9 --- /dev/null +++ b/src/lib_scoru_wasm/test/test_input.ml @@ -0,0 +1,181 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +(** Testing + ------- + Component: Lib_scoru_wasm input + Invocation: dune exec src/lib_scoru_wasm/test/test_scoru_wasm.exe \ + -- test "$Encodings^" + Subject: Input tests for the tezos-scoru-wasm library +*) + +open Tztest +open Tezos_webassembly_interpreter +open Tezos_scoru_wasm + +let write_input () = + let open Lwt.Syntax in + let input = Input_buffer.alloc () in + let* () = + Input_buffer.enqueue + input + { + rtype = 1l; + raw_level = 2l; + message_counter = Z.of_int 2; + payload = Bytes.of_string "hello"; + } + in + let* () = + Input_buffer.enqueue + input + { + rtype = 1l; + raw_level = 2l; + message_counter = Z.of_int 3; + payload = Bytes.of_string "hello"; + } + in + assert (Input_buffer.num_elements input = Z.of_int 2) ; + let* () = + Lwt.try_bind + (fun () -> + Input_buffer.enqueue + input + { + rtype = 1l; + raw_level = 2l; + message_counter = Z.of_int 2; + payload = Bytes.of_string "hello"; + }) + (fun _ -> assert false) + (function + | Input_buffer.Cannot_store_an_earlier_message -> Lwt.return () + | _ -> assert false) + in + Lwt.return Result.return_unit + +let read_input () = + let open Lwt.Syntax in + let lim = Types.(MemoryType {min = 100l; max = Some 1000l}) in + let memory = Memory.alloc lim in + let input_buffer = Input_buffer.alloc () in + let* () = + Input_buffer.enqueue + input_buffer + { + rtype = 1l; + raw_level = 2l; + message_counter = Z.of_int 2; + payload = Bytes.of_string "hello"; + } + in + assert (Input_buffer.num_elements input_buffer = Z.one) ; + let module_inst = + ref Tezos_webassembly_interpreter.Instance.empty_module_inst + in + let memories = + Tezos_webassembly_interpreter.Instance.Vector.cons + memory + !module_inst.memories + in + module_inst := {!module_inst with memories} ; + let* result = + Host_funcs.Internal_for_tests.aux_write_input_in_memory + ~input_buffer + ~module_inst + ~rtype_offset:0L + ~level_offset:4L + ~id_offset:10L + ~dst:50L + ~max_bytes:36000L + in + let* memory = + Tezos_webassembly_interpreter.Instance.Vector.get 0l !module_inst.memories + in + assert (Input_buffer.num_elements input_buffer = Z.zero) ; + assert (result = 5) ; + let* m = Memory.load_bytes memory 0L 1 in + assert (m = "\001") ; + let* m = Memory.load_bytes memory 4L 1 in + assert (m = "\002") ; + let* m = Memory.load_bytes memory 10L 1 in + assert (m = "\002") ; + let* m = Memory.load_bytes memory 50L 5 in + assert (m = "hello") ; + Lwt.return @@ Result.return_unit + +let test_host_fun () = + let open Lwt.Syntax in + let input = Input_buffer.alloc () in + let* () = + Input_buffer.enqueue + input + { + rtype = 1l; + raw_level = 2l; + message_counter = Z.of_int 2; + payload = Bytes.of_string "hello"; + } + in + let module_inst = Tezos_webassembly_interpreter.Instance.empty_module_inst in + let memories = + Tezos_webassembly_interpreter.Lazy_vector.LwtInt32Vector.cons + (Memory.alloc (MemoryType Types.{min = 20l; max = Some 3600l})) + module_inst.memories + in + let module_inst = {module_inst with memories} in + let values = + Values. + [ + Num (I64 0L); Num (I64 4L); Num (I64 10L); Num (I64 50L); Num (I64 3600L); + ] + in + let* module_inst, result = + Eval.invoke ~module_inst ~input Host_funcs.read_input values + in + let* memory = + Tezos_webassembly_interpreter.Lazy_vector.LwtInt32Vector.get + 0l + module_inst.memories + in + assert (Input_buffer.num_elements input = Z.zero) ; + let* m = Memory.load_bytes memory 0L 1 in + assert (m = "\001") ; + let* m = Memory.load_bytes memory 4L 1 in + assert (m = "\002") ; + let* m = Memory.load_bytes memory 10L 1 in + assert (m = "\002") ; + let* m = Memory.load_bytes memory 50L 5 in + assert (m = "hello") ; + assert (result = Values.[Num (I32 5l)]) ; + Lwt.return @@ Result.return_unit + +let tests = + [ + tztest "Write input" `Quick write_input; + tztest "Read input" `Quick read_input; + tztest "Host read input" `Quick test_host_fun; + ] diff --git a/src/lib_scoru_wasm/test/test_scoru_wasm.ml b/src/lib_scoru_wasm/test/test_scoru_wasm.ml index 48987a58a0e3951e4786bcf54dcc12c50dc95bd7..8bf3777c38093c7c2e902b1c107e2318ba4840d6 100644 --- a/src/lib_scoru_wasm/test/test_scoru_wasm.ml +++ b/src/lib_scoru_wasm/test/test_scoru_wasm.ml @@ -1,151 +1,37 @@ -open Tztest -open Tezos_webassembly_interpreter -open Tezos_scoru_wasm +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) -let write_input () = - let open Lwt.Syntax in - let input = Input_buffer.alloc () in - let* () = - Input_buffer.enqueue - input - { - rtype = 1l; - raw_level = 2l; - message_counter = Z.of_int 2; - payload = Bytes.of_string "hello"; - } - in - let* () = - Input_buffer.enqueue - input - { - rtype = 1l; - raw_level = 2l; - message_counter = Z.of_int 3; - payload = Bytes.of_string "hello"; - } - in - assert (Input_buffer.num_elements input = Z.of_int 2) ; - let* () = - Lwt.try_bind - (fun () -> - Input_buffer.enqueue - input - { - rtype = 1l; - raw_level = 2l; - message_counter = Z.of_int 2; - payload = Bytes.of_string "hello"; - }) - (fun _ -> assert false) - (function - | Input_buffer.Cannot_store_an_earlier_message -> Lwt.return () - | _ -> assert false) - in - Lwt.return @@ Result.return_unit - -let read_input () = - let open Lwt.Syntax in - let lim = Types.(MemoryType {min = 100l; max = Some 1000l}) in - let memory = Memory.alloc lim in - let input_buffer = Input_buffer.alloc () in - let* () = - Input_buffer.enqueue - input_buffer - { - rtype = 1l; - raw_level = 2l; - message_counter = Z.of_int 2; - payload = Bytes.of_string "hello"; - } - in - assert (Input_buffer.num_elements input_buffer = Z.one) ; - let module_inst = - ref Tezos_webassembly_interpreter.Instance.empty_module_inst - in - let memories = - Tezos_webassembly_interpreter.Instance.Vector.cons - memory - !module_inst.memories - in - module_inst := {!module_inst with memories} ; - let* result = - Host_funcs.Internal_for_tests.aux_write_input_in_memory - ~input_buffer - ~module_inst - ~rtype_offset:0L - ~level_offset:4L - ~id_offset:10L - ~dst:50L - ~max_bytes:36000L - in - let* memory = - Tezos_webassembly_interpreter.Instance.Vector.get 0l !module_inst.memories - in - assert (Input_buffer.num_elements input_buffer = Z.zero) ; - assert (result = 5) ; - let* m = Memory.load_bytes memory 0L 1 in - assert (m = "\001") ; - let* m = Memory.load_bytes memory 4L 1 in - assert (m = "\002") ; - let* m = Memory.load_bytes memory 10L 1 in - assert (m = "\002") ; - let* m = Memory.load_bytes memory 50L 5 in - assert (m = "hello") ; - Lwt.return @@ Result.return_unit - -let test_host_fun () = - let open Lwt.Syntax in - let input = Input_buffer.alloc () in - let* () = - Input_buffer.enqueue - input - { - rtype = 1l; - raw_level = 2l; - message_counter = Z.of_int 2; - payload = Bytes.of_string "hello"; - } - in - let module_inst = Tezos_webassembly_interpreter.Instance.empty_module_inst in - let memories = - Tezos_webassembly_interpreter.Lazy_vector.LwtInt32Vector.cons - (Memory.alloc (MemoryType Types.{min = 20l; max = Some 3600l})) - module_inst.memories - in - let module_inst = {module_inst with memories} in - let values = - Values. - [ - Num (I64 0L); Num (I64 4L); Num (I64 10L); Num (I64 50L); Num (I64 3600L); - ] - in - let* module_inst, result = - Eval.invoke ~module_inst ~input Host_funcs.read_input values - in - let* memory = - Tezos_webassembly_interpreter.Lazy_vector.LwtInt32Vector.get - 0l - module_inst.memories - in - assert (Input_buffer.num_elements input = Z.zero) ; - let* m = Memory.load_bytes memory 0L 1 in - assert (m = "\001") ; - let* m = Memory.load_bytes memory 4L 1 in - assert (m = "\002") ; - let* m = Memory.load_bytes memory 10L 1 in - assert (m = "\002") ; - let* m = Memory.load_bytes memory 50L 5 in - assert (m = "hello") ; - assert (result = Values.[Num (I32 5l)]) ; - Lwt.return @@ Result.return_unit - -let tests = - [ - tztest "write_input" `Quick write_input; - tztest "read_input" `Quick read_input; - tztest "Host_read_input" `Quick test_host_fun; - ] +(** Testing + ------- + Component: Lib_scoru_wasm + Invocation: dune runtest src/lib_scoru_wasm/ + Subject: Testing for the tezos-scoru-wasm library +*) let () = - Alcotest_lwt.run "Testing the read_input" [("unit", tests)] |> Lwt_main.run + Alcotest_lwt.run + "test lib scoru wasm" + [("Input", Test_input.tests); ("Encodings", Test_encoding.tests)] + |> Lwt_main.run diff --git a/src/lib_scoru_wasm/tree_decoding.ml b/src/lib_scoru_wasm/tree_decoding.ml index 3ae34d735bada96677725e0b4ee2535b9c927f10..2d320bc98ceb03942f0eda8e25b4ea33bc91e0b5 100644 --- a/src/lib_scoru_wasm/tree_decoding.ml +++ b/src/lib_scoru_wasm/tree_decoding.ml @@ -27,6 +27,8 @@ type key = string list exception Key_not_found of key +exception No_tag_matched + exception Decode_error of {key : key; error : Data_encoding.Binary.read_error} module type S = sig @@ -34,6 +36,8 @@ module type S = sig type 'a t + type ('tag, 'a) case + val run : 'a t -> tree -> 'a Lwt.t val raw : key -> bytes t @@ -46,6 +50,14 @@ module type S = sig val of_lwt : 'a Lwt.t -> 'a t + val map : ('a -> 'b) -> 'a t -> 'b t + + val map_lwt : ('a -> 'b Lwt.t) -> 'a t -> 'b t + + val case : 'tag -> 'b t -> ('b -> 'a) -> ('tag, 'a) case + + val tagged_union : 'tag t -> ('tag, 'a) case list -> 'a t + module Syntax : sig val return : 'a -> 'a t @@ -82,8 +94,15 @@ module Make (T : Tree.S) : S with type tree = T.tree = struct type 'a t = Tree.tree -> prefix_key -> 'a Lwt.t + type ('tag, 'a) case = + | Case : {tag : 'tag; extract : 'b -> 'a; decode : 'b t} -> ('tag, 'a) case + let of_lwt lwt _tree _prefix = lwt + let map f dec tree prefix = Lwt.map f (dec tree prefix) + + let map_lwt f dec tree prefix = Lwt.bind (dec tree prefix) f + module Syntax = struct let return value _tree _prefix = Lwt.return value @@ -92,7 +111,7 @@ module Make (T : Tree.S) : S with type tree = T.tree = struct let both lhs rhs tree prefix = Lwt.both (lhs tree prefix) (rhs tree prefix) - let ( let+ ) dec f tree prefix = Lwt.map f (dec tree prefix) + let ( let+ ) m f = map f m let ( and+ ) = both @@ -127,4 +146,17 @@ module Make (T : Tree.S) : S with type tree = T.tree = struct tree (to_key index) field_enc input_tree input_prefix in Lwt.return produce_value + + let case tag decode extract = Case {tag; decode; extract} + + let tagged_union decode_tag cases input_tree prefix = + let open Lwt_syntax in + let* target_tag = tree ["tag"] decode_tag input_tree prefix in + (* Search through the cases to find a matching branch. *) + cases + |> List.find_map (fun (Case {tag; decode; extract}) -> + if tag = target_tag then + Some (map extract (tree ["value"] decode) input_tree prefix) + else None) + |> Option.value_f ~default:(fun _ -> raise No_tag_matched) end diff --git a/src/lib_scoru_wasm/tree_decoding.mli b/src/lib_scoru_wasm/tree_decoding.mli index 7a6c55693d578ca69067f6447d9e18e780882676..0e9993e5b0624e0a56da82e7b8558e5dee186d74 100644 --- a/src/lib_scoru_wasm/tree_decoding.mli +++ b/src/lib_scoru_wasm/tree_decoding.mli @@ -28,6 +28,10 @@ type key = string list (** Raised when a requested key is not present. *) exception Key_not_found of key +(** Raised when an encoder produced by [tagged_union] does not contain a + matching branch. *) +exception No_tag_matched + (** Raised when data-encoding fails to decode a certain value. *) exception Decode_error of {key : key; error : Data_encoding.Binary.read_error} @@ -37,7 +41,11 @@ module type S = sig (** Tree decoder type *) type 'a t - (** [run decoder tree] runs the tree decoder against the tree. *) + (** Represents a partial encoder for a specific constructor of a sum-type. *) + type ('tag, 'a) case + + (** [run decoder tree] runs the tree decoder against the tree. May raise a + [Key_not_found] or a [No_tag_matched] exception. *) val run : 'a t -> tree -> 'a Lwt.t (** [raw key] retrieves the raw value at the given [key]. @@ -73,6 +81,29 @@ module type S = sig (** [of_lwt p] lifts the promise [p] into a decoding value. *) val of_lwt : 'a Lwt.t -> 'a t + (** [map f d] maps over the result of the decoder [d] with function [f]. *) + val map : ('a -> 'b) -> 'a t -> 'b t + + (** [map_lwt f d] maps over the result of the decoder [d] with the effectful + function [f]. *) + val map_lwt : ('a -> 'b Lwt.t) -> 'a t -> 'b t + + (** [case tag dec f] return a a partial decoder that represents a case in a + variant type. The decoder hides the (existentially bound) type of the + parameter to the specific case, provided a converter function [f] and + base decoder [dec]. *) + val case : 'tag -> 'b t -> ('b -> 'a) -> ('tag, 'a) case + + (** [tagged_union tag_dec cases] returns a decoder that use [tag_dec] for + decoding the value of a field [tag]. The decoder searches through the list + of cases for a matching branch. When a matching branch is found, it uses + its embedded decoder for the value. This function is used for constructing + decoders for sum-types. + + If an insufficient list of cases are provided, the resulting encoder may + fail with a [No_tag_matched] error when [run]. *) + val tagged_union : 'tag t -> ('tag, 'a) case list -> 'a t + (** Syntax module for the {!Tree_decoding}. This is intended to be opened locally in functions. Within the scope of this module, the code can include binding operators, leading to a [let]-style syntax. Similar to diff --git a/src/lib_scoru_wasm/tree_encoding.ml b/src/lib_scoru_wasm/tree_encoding.ml new file mode 100644 index 0000000000000000000000000000000000000000..860a594f31083ac03d26e0f3279f733bfe5a4956 --- /dev/null +++ b/src/lib_scoru_wasm/tree_encoding.ml @@ -0,0 +1,139 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2022 TriliTech *) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +type key = string list + +exception No_tag_matched + +module type S = sig + type tree + + type -'a t + + val contramap : ('a -> 'b) -> 'b t -> 'a t + + val contramap_lwt : ('a -> 'b Lwt.t) -> 'b t -> 'a t + + val run : 'a t -> 'a -> tree -> tree Lwt.t + + val raw : key -> bytes t + + val value : key -> 'a Data_encoding.t -> 'a t + + val tree : key -> 'a t -> 'a t + + val lazy_mapping : ('k -> key) -> 'v t -> ('k * 'v) list t + + type ('tag, 'a) case + + val case : 'tag -> 'b t -> ('a -> 'b option) -> ('tag, 'a) case + + val tagged_union : 'tag t -> ('tag, 'a) case list -> 'a t + + val lwt : 'a t -> 'a Lwt.t t + + val tup2 : 'a t -> 'b t -> ('a * 'b) t + + val tup3 : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t +end + +module Make (T : Tree.S) = struct + (** [append_key prefix key] append [key] to [prefix] in order to create a new + [prefix_key]. *) + let append_key prefix key tail = prefix (List.append key tail) + + type tree = T.tree + + (** Given the tail key, construct a full key. *) + type prefix_key = key -> key + + type -'a t = 'a -> prefix_key -> tree -> tree Lwt.t + + let run enc value tree = enc value Fun.id tree + + let lwt enc value prefix tree = + let open Lwt_syntax in + let* v = value in + enc v prefix tree + + let contramap f enc value = enc (f value) + + let contramap_lwt f enc value prefix tree = + let open Lwt_syntax in + let* v = f value in + enc v prefix tree + + let tup2 lhs rhs (l, r) prefix tree = + let open Lwt.Syntax in + let* tree = lhs l prefix tree in + rhs r prefix tree + + let tup3 encode_a encode_b encode_c (a, b, c) prefix tree = + let open Lwt.Syntax in + let* tree = encode_a a prefix tree in + let* tree = encode_b b prefix tree in + encode_c c prefix tree + + let raw suffix bytes prefix tree = T.add tree (prefix suffix) bytes + + let value suffix enc = + contramap (Data_encoding.Binary.to_bytes_exn enc) (raw suffix) + + let tree key enc value prefix tree = enc value (append_key prefix key) tree + + let lazy_mapping to_key enc_value bindings prefix tree = + List.fold_left_s + (fun tree (k, v) -> + let key = append_key prefix (to_key k) in + enc_value v key tree) + tree + bindings + + type ('tag, 'a) case = + | Case : { + tag : 'tag; + probe : 'a -> 'b option; + encode : 'b t; + } + -> ('tag, 'a) case + + let case tag encode probe = Case {tag; encode; probe} + + let tagged_union encode_tag cases value prefix target_tree = + let open Lwt_syntax in + let encode_tag = tree ["tag"] encode_tag in + let match_case (Case {probe; tag; encode}) = + match probe value with + | Some value -> + let* target_tree = encode_tag tag prefix target_tree in + let* x = tree ["value"] encode value prefix target_tree in + return (Some x) + | None -> return None + in + let* tree_opt = List.find_map_s match_case cases in + match tree_opt with + | None -> raise No_tag_matched + | Some tree -> return tree +end diff --git a/src/lib_scoru_wasm/tree_encoding.mli b/src/lib_scoru_wasm/tree_encoding.mli new file mode 100644 index 0000000000000000000000000000000000000000..d6c1348014084349813bca7120345c44ca9af4f6 --- /dev/null +++ b/src/lib_scoru_wasm/tree_encoding.mli @@ -0,0 +1,98 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2022 TriliTech *) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +type key = string list + +(** Raised when an encoder produced by [tagged_union] does not contain a + matching branch. *) +exception No_tag_matched + +module type S = sig + type tree + + (** Tree encoder type. *) + type -'a t + + (** Represents a partial encoder for specific constructor of a sum-type. *) + type ('tag, 'a) case + + (** [contramap f e] is contravariant map operation that creates a new decoder + that maps its input using [f] before feeding it to [e]. *) + val contramap : ('a -> 'b) -> 'b t -> 'a t + + (** [contramap_lwt f e]. Same as [contramap] except that [f] als produces + an Lwt effect. *) + val contramap_lwt : ('a -> 'b Lwt.t) -> 'b t -> 'a t + + (** [run enc x tree] encodes the given value [x] using the encoder [enc] and + writes it to the tree [tree]. May raise a [Key_not_found] or a + [No_tag_matched] exception. *) + val run : 'a t -> 'a -> tree -> tree Lwt.t + + (** [raw key] returns an encoder that encodes raw bytes at the given key. *) + val raw : key -> bytes t + + (** [value key enc] encodes the value at a given [key] using the provided + [enc] encoder for the value. *) + val value : key -> 'a Data_encoding.t -> 'a t + + (** [tree key enc] applies a tree encoder for a provided [key]. *) + val tree : key -> 'a t -> 'a t + + (** [lazy_mapping to_key enc] returns a key-value list encoder that + encodes values from a given key-value list using the key-mapping function + [to_key] and the provided encoder [enc] for the values. *) + val lazy_mapping : ('k -> key) -> 'v t -> ('k * 'v) list t + + (** [case tag enc f] return a partial encoder that represents a case in a + sum-type. The encoder hides the (existentially bound) type of the + parameter to the specific case, provided a converter function [f] and + base encoder [enc]. *) + val case : 'tag -> 'b t -> ('a -> 'b option) -> ('tag, 'a) case + + (** [tagged_union tag_enc cases] returns an encoder that uses [tag_enc] for + encoding the value of a field [tag]. The encoder searches through the list + of cases for a matching branch. When a matching branch is found, it + applies its embedded encoder for the value. This function is used for + constructing encoders for sum-types. + + If an insufficient list of cases are provided, the resulting encoder may + fail with a [No_tag_matched] error when [run]. *) + val tagged_union : 'tag t -> ('tag, 'a) case list -> 'a t + + (** [lwt enc] promotes the given encoder [enc] to one that can handle lwt + values. *) + val lwt : 'a t -> 'a Lwt.t t + + (** [tup2 e1 e2] creates an encoder that encodes a tuple of elements using + [e1] and [e2]. *) + val tup2 : 'a t -> 'b t -> ('a * 'b) t + + (** [tup3 e1 e2] creates an encoder that encodes a triple of elements using + [e1], [e2], and [e3]. *) + val tup3 : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t +end + +module Make : functor (T : Tree.S) -> S with type tree = T.tree diff --git a/src/lib_scoru_wasm/tree_encoding_decoding.ml b/src/lib_scoru_wasm/tree_encoding_decoding.ml new file mode 100644 index 0000000000000000000000000000000000000000..658638f3655177d3c28118350b61de62639cdfbb --- /dev/null +++ b/src/lib_scoru_wasm/tree_encoding_decoding.ml @@ -0,0 +1,191 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2022 TriliTech *) +(* *) +(* 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 Tezos_webassembly_interpreter + +type key = string list + +module type S = sig + type tree + + type 'a map + + type vector_key + + type 'a vector + + type ('tag, 'a) case + + module Decoding : Tree_decoding.S with type tree = tree + + module Encoding : Tree_encoding.S with type tree = tree + + type 'a t + + val encode : 'a t -> 'a -> tree -> tree Lwt.t + + val decode : 'a t -> tree -> 'a Lwt.t + + val custom : 'a Encoding.t -> 'a Decoding.t -> 'a t + + val conv : ('a -> 'b) -> ('b -> 'a) -> 'a t -> 'b t + + val conv_lwt : ('a -> 'b Lwt.t) -> ('b -> 'a Lwt.t) -> 'a t -> 'b t + + val tup2 : 'a t -> 'b t -> ('a * 'b) t + + val tup3 : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t + + val raw : key -> bytes t + + val value : key -> 'a Data_encoding.t -> 'a t + + val tree : key -> 'a t -> 'a t + + val lazy_mapping : 'a t -> 'a map t + + val lazy_vector : vector_key t -> 'a t -> 'a vector t + + val case : 'tag -> 'b t -> ('a -> 'b option) -> ('b -> 'a) -> ('tag, 'a) case + + val tagged_union : 'tag t -> ('tag, 'a) case list -> 'a t +end + +module Make + (M : Lazy_map.S with type 'a effect = 'a Lwt.t) + (V : Lazy_vector.S with type 'a effect = 'a Lwt.t) + (T : Tree.S) : + S + with type tree = T.tree + and type 'a map = 'a M.t + and type vector_key = V.key + and type 'a vector = 'a V.t = struct + module Encoding = Tree_encoding.Make (T) + module Decoding = Tree_decoding.Make (T) + module E = Encoding + module D = Decoding + + type tree = T.tree + + type vector_key = V.key + + type 'a vector = 'a V.t + + type 'a map = 'a M.t + + type 'a encoding = 'a E.t + + type 'a decoding = 'a D.t + + type 'a t = {encode : 'a encoding; decode : 'a decoding} + + let custom encode decode = {encode; decode} + + let conv d e {encode; decode} = + {encode = E.contramap e encode; decode = D.map d decode} + + let conv_lwt d e {encode; decode} = + {encode = E.contramap_lwt e encode; decode = D.map_lwt d decode} + + let tup2 lhs rhs = + { + encode = E.tup2 lhs.encode rhs.encode; + decode = D.Syntax.both lhs.decode rhs.decode; + } + + let tup3 one two three = + conv + (fun (a, (b, c)) -> (a, b, c)) + (fun (a, b, c) -> (a, (b, c))) + (tup2 one (tup2 two three)) + + let encode {encode; _} value tree = E.run encode value tree + + let decode {decode; _} tree = D.run decode tree + + let raw key = {encode = E.raw key; decode = D.raw key} + + let value key de = {encode = E.value key de; decode = D.value key de} + + let tree key {encode; decode} = + {encode = E.tree key encode; decode = D.tree key decode} + + let lazy_mapping value = + let to_key k = [M.string_of_key k] in + let encode = + E.contramap M.loaded_bindings (E.lazy_mapping to_key value.encode) + in + let decode = + D.map + (fun produce_value -> M.create ~produce_value ()) + (D.lazy_mapping to_key value.decode) + in + {encode; decode} + + let lazy_vector with_key value = + let to_key k = [V.string_of_key k] in + let encode = + E.contramap + (fun vector -> + (V.loaded_bindings vector, V.num_elements vector, V.first_key vector)) + (E.tup3 + (E.lazy_mapping to_key value.encode) + (E.tree ["length"] with_key.encode) + (E.tree ["head"] with_key.encode)) + in + let decode = + D.map + (fun (produce_value, len, head) -> + V.create ~produce_value ~first_key:head len) + (let open D.Syntax in + let+ x = D.lazy_mapping to_key value.decode + and+ y = D.tree ["length"] with_key.decode + and+ z = D.tree ["head"] with_key.decode in + (x, y, z)) + in + {encode; decode} + + type ('tag, 'a) case = + | Case : { + tag : 'tag; + probe : 'a -> 'b option; + extract : 'b -> 'a; + delegate : 'b t; + } + -> ('tag, 'a) case + + let case tag delegate probe extract = Case {tag; delegate; probe; extract} + + let tagged_union {encode; decode} cases = + let to_encode_case (Case {tag; delegate; probe; extract = _}) = + E.case tag delegate.encode probe + in + let to_decode_case (Case {tag; delegate; extract; probe = _}) = + D.case tag delegate.decode extract + in + let encode = E.tagged_union encode (List.map to_encode_case cases) in + let decode = D.tagged_union decode (List.map to_decode_case cases) in + {encode; decode} +end diff --git a/src/lib_scoru_wasm/tree_encoding_decoding.mli b/src/lib_scoru_wasm/tree_encoding_decoding.mli new file mode 100644 index 0000000000000000000000000000000000000000..1127e97e04250492324508a3f4f6d9cd8ec7c6d0 --- /dev/null +++ b/src/lib_scoru_wasm/tree_encoding_decoding.mli @@ -0,0 +1,131 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2022 TriliTech *) +(* *) +(* 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 Tezos_webassembly_interpreter + +(** A key in the tree is a list of string. *) +type key = string trace + +module type S = sig + (** {1 Types}*) + + (** The underlying tree type. *) + type tree + + (** The map structure used. *) + type 'a map + + (** The type of vector keys. *) + type vector_key + + (** The vector structure used. *) + type 'a vector + + (** Represents a partial encoder for a specific constructor of a sum-type. *) + type ('tag, 'a) case + + (** Represents an encoder and a decoder. *) + type 'a t + + (** A decoding module with the same tree type. *) + module Decoding : Tree_decoding.S with type tree = tree + + (** An encoding module with the same tree type. *) + module Encoding : Tree_encoding.S with type tree = tree + + (** {2 Function}*) + + (** [encode enc x tree] encodes a value x using the encoder [enc] into the + provided [tree]. *) + val encode : 'a t -> 'a -> tree -> tree Lwt.t + + (** [decode enc x tree] decodes a value using the encoder [enc] from the + provided [tree]. *) + val decode : 'a t -> tree -> 'a Lwt.t + + (** [custom enc dec] creates a custom encoder that uses [enc] and [dec]. It's + the users responsibility to provide matching encoder and decoder values. + **) + val custom : 'a Encoding.t -> 'a Decoding.t -> 'a t + + (** [conv f g enc] transforms from one encoding to a different one using + [f] for mapping the results decoded using [enc], and [g] for mapping from + the input. *) + val conv : ('a -> 'b) -> ('b -> 'a) -> 'a t -> 'b t + + (** [conv_lwt f g enc] is the same as [conv] but where [f] and [g] are + effectful (produce lwt promises). *) + val conv_lwt : ('a -> 'b Lwt.t) -> ('b -> 'a Lwt.t) -> 'a t -> 'b t + + (** [tup2 e1 e2] combines [e1] and [e2] into an encoder for pairs. *) + val tup2 : 'a t -> 'b t -> ('a * 'b) t + + (** [tup3 e1 e2 e3] combines [e1], [e2], and [e3] into an encoder for + triples. *) + val tup3 : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t + + (** [raw key] is an encoder for bytes under the given [key]. *) + val raw : key -> bytes t + + (** [value key enc] creates an encoder under the given [key] using the + provided data-encoding [enc] for encoding/decoding values. *) + val value : key -> 'a Data_encoding.t -> 'a t + + (** [tree key enc] applies a tree encoder for a provided [key]. *) + val tree : key -> 'a t -> 'a t + + (** [lazy_mapping enc] produces an encoder for [map]s that uses the given + [enc] for encoding values. *) + val lazy_mapping : 'a t -> 'a map t + + (** [lazy_vector enc] produces an encoder for [vector]s that uses the given + [enc] for encoding values. *) + val lazy_vector : vector_key t -> 'a t -> 'a vector t + + (** [case tag enc f] return a a partial encoder that represents a case in a + sum-type. The encoder hides the (existentially bound) type of the + parameter to the specific case, provided a converter function [f] and + base encoder [enc]. *) + val case : 'tag -> 'b t -> ('a -> 'b option) -> ('b -> 'a) -> ('tag, 'a) case + + (** [tagged_union tag_enc cases] returns an encoder that use [tag_enc] for + encoding the value of a field [tag]. The encoder searches through the list + of cases for a matching branch. When a matching branch is found, it uses + its embedded encoder for the value. This function is used for constructing + encoders for sum-types. *) + val tagged_union : 'tag t -> ('tag, 'a) case list -> 'a t +end + +(** Produces an encoder/decoder module with the provided map, vector and tree + structures. *) +module Make + (M : Lazy_map.S with type 'a effect = 'a Lwt.t) + (V : Lazy_vector.S with type 'a effect = 'a Lwt.t) + (T : Tree.S) : + S + with type tree = T.tree + and type 'a map = 'a M.t + and type vector_key = V.key + and type 'a vector = 'a V.t diff --git a/src/lib_scoru_wasm/wasm_decodings.ml b/src/lib_scoru_wasm/wasm_decodings.ml index f97f629442711a15aeb5b0aec132687a2ca96628..f9a811d5762889c8044cd72b3ac812193185dc79 100644 --- a/src/lib_scoru_wasm/wasm_decodings.ml +++ b/src/lib_scoru_wasm/wasm_decodings.ml @@ -38,6 +38,8 @@ module type S = sig val module_instance_decoding : module_inst Vector.t -> module_inst t val module_instances_decoding : module_inst Vector.t t + + val eval_config_decoding : Eval.config t end module Make (T : Tree.S) = struct @@ -568,4 +570,59 @@ module Make (T : Tree.S) = struct [self_modules -> get_module_inst -> modules -> self -> self_modules]. *) (self := fun () -> self_modules) ; modules + + let frame_decoding modules = + let open Syntax in + let* inst = module_instance_decoding modules in + let* locals = + lazy_vector_decoding + "locals" + (map (fun x -> ref x) (value_decoding modules)) + in + let* locals = of_lwt @@ Vector.to_list locals in + return Eval.{inst; locals} + + let input_message_decoding = + let open Syntax in + let* rtype = value ["rtype"] Data_encoding.int32 in + let* raw_level = value ["raw_level"] Data_encoding.int32 in + let* message_counter = value ["message_counter"] Data_encoding.z in + let* payload = value ["payload"] (Data_encoding.Bounded.bytes 4_096) in + return Input_buffer.{rtype; raw_level; message_counter; payload} + + let input_decoding = + let open Syntax in + let to_input_buffer vec = + Lwt.Syntax.( + let buffer = Input_buffer.alloc () in + let rec add_messages = function + | [] -> Lwt.return buffer + | x :: xs -> + let* _ = Input_buffer.enqueue buffer x in + add_messages xs + in + let* messages = Vector.to_list vec in + add_messages messages) + in + let* message_stack = lazy_vector_decoding "input" input_message_decoding in + of_lwt @@ to_input_buffer message_stack + + let admin_instructions_decoding = Syntax.(return @@ Vector.of_list []) + + let code_decoding modules = + let open Syntax in + let* values = lazy_vector_decoding "value_stack" (value_decoding modules) in + let* admin_instr = admin_instructions_decoding in + let* values = of_lwt @@ Vector.to_list values in + let* admin_instr = of_lwt @@ Vector.to_list admin_instr in + return (values, admin_instr) + + let eval_config_decoding = + let open Syntax in + let* modules = module_instances_decoding in + let* frame = frame_decoding modules in + let* input = input_decoding in + let* code = code_decoding modules in + let* budget = map Int32.to_int (value ["budget"] Data_encoding.int32) in + return Eval.{frame; input; code; budget} end diff --git a/src/lib_scoru_wasm/wasm_decodings.mli b/src/lib_scoru_wasm/wasm_decodings.mli index b5c24441631addd8bf722872f053d894a8f1a23b..dd8235a0c63d533beb0735c0ede3001c2f53fff1 100644 --- a/src/lib_scoru_wasm/wasm_decodings.mli +++ b/src/lib_scoru_wasm/wasm_decodings.mli @@ -42,6 +42,10 @@ module type S = sig (** [module_instances_decoding] decodes module instances. *) val module_instances_decoding : module_inst Vector.t t + + (** [eval_config_decoding] decodes the evaluation configuration, the execution + state of the WASM PVM. *) + val eval_config_decoding : Tezos_webassembly_interpreter.Eval.config t end (** Creates a WASM decoding module given a {!Tree.S} implementation. *) diff --git a/src/lib_scoru_wasm/wasm_pvm.ml b/src/lib_scoru_wasm/wasm_pvm.ml index f0ef2ead0084be1ec38f031d99b6141c4a82732a..ff7c2dacdada51c8c8afa3c0f3a7d1d92c9d3a04 100644 --- a/src/lib_scoru_wasm/wasm_pvm.ml +++ b/src/lib_scoru_wasm/wasm_pvm.ml @@ -62,5 +62,7 @@ module Make (T : Tree.S) : Wasm_pvm_sig.S with type tree = T.tree = struct let _module_instances_of_tree = Decodings.run Decodings.module_instances_decoding + + let _eval_config_of_tree = Decodings.run Decodings.eval_config_decoding end) end diff --git a/src/lib_test/qcheck2_helpers.ml b/src/lib_test/qcheck2_helpers.ml index 285f9d595563823450b2fc35f969dce370c847b2..d78ca281a5e4d4cc6dbdab05027da7d83dad3a69 100644 --- a/src/lib_test/qcheck2_helpers.ml +++ b/src/lib_test/qcheck2_helpers.ml @@ -26,6 +26,24 @@ let qcheck_wrap ?verbose ?long ?rand = List.map (QCheck_alcotest.to_alcotest ?verbose ?long ?rand) +let qcheck_make_result ?count ?print ?pp_error ?check ~name + ~(gen : 'a QCheck2.Gen.t) (f : 'a -> (bool, 'b) result) = + let check = + match check with + | Some check -> check + | None -> ( + function + | Ok b -> b + | Error err -> ( + match pp_error with + | Some pp_error -> + QCheck2.Test.fail_reportf "Test failed:@,%a" pp_error err + | None -> + QCheck2.Test.fail_reportf + "Test failed but no pretty printer was provided.")) + in + QCheck2.Test.make ~name ?print ?count gen (fun x -> f x |> check) + let qcheck_eq ?pp ?cmp ?eq expected actual = let pass = match (eq, cmp) with diff --git a/src/lib_test/qcheck2_helpers.mli b/src/lib_test/qcheck2_helpers.mli index 879c13337ccdf141bcc3183616cd0d9cf8173894..05f411e6c8a71bd9caa81b32ccfdb45ab8e3e5bd 100644 --- a/src/lib_test/qcheck2_helpers.mli +++ b/src/lib_test/qcheck2_helpers.mli @@ -31,6 +31,21 @@ val qcheck_wrap : QCheck2.Test.t list -> unit Alcotest.test_case list +(** [qcheck_make_result ?print ?pp_error ?count ?check ~name ~gen f] + is a wrapper around {!QCheck2.Test.make} where [f] returns a + result type. If [check] is not provided and if the result of [f] is + an error, {!Qcheck2.Test.fail_reportf} is called and the error is + shown if [pp_error] is provided. *) +val qcheck_make_result : + ?count:int -> + ?print:'a QCheck2.Print.t -> + ?pp_error:(Format.formatter -> 'b -> unit) -> + ?check:((bool, 'b) result -> bool) -> + name:string -> + gen:'a QCheck2.Gen.t -> + ('a -> (bool, 'b) result) -> + QCheck2.Test.t + (** [qcheck_eq_tests ~eq ~gen ~eq_name] returns three tests of [eq]: reflexivity, symmetry, and transitivity. diff --git a/src/lib_webassembly/bin/text/arrange.ml b/src/lib_webassembly/bin/text/arrange.ml index 90d567df0712475cddcb88b9fbb7490702623b37..3446112b9bb7c72226b540c3333dc1f764068ffb 100644 --- a/src/lib_webassembly/bin/text/arrange.ml +++ b/src/lib_webassembly/bin/text/arrange.ml @@ -4,6 +4,7 @@ open Script open Values open Types open Sexpr +module TzStdLib = Tezos_lwt_result_stdlib.Lwtreslib.Bare (* Generic formatting *) @@ -55,6 +56,11 @@ let lazy_vectori f map = (fun (i32, v) -> f (Int32.to_int i32) v) (Lazy_vector.LwtInt32Vector.loaded_bindings map) +let lazy_vectori_lwt f map = + TzStdLib.List.map_s + (fun (i32, v) -> f (Int32.to_int i32) v) + (Lazy_vector.LwtInt32Vector.loaded_bindings map) + let tab head f xs = if xs = [] then [] else [Node (head, list f xs)] let atom f x = Atom (f x) @@ -596,11 +602,10 @@ let elem i seg = else atom ref_type etype :: list (const "item") einit ) let data i seg = + let open Lwt.Syntax in let {dinit; dmode} = seg.it in - Node - ( "data $" ^ nat i, - segment_mode "memory" dmode - @ break_bytes (Chunked_byte_vector.Buffer.to_string_unstable dinit) ) + let+ dinit = Chunked_byte_vector.Lwt.Buffer.to_string_unstable dinit in + Node ("data $" ^ nat i, segment_mode "memory" dmode @ break_bytes dinit) (* Modules *) @@ -651,11 +656,13 @@ let start s = Node ("start " ^ var s.it.sfunc, []) let var_opt = function None -> "" | Some x -> " " ^ x.it let module_with_var_opt x_opt m = + let open Lwt.Syntax in let fx = ref 0 in let tx = ref 0 in let mx = ref 0 in let gx = ref 0 in let imports = lazy_vector (import fx tx mx gx) m.it.imports in + let+ datas = lazy_vectori_lwt data m.it.datas in Node ( "module" ^ var_opt x_opt, lazy_vectori typedef m.it.types @@ -667,7 +674,7 @@ let module_with_var_opt x_opt m = @ lazy_vector export m.it.exports @ opt start m.it.start @ lazy_vectori elem m.it.elems - @ lazy_vectori data m.it.datas ) + @ datas ) let binary_module_with_var_opt x_opt bs = Node ("module" ^ var_opt x_opt ^ " binary", break_bytes bs) @@ -706,7 +713,7 @@ let definition mode x_opt def = | Encoded (_, bytes) -> Decode.decode ~name:"" ~bytes | Quoted (_, s) -> unquote (Parse.string_to_module s) in - let+ unquoted = unquote def in + let* unquoted = unquote def in module_with_var_opt x_opt unquoted | `Binary -> let rec unquote def = @@ -721,7 +728,7 @@ let definition mode x_opt def = binary_module_with_var_opt x_opt unquoted | `Original -> ( match def.it with - | Textual m -> module_with_var_opt x_opt m |> Lwt.return + | Textual m -> module_with_var_opt x_opt m | Encoded (_, bs) -> binary_module_with_var_opt x_opt bs |> Lwt.return | Quoted (_, s) -> quoted_module_with_var_opt x_opt s |> Lwt.return)) (function diff --git a/src/lib_webassembly/bin/text/arrange.mli b/src/lib_webassembly/bin/text/arrange.mli index 60c103dc7ba5d44de9a1ce23d20081e1c1c365ab..887831058c3994d2509f0ca4feb5fcbb2f218ee9 100644 --- a/src/lib_webassembly/bin/text/arrange.mli +++ b/src/lib_webassembly/bin/text/arrange.mli @@ -4,6 +4,6 @@ val instr : Ast.instr -> sexpr val func : Ast.func -> sexpr -val module_ : Ast.module_ -> sexpr +val module_ : Ast.module_ -> sexpr Lwt.t val script : [`Textual | `Binary] -> Script.script -> sexpr list Lwt.t diff --git a/src/lib_webassembly/bin/text/parser.mly b/src/lib_webassembly/bin/text/parser.mly index 6897454e218343b8adbcf7ccc61d234f155bd142..7d1288bcbafb60fbe44b1706cbe6f849ccd15329 100644 --- a/src/lib_webassembly/bin/text/parser.mly +++ b/src/lib_webassembly/bin/text/parser.mly @@ -980,17 +980,17 @@ data : | LPAR DATA bind_var_opt string_list RPAR { let at = at () in fun c -> ignore ($3 c anon_data bind_data); - fun () -> {dinit = Chunked_byte_vector.Buffer.of_string $4; dmode = Passive @@ at} @@ at } + fun () -> {dinit = Chunked_byte_vector.Lwt.Buffer.of_string $4; dmode = Passive @@ at} @@ at } | LPAR DATA bind_var_opt memory_use offset string_list RPAR { let at = at () in fun c -> ignore ($3 c anon_data bind_data); fun () -> - {dinit = Chunked_byte_vector.Buffer.of_string $6; dmode = Active {index = $4 c memory; offset = $5 c} @@ at} @@ at } + {dinit = Chunked_byte_vector.Lwt.Buffer.of_string $6; dmode = Active {index = $4 c memory; offset = $5 c} @@ at} @@ at } | LPAR DATA bind_var_opt offset string_list RPAR /* Sugar */ { let at = at () in fun c -> ignore ($3 c anon_data bind_data); fun () -> - {dinit = Chunked_byte_vector.Buffer.of_string $5; dmode = Active {index = 0l @@ at; offset = $4 c} @@ at} @@ at } + {dinit = Chunked_byte_vector.Lwt.Buffer.of_string $5; dmode = Active {index = 0l @@ at; offset = $4 c} @@ at} @@ at } memory : | LPAR MEMORY bind_var_opt memory_fields RPAR @@ -1014,7 +1014,7 @@ memory_fields : let offset = [i32_const (0l @@ at) @@ at] @@ at in let size = Int32.(div (add (of_int (String.length $3)) 65535l) 65536l) in [{mtype = MemoryType {min = size; max = Some size}} @@ at], - [{dinit = Chunked_byte_vector.Buffer.of_string $3; dmode = Active {index = x; offset} @@ at} @@ at], + [{dinit = Chunked_byte_vector.Lwt.Buffer.of_string $3; dmode = Active {index = x; offset} @@ at} @@ at], [], [] } global : diff --git a/src/lib_webassembly/bin/text/print.ml b/src/lib_webassembly/bin/text/print.ml index 97441cb36829c7e6e4984d5f0e493c904116bd40..5039f4d2929bb2f3cc06646263987eaf2ef835cf 100644 --- a/src/lib_webassembly/bin/text/print.ml +++ b/src/lib_webassembly/bin/text/print.ml @@ -4,7 +4,10 @@ let instr oc width e = Sexpr.output oc width (Arrange.instr e) let func oc width f = Sexpr.output oc width (Arrange.func f) -let module_ oc width m = Sexpr.output oc width (Arrange.module_ m) +let module_ oc width m = + let open Lwt.Syntax in + let* m = Arrange.module_ m in + Sexpr.output oc width m let script oc width mode s = let open Lwt.Syntax in diff --git a/src/lib_webassembly/binary/decode.ml b/src/lib_webassembly/binary/decode.ml index ac39433975238a0a35cf3a6a58b9ec566b5af2c9..f928b98ec951fe5e81f66e052772748fa9a630b5 100644 --- a/src/lib_webassembly/binary/decode.ml +++ b/src/lib_webassembly/binary/decode.ml @@ -161,20 +161,25 @@ let sized f s = (** Incremental chunked byte vector creation (from implicit input). *) type byte_vector_kont = | VKStart (** Initial step. *) - | VKRead of Chunked_byte_vector.Buffer.t * int * int + | VKRead of Chunked_byte_vector.Lwt.Buffer.t * int * int (** Reading step, containing the current position in the string and the length, reading byte per byte. *) - | VKStop of Chunked_byte_vector.Buffer.t (** Final step, cannot reduce. *) + | VKStop of Chunked_byte_vector.Lwt.Buffer.t + (** Final step, cannot reduce. *) -let byte_vector_step s = function +let byte_vector_step s = + let open Lwt.Syntax in + function | VKStart -> let len = len32 s in - let vector = len |> Int64.of_int |> Chunked_byte_vector.Buffer.create in - VKRead (vector, 0, len) - | VKRead (vector, index, len) when index >= len -> VKStop vector + let vector = + len |> Int64.of_int |> Chunked_byte_vector.Lwt.Buffer.create + in + VKRead (vector, 0, len) |> Lwt.return + | VKRead (vector, index, len) when index >= len -> VKStop vector |> Lwt.return | VKRead (vector, index, len) -> let c = get s in - let vector = Chunked_byte_vector.Buffer.add_byte vector c in + let+ vector = Chunked_byte_vector.Lwt.Buffer.add_byte vector c in VKRead (vector, index + 1, len) (* Final step, cannot reduce *) | VKStop vector -> assert false @@ -1510,20 +1515,24 @@ let data_start s = DKMode {left; index; offset_kont = (left_offset, [IKNext []])} | _ -> error s (pos s - 1) "malformed data segment kind" -let data_step s = function - | DKStart -> data_start s +let data_step s = + let open Lwt.Syntax in + function + | DKStart -> data_start s |> Lwt.return | DKMode {left; index; offset_kont = left_offset, [IKStop offset]} -> end_ s ; let right = pos s in let offset = Source.(offset @@ region s left_offset right) in let dmode = Source.(Active {index; offset} @@ region s left right) in - DKInit {dmode; init_kont = VKStart} + DKInit {dmode; init_kont = VKStart} |> Lwt.return | DKMode {left; index; offset_kont = left_offset, k} -> let k' = instr_block_step s k in - DKMode {left; index; offset_kont = (left_offset, k')} - | DKInit {dmode; init_kont = VKStop dinit} -> DKStop {dmode; dinit} + DKMode {left; index; offset_kont = (left_offset, k')} |> Lwt.return + | DKInit {dmode; init_kont = VKStop dinit} -> + DKStop {dmode; dinit} |> Lwt.return | DKInit {dmode; init_kont} -> - DKInit {dmode; init_kont = byte_vector_step s init_kont} + let+ init_kont = byte_vector_step s init_kont in + DKInit {dmode; init_kont} | DKStop _ -> assert false (* final step, cannot reduce *) (* DataCount section *) @@ -1882,7 +1891,8 @@ let module_step state = let data = Source.(data @@ region s left (pos s)) in next @@ MKField (DataField, size, lazy_vec_step data vec) | MKData (data_kont, pos, size, curr_vec) -> - next @@ MKData (data_step s data_kont, pos, size, curr_vec) + let* data_kont = data_step s data_kont in + next @@ MKData (data_kont, pos, size, curr_vec) | MKCode (CKStop func, left, size, vec) -> next @@ MKField (CodeField, size, lazy_vec_step func vec) | MKCode (code_kont, pos, size, curr_vec) -> diff --git a/src/lib_webassembly/binary/decode.mli b/src/lib_webassembly/binary/decode.mli index 13203dcb2e5b04fec9b23fce62064d6abfc38048..9842770a38764a8b081b5c87b0ba4730d15325e3 100644 --- a/src/lib_webassembly/binary/decode.mli +++ b/src/lib_webassembly/binary/decode.mli @@ -38,10 +38,11 @@ type size = {size : int; start : pos} (** Incremental chunked byte vector creation (from implicit input). *) type byte_vector_kont = | VKStart (** Initial step. *) - | VKRead of Chunked_byte_vector.Buffer.t * pos * int + | VKRead of Chunked_byte_vector.Lwt.Buffer.t * pos * int (** Reading step, containing the current position in the string and the length, reading byte per byte. *) - | VKStop of Chunked_byte_vector.Buffer.t (** Final step, cannot reduce. *) + | VKStop of Chunked_byte_vector.Lwt.Buffer.t + (** Final step, cannot reduce. *) type name_step = | NKStart (** UTF8 name starting point. *) diff --git a/src/lib_webassembly/binary/encode.ml b/src/lib_webassembly/binary/encode.ml index c5c8bb4746c1f2eb3df3d410ae5b9740ac30ac1a..718ae00d5f54ae69f6b26de6a7d4536bd0d8e3da 100644 --- a/src/lib_webassembly/binary/encode.ml +++ b/src/lib_webassembly/binary/encode.ml @@ -3,6 +3,8 @@ This module should never be part of the PVM since it assumes lazy vectors are fully loaded. *) +module TzStdLib = Tezos_lwt_result_stdlib.Lwtreslib.Bare + (* Version *) let version = 1l @@ -105,12 +107,18 @@ struct let list f xs = List.iter f xs + let list_lwt f xs = TzStdLib.List.iter_s f xs + let opt f xo = Lib.Option.app f xo let vec f xs = len (List.length xs) ; list f xs + let vec_lwt f xs = + len (List.length xs) ; + list_lwt f xs + let gap32 () = let p = pos s in u32 0l ; @@ -935,6 +943,16 @@ struct f x ; patch_gap32 g (pos s - p)) + let section_lwt id f x needed = + let open Lwt.Syntax in + if needed then ( + u8 id ; + let g = gap32 () in + let p = pos s in + let+ () = f x in + patch_gap32 g (pos s - p)) + else Lwt.return_unit + (* Type section *) let type_ t = func_type t.it @@ -1108,8 +1126,9 @@ struct (* Data section *) let data seg = + let open Lwt.Syntax in let {dinit; dmode} = seg.it in - let dinit = Chunked_byte_vector.Buffer.to_string_unstable dinit in + let+ dinit = Chunked_byte_vector.Lwt.Buffer.to_string_unstable dinit in match dmode.it with | Passive -> vu32 0x01l ; @@ -1125,7 +1144,7 @@ struct string dinit | Declarative -> assert false - let data_section datas = section 11 (vec data) datas (datas <> []) + let data_section datas = section_lwt 11 (vec_lwt data) datas (datas <> []) (* Data count section *) let data_count_section datas m = @@ -1157,7 +1176,7 @@ struct export_section (to_list m.it.exports) ; start_section m.it.start ; elem_section (to_list m.it.elems) ; - let+ () = data_count_section (to_list m.it.datas) m in + let* () = data_count_section (to_list m.it.datas) m in code_section (to_list m.it.funcs) ; data_section (to_list m.it.datas) end diff --git a/src/lib_webassembly/exec/eval.ml b/src/lib_webassembly/exec/eval.ml index fd7037b046fb9bc8c6875c98e9170703db6ee605..15b098c4fee019a5d93d29e10d6a254f523d29ca 100644 --- a/src/lib_webassembly/exec/eval.ml +++ b/src/lib_webassembly/exec/eval.ml @@ -885,12 +885,8 @@ let create_elem (inst : module_inst) (seg : elem_segment) : elem_inst Lwt.t = let create_data (inst : module_inst) (seg : data_segment) : data_inst Lwt.t = let {dinit; _} = seg.it in - (* TODO: #3076 - Conversion from [Chunked_byte_vector.Buffer.t] to - [Chunked_byte_vector.Lwt.t] is currently not efficiently supported. *) - let data = Chunked_byte_vector.Buffer.to_string_unstable dinit in - let+ data = Chunked_byte_vector.Lwt.of_string data in - ref data + let data = Chunked_byte_vector.Lwt.Buffer.to_byte_vector dinit in + Lwt.return (ref data) let add_import (m : module_) (ext : extern) (im : import) (inst : module_inst) : module_inst Lwt.t = @@ -951,7 +947,7 @@ let run_data i data = (I32 (Int32.of_int (Int64.to_int - (Chunked_byte_vector.Buffer.length data.it.dinit))) + (Chunked_byte_vector.Lwt.Buffer.length data.it.dinit))) @@ at) @@ at; MemoryInit x @@ at; diff --git a/src/lib_webassembly/exec/eval.mli b/src/lib_webassembly/exec/eval.mli index 5ef8ec7c897f5ec3318b4e539aaefe18141c6d70..d2f25fa2f203758bf0a91d0f0b13063e756e8605 100644 --- a/src/lib_webassembly/exec/eval.mli +++ b/src/lib_webassembly/exec/eval.mli @@ -9,6 +9,31 @@ exception Crash of Source.region * string exception Exhaustion of Source.region * string +type 'a stack = 'a list + +type frame = {inst : module_inst; locals : value ref list} + +type code = value stack * admin_instr list + +and admin_instr = admin_instr' Source.phrase + +and admin_instr' = + | Plain of Ast.instr' + | Refer of ref_ + | Invoke of func_inst + | Trapping of string + | Returning of value stack + | Breaking of int32 * value stack + | Label of int32 * Ast.instr list * code + | Frame of int32 * frame * code + +type config = { + frame : frame; + input : Instance.input_inst; + code : code; + budget : int; +} + val init : Ast.module_ -> extern list -> module_inst Lwt.t (* raises Link, Trap *) diff --git a/src/lib_webassembly/syntax/ast.ml b/src/lib_webassembly/syntax/ast.ml index 03df8d5f0039f9ff234c2a38a52f2d5ff5237eec..63305fd9cf6d5a709145317a7f91504fef9c8db4 100644 --- a/src/lib_webassembly/syntax/ast.ml +++ b/src/lib_webassembly/syntax/ast.ml @@ -367,7 +367,10 @@ and elem_segment' = { type data_segment = data_segment' Source.phrase -and data_segment' = {dinit : Chunked_byte_vector.Buffer.t; dmode : segment_mode} +and data_segment' = { + dinit : Chunked_byte_vector.Lwt.Buffer.t; + dmode : segment_mode; +} (* Modules *) diff --git a/src/lib_webassembly/util/chunked_byte_vector.ml b/src/lib_webassembly/util/chunked_byte_vector.ml index ce80160b79645bcb458072df59933c0bd29d64da..0a0e8297868e3bdf7e36a878df005916188bbde5 100644 --- a/src/lib_webassembly/util/chunked_byte_vector.ml +++ b/src/lib_webassembly/util/chunked_byte_vector.ml @@ -16,6 +16,9 @@ module Chunk = struct (** Get the offset within its chunk for a given address. *) let offset address = Int64.(logand address (sub size 1L)) + (** Get the address from a page index and an offset. *) + let address ~index ~offset = Int64.(add (shift_left index offset_bits) offset) + let alloc () = let chunk = Array1_64.create Int8_unsigned C_layout size in Array1.fill chunk 0 ; @@ -65,7 +68,7 @@ module type S = sig val create : ?get_chunk:(int64 -> Chunk.t effect) -> int64 -> t - val of_string : string -> t effect + val of_string : string -> t val of_bytes : bytes -> t effect @@ -90,7 +93,7 @@ module type S = sig val add_byte : t -> int -> t effect - val of_string : string -> t effect + val of_string : string -> t val to_string_unstable : t -> string effect @@ -144,13 +147,33 @@ module Make (Effect : Effect.S) : S with type 'a effect = 'a Effect.t = struct |> Effect.join let of_string str = - let open Effect in - let vector = String.length str |> Int64.of_int |> create in - let+ () = - List.init (String.length str) (fun i -> - let c = String.get str i in - store_byte vector (Int64.of_int i) (Char.code c)) - |> join + (* Strings are limited in size and contained in `nativeint` (either int31 or + int63 depending of the architecture). The maximum size of strings in + OCaml is limited by {!Sys.max_string_length} which is lesser than + `Int64.max_int` (and even Int.max_int). As such conversions from / to + Int64 to manipulate the vector is safe since the size of the + Chunked_byte_vector from a string can be contained in an `int`. + + Moreover, WASM strings are limited to max_uint32 in size for data + segments, which is the primary usage of this function in the text + parser. *) + let len = String.length str in + let vector = create (Int64.of_int len) in + let _ = + List.init + (Vector.num_elements vector.chunks |> Int64.to_int) + (fun index -> + let index = Int64.of_int index in + let chunk = Chunk.alloc () in + let _ = + List.init (Chunk.size |> Int64.to_int) (fun offset -> + let offset = Int64.of_int offset in + let address = Chunk.address ~index ~offset |> Int64.to_int in + if address < len then + let c = String.get str address in + Array1_64.set chunk offset (Char.code c)) + in + Vector.set index chunk vector.chunks) in vector @@ -171,9 +194,8 @@ module Make (Effect : Effect.S) : S with type 'a effect = 'a Effect.t = struct {vector; offset = Int64.succ offset} let of_string str = - let open Effect in let offset = String.length str |> Int64.of_int in - let+ vector = of_string str in + let vector = of_string str in {vector; offset} let create length = {vector = create length; offset = 0L} diff --git a/src/lib_webassembly/util/chunked_byte_vector.mli b/src/lib_webassembly/util/chunked_byte_vector.mli index 6fced71cfc7e55a20263ee6534f69c8dd3a6e363..14196bba9dd94806da26a99ec3ad7d0139a4948e 100644 --- a/src/lib_webassembly/util/chunked_byte_vector.mli +++ b/src/lib_webassembly/util/chunked_byte_vector.mli @@ -36,7 +36,7 @@ module type S = sig val create : ?get_chunk:(int64 -> Chunk.t effect) -> int64 -> t (** [of_string str] creates a chunked byte vector from the given [str]. *) - val of_string : string -> t effect + val of_string : string -> t (** [of_bytes bytes] creates a chunked byte vector from the given [bytes]. The underlying memory is effectively copied - further modifications to [bytes] @@ -77,7 +77,7 @@ module type S = sig val add_byte : t -> int -> t effect (** [of_string str] creates a chunked byte vector from the given [str]. *) - val of_string : string -> t effect + val of_string : string -> t (** [to_string_unstable buffer] creates a string from the given buffer [buffer]. diff --git a/src/lib_webassembly/util/lazy_map.ml b/src/lib_webassembly/util/lazy_map.ml index d24942d2e05a96519963b204412ed240c2e49503..c810cdc3b1ea049d0012102b49f2871e03bd3e0d 100644 --- a/src/lib_webassembly/util/lazy_map.ml +++ b/src/lib_webassembly/util/lazy_map.ml @@ -41,6 +41,8 @@ module type S = sig type 'a t + val string_of_key : key -> string + val pp : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit val to_string : ('a -> string) -> 'a t -> string @@ -77,6 +79,8 @@ module Make (Effect : Effect.S) (Key : KeyS) : type 'a t = {produce_value : 'a producer; mutable values : 'a Map.t} + let string_of_key = Key.to_string + let pp pp_value = let pp_values fmt values = Map.bindings values diff --git a/src/lib_webassembly/util/lazy_map.mli b/src/lib_webassembly/util/lazy_map.mli index 262d16ebd7a5ee23c17769dfdefbf7aa9b509245..3c858fd1d92119feceffc1bbdd18f4659dd74c02 100644 --- a/src/lib_webassembly/util/lazy_map.mli +++ b/src/lib_webassembly/util/lazy_map.mli @@ -39,6 +39,9 @@ module type S = sig type 'a t + (** [string_of_key key] turns the given [key] into a string. *) + val string_of_key : key -> string + (** [pp pp_value] gives you a pretty-printer. This function is a witness of internal mutation. *) val pp : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit diff --git a/src/lib_webassembly/util/lazy_vector.ml b/src/lib_webassembly/util/lazy_vector.ml index b92cb3918c27951d27aa8e65c3e09139bbf4d8af..082af375d9926c5252d15ef86ab27de3c5d31be3 100644 --- a/src/lib_webassembly/util/lazy_vector.ml +++ b/src/lib_webassembly/util/lazy_vector.ml @@ -51,9 +51,16 @@ module type S = sig val to_string : ('a -> string) -> 'a t -> string + val string_of_key : key -> string + val num_elements : 'a t -> key - val create : ?values:'a Map.Map.t -> ?produce_value:'a producer -> key -> 'a t + val create : + ?first_key:key -> + ?values:'a Map.Map.t -> + ?produce_value:'a producer -> + key -> + 'a t val empty : unit -> 'a t @@ -74,6 +81,8 @@ module type S = sig val to_list : 'a t -> 'a list effect val loaded_bindings : 'a t -> (key * 'a) list + + val first_key : 'a t -> key end module ZZ : KeyS with type t = Z.t = struct @@ -114,11 +123,13 @@ module Make (Effect : Effect.S) (Key : KeyS) : let pp_value fmt value = Format.pp_print_string fmt (show_value value) in Format.asprintf "%a" (pp pp_value) map + let string_of_key = Key.to_string + let num_elements map = map.num_elements - let create ?values ?produce_value num_elements = + let create ?(first_key = Key.zero) ?values ?produce_value num_elements = let values = Map.create ?values ?produce_value () in - {first = Key.zero; num_elements; values} + {first = first_key; num_elements; values} let empty () = create Key.zero @@ -207,6 +218,8 @@ module Make (Effect : Effect.S) (Key : KeyS) : else (unroll [@ocaml.tailcall]) [] (Key.pred map.num_elements) let loaded_bindings m = Map.loaded_bindings m.values + + let first_key vector = vector.first end module Int = struct diff --git a/src/lib_webassembly/util/lazy_vector.mli b/src/lib_webassembly/util/lazy_vector.mli index 121accfb2c1c0f924788e5efcb73769a3120dbd3..318f7206323308107f336c54b09e16b66bcdf793 100644 --- a/src/lib_webassembly/util/lazy_vector.mli +++ b/src/lib_webassembly/util/lazy_vector.mli @@ -62,14 +62,24 @@ module type S = sig internal mutation. *) val to_string : ('a -> string) -> 'a t -> string + (** [string_of_key key] turns the given [key] into a string. *) + val string_of_key : key -> string + (** [num_elements vector] returns the maximum number of elements in the lazy vector. *) val num_elements : 'a t -> key - (** [create ?values ?produce_value num_elements] produces a lazy vector with - [num_elements] entries where each is created using [produce_value]. - [values] may be provided to supply an initial set of entries. *) - val create : ?values:'a Map.Map.t -> ?produce_value:'a producer -> key -> 'a t + (** [create ?first_key ?values ?produce_value num_elements] produces a lazy + vector with [num_elements] entries where each is created using + [produce_value]. [values] may be provided to supply an initial set of + entries. [first_key] specifies the first index of the vector if given and + defaults to zero. *) + val create : + ?first_key:key -> + ?values:'a Map.Map.t -> + ?produce_value:'a producer -> + key -> + 'a t (** [empty ()] creates a vector of size zero. This is used in conjunction with {!cons} to model list-like structure. *) @@ -116,6 +126,9 @@ module type S = sig the vector [vector] containing only the loaded values, in order of increasing keys. This function is a witness of internal mutations. *) val loaded_bindings : 'a t -> (key * 'a) list + + (** [first_key v] returns the first key of the given vector [v]. *) + val first_key : 'a t -> key end module Make (Effect : Effect.S) (Key : KeyS) : diff --git a/src/proto_014_PtKathma/lib_delegate/baking_actions.ml b/src/proto_014_PtKathma/lib_delegate/baking_actions.ml index c88a975828bcdd54ee34092290ed7a86be7c956b..58d91acbc7bac687eb2832c160806e5e52d6b5c5 100644 --- a/src/proto_014_PtKathma/lib_delegate/baking_actions.ml +++ b/src/proto_014_PtKathma/lib_delegate/baking_actions.ml @@ -340,6 +340,9 @@ let inject_preendorsements ~state_recorder state ~preendorsements ~updated_state (* N.b. signing a lot of operations may take some time *) (* Don't parallelize signatures: the signer might not be able to handle concurrent requests *) + let block_location = + Baking_files.resolve_location ~chain_id `Highwatermarks + in List.filter_map_es (fun (delegate, consensus_content) -> Events.(emit signing_preendorsement delegate) >>= fun () -> @@ -352,10 +355,8 @@ let inject_preendorsements ~state_recorder state ~preendorsements ~updated_state let contents = Single (Preendorsement consensus_content) in let level = Raw_level.to_int32 consensus_content.level in let round = consensus_content.round in + let sk_uri = delegate.secret_key_uri in cctxt#with_lock (fun () -> - let block_location = - Baking_files.resolve_location ~chain_id `Highwatermarks - in let delegate = delegate.public_key_hash in Baking_highwatermarks.may_sign_preendorsement cctxt @@ -382,9 +383,7 @@ let inject_preendorsements ~state_recorder state ~preendorsements ~updated_state Operation.unsigned_encoding unsigned_operation in - (* TODO: do we want to reload the sk uri or not ? *) - Client_keys.get_key cctxt delegate.public_key_hash >>=? fun (_, _, sk) -> - Client_keys.sign cctxt ~watermark sk unsigned_operation_bytes + Client_keys.sign cctxt ~watermark sk_uri unsigned_operation_bytes else fail (Baking_highwatermarks.Block_previously_preendorsed {round; level})) >>= function @@ -427,6 +426,9 @@ let sign_endorsements state endorsements = (* N.b. signing a lot of operations may take some time *) (* Don't parallelize signatures: the signer might not be able to handle concurrent requests *) + let block_location = + Baking_files.resolve_location ~chain_id `Highwatermarks + in List.filter_map_es (fun (delegate, consensus_content) -> Events.(emit signing_endorsement delegate) >>= fun () -> @@ -442,14 +444,13 @@ let sign_endorsements state endorsements = in let level = Raw_level.to_int32 consensus_content.level in let round = consensus_content.round in + let sk_uri = delegate.secret_key_uri in cctxt#with_lock (fun () -> - let block_location = - Baking_files.resolve_location ~chain_id `Highwatermarks - in + let delegate = delegate.public_key_hash in Baking_highwatermarks.may_sign_endorsement cctxt block_location - ~delegate:delegate.public_key_hash + ~delegate ~level ~round >>=? function @@ -457,7 +458,7 @@ let sign_endorsements state endorsements = Baking_highwatermarks.record_endorsement cctxt block_location - ~delegate:delegate.public_key_hash + ~delegate ~level ~round >>=? fun () -> return_true @@ -471,11 +472,8 @@ let sign_endorsements state endorsements = Operation.unsigned_encoding unsigned_operation in - (* TODO: do we want to reload the sk uri or not ? *) - Client_keys.get_key cctxt delegate.public_key_hash >>=? fun (_, _, sk) -> - Client_keys.sign cctxt ~watermark sk unsigned_operation_bytes - else - fail (Baking_highwatermarks.Block_previously_preendorsed {round; level})) + Client_keys.sign cctxt ~watermark sk_uri unsigned_operation_bytes + else fail (Baking_highwatermarks.Block_previously_endorsed {round; level})) >>= function | Error err -> Events.(emit skipping_endorsement (delegate, err)) >>= fun () -> diff --git a/src/proto_014_PtKathma/lib_protocol/test/helpers/incremental.ml b/src/proto_014_PtKathma/lib_protocol/test/helpers/incremental.ml index 7c03e9c1d9ba13f55e73ad78ef1a9ecf5a7f91a7..3d9ee379a6171c46e745c6670e4162f898cced2f 100644 --- a/src/proto_014_PtKathma/lib_protocol/test/helpers/incremental.ml +++ b/src/proto_014_PtKathma/lib_protocol/test/helpers/incremental.ml @@ -170,10 +170,10 @@ let apply_operation ?(check_size = true) st op = Constants_repr.max_operation_data_length))) ; apply_operation st.state op >|= Environment.wrap_tzresult -let precheck_operation ?expect_failure ?check_size st op = +let validate_operation ?expect_failure ?check_size st op = apply_operation ?check_size st op >>= fun result -> match (expect_failure, result) with - | Some _, Ok _ -> failwith "Error expected while prechecking operation" + | Some _, Ok _ -> failwith "Error expected while validating operation" | Some f, Error err -> f err >|=? fun () -> st | None, Error err -> failwith "Error %a was not expected" pp_print_trace err | None, Ok (state, (Operation_metadata _ as metadata)) diff --git a/src/proto_014_PtKathma/lib_protocol/test/helpers/incremental.mli b/src/proto_014_PtKathma/lib_protocol/test/helpers/incremental.mli index 53a824fde6b5df853bb3ebc7410fbbc3d527f17e..804a282f813d7a5ec1634e6a8d4dfcbbd388c955 100644 --- a/src/proto_014_PtKathma/lib_protocol/test/helpers/incremental.mli +++ b/src/proto_014_PtKathma/lib_protocol/test/helpers/incremental.mli @@ -57,23 +57,23 @@ val begin_construction : Block.t -> incremental tzresult Lwt.t -(** [precheck_operation ?expect_failure ?check_size i op] tries to - precheck [op] in the validation state of [i]. If the precheck +(** [validate_operation ?expect_failure ?check_size i op] tries to + validate [op] in the validation state of [i]. If the validation succeeds, the function returns the incremental value with a - validation state updated after the precheck. Otherwise raise the - error from the prechecking of [op]. + validation state updated after the validate. Otherwise raise the + error from the validation of [op]. Optional arguments allow to override defaults: {ul {li [?expect_failure:(error list -> unit tzresult Lwt.t)]: - precheck of [op] is expected to fail and [expect_failure] should - handle the error. In case precheck does not fail and an - [expect_failure] is provided, [precheck_operation] fails.} + validation of [op] is expected to fail and [expect_failure] should + handle the error. In case validate does not fail and an + [expect_failure] is provided, [validate_operation] fails.} {li [?check_size:bool]: enable the check that an operation size should not exceed [Constants_repr.max_operation_data_length]. Enabled (set to [true]) by default. }} *) -val precheck_operation : +val validate_operation : ?expect_failure:(error list -> unit tzresult Lwt.t) -> ?check_size:bool -> incremental -> @@ -82,16 +82,16 @@ val precheck_operation : (** [add_operation ?expect_failure ?expect_apply_failure ?check_size i op] tries to apply [op] in the validation state of [i]. If the - precheck of [op] succeeds, the function returns the incremental + validation of [op] succeeds, the function returns the incremental value with a validation state updated after the application of - [op]. Otherwise raise the error from the prechecking of [op]. + [op]. Otherwise raise the error from the validation of [op]. Optional arguments allow to override defaults: {ul {li [?expect_failure:(error list -> unit tzresult Lwt.t)]: - precheck of [op] is expected to fail and [expect_failure] should - handle the error. In case precheck does not fail and - [expect_failure] is provided, [precheck_operation] fails.} + validation of [op] is expected to fail and [expect_failure] should + handle the error. In case validate does not fail and + [expect_failure] is provided, [validate_operation] fails.} {ul {li [?expect_apply_failure:(error list -> unit tzresult Lwt.t)]: application of [op] is expected to fail and diff --git a/src/proto_014_PtKathma/lib_protocol/test/helpers/op.ml b/src/proto_014_PtKathma/lib_protocol/test/helpers/op.ml index c3e183a50dfeda7fc12732af45634e14de996d47..ccef199cec1ea3a6bddc67964b75b8bededbde3b 100644 --- a/src/proto_014_PtKathma/lib_protocol/test/helpers/op.ml +++ b/src/proto_014_PtKathma/lib_protocol/test/helpers/op.ml @@ -170,6 +170,15 @@ let resolve_gas_limit ctxt = function | Zero -> return Gas.Arith.zero | Custom_gas x -> return x +let pp_gas_limit fmt = function + | Max -> Format.fprintf fmt "Max" + | High -> + Format.fprintf fmt "High: %a" Gas.Arith.pp_integral default_high_gas_limit + | Low -> + Format.fprintf fmt "Low: %a" Gas.Arith.pp_integral default_low_gas_limit + | Zero -> Format.fprintf fmt "Zero: %a" Gas.Arith.pp_integral Gas.Arith.zero + | Custom_gas x -> Format.fprintf fmt "Custom: %a" Gas.Arith.pp_integral x + let combine_operations ?public_key ?counter ?spurious_operation ~source ctxt (packed_operations : packed_operation list) = assert (match packed_operations with [] -> false | _ :: _ -> true) ; diff --git a/src/proto_014_PtKathma/lib_protocol/test/helpers/op.mli b/src/proto_014_PtKathma/lib_protocol/test/helpers/op.mli index c2aa30bfd275075366549d9f012871c824a5f07a..d4e2d7bf3fe656590fc32676f9f3fcceb6bc7723 100644 --- a/src/proto_014_PtKathma/lib_protocol/test/helpers/op.mli +++ b/src/proto_014_PtKathma/lib_protocol/test/helpers/op.mli @@ -69,6 +69,9 @@ type gas_limit = | Zero | Custom_gas of Gas.Arith.integral +(** Pretty printer for gas_limit type. *) +val pp_gas_limit : Format.formatter -> gas_limit -> unit + val transaction : ?force_reveal:bool -> ?counter:Z.t -> diff --git a/src/proto_014_PtKathma/lib_protocol/test/integration/precheck/manager_operation_helpers.ml b/src/proto_014_PtKathma/lib_protocol/test/integration/precheck/manager_operation_helpers.ml deleted file mode 100644 index 2be78e4339b58c22c7a739cdfcf2e9841be01ca7..0000000000000000000000000000000000000000 --- a/src/proto_014_PtKathma/lib_protocol/test/integration/precheck/manager_operation_helpers.ml +++ /dev/null @@ -1,968 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -open Protocol -open Alpha_context -open Test_tez - -(* Hard gas limit *) -let gb_limit = Gas.Arith.(integral_of_int_exn 100_000) - -let half_gb_limit = Gas.Arith.(integral_of_int_exn 50_000) - -type infos = { - block : Block.t; - account1 : Account.t; - contract1 : Contract.t; - account2 : Account.t; - contract2 : Contract.t; - account3 : Account.t; - contract3 : Contract.t; - contract_hash : Contract_hash.t; - tx_rollup : Tx_rollup.t; - sc_rollup : Sc_rollup.t; -} - -(* Initialize an [infos] record with a context enabling tx and sc - rollup, funded accounts, tx_rollup, sc_rollup *) -let init_context ?hard_gas_limit_per_block () = - let open Lwt_result_syntax in - let* b, bootstrap_contract = - Context.init1 - ~consensus_threshold:0 - ?hard_gas_limit_per_block - ~tx_rollup_enable:true - ~tx_rollup_sunset_level:Int32.max_int - ~sc_rollup_enable:true - ~dal_enable:true - () - in - (* Set a gas_limit to avoid the default gas_limit of the helpers - ([hard_gas_limit_per_operation]) *) - let gas_limit = Op.Custom_gas (Gas.Arith.integral_of_int_exn 10_000) in - (* Create and fund an account use for originate a Tx and a Sc - rollup *) - let rollup_account = Account.new_account () in - let rollup_contract = Contract.Implicit rollup_account.pkh in - let counter = Z.zero in - let* fund_rollup_account = - Op.transaction - ~force_reveal:true - ~counter - ~gas_limit - (B b) - bootstrap_contract - rollup_contract - Tez.one - in - let* b = Block.bake ~operation:fund_rollup_account b in - let counter2 = Z.succ counter in - let* rollup_origination, tx_rollup = - Op.tx_rollup_origination - ~force_reveal:true - ~counter:counter2 - ~gas_limit - (B b) - rollup_contract - in - let* _, sc_rollup = - Op.sc_rollup_origination - ~counter:counter2 - ~gas_limit - (B b) - rollup_contract - Sc_rollup.Kind.Example_arith - "" - (Script.lazy_expr (Expr.from_string "1")) - in - let* b = Block.bake ~operation:rollup_origination b in - (* Create and fund three accounts *) - let account1 = Account.new_account () in - let contract1 = Contract.Implicit account1.pkh in - let counter = Z.succ counter in - let* fund_account1 = - Op.transaction - ~counter - ~gas_limit - (B b) - bootstrap_contract - contract1 - Tez.one - in - let account2 = Account.new_account () in - let contract2 = Contract.Implicit account2.pkh in - let counter = Z.succ counter in - let* fund_account2 = - Op.transaction - ~counter - ~gas_limit - (B b) - bootstrap_contract - contract2 - Tez.one - in - let account3 = Account.new_account () in - let contract3 = Contract.Implicit account3.pkh in - let counter = Z.succ counter in - let* fund_account3 = - Op.transaction - ~counter - ~gas_limit - (B b) - bootstrap_contract - contract3 - Tez.one - in - let* create_contract_hash, contract_hash = - Op.contract_origination_hash - (B b) - contract3 - ~fee:Tez.zero - ~script:Op.dummy_script - in - let* operation = - Op.batch_operations - ~source:bootstrap_contract - (B b) - [fund_account1; fund_account2; fund_account3; create_contract_hash] - in - let+ block = Block.bake ~operation b in - { - block; - account1; - contract1; - account2; - contract2; - account3; - contract3; - contract_hash; - tx_rollup; - sc_rollup; - } - -(* Same as [init_context] but [contract1] delegate to [contract2] *) -let init_delegated_implicit () = - let open Lwt_result_syntax in - let* infos = init_context () in - let* del_opt = - Context.Contract.delegate_opt (B infos.block) infos.contract1 - in - let* _ = - Assert.is_none - ~loc:__LOC__ - ~pp:(fun fmt _ -> Format.fprintf fmt "should not be delegated") - del_opt - in - let* operation = - Op.delegation - ~force_reveal:true - (B infos.block) - infos.contract2 - (Some (Context.Contract.pkh infos.contract2)) - in - let* block = Block.bake infos.block ~operation in - let* operation = - Op.delegation - ~force_reveal:true - (B block) - infos.contract1 - (Some infos.account2.pkh) - in - let* block = Block.bake block ~operation in - let* del_opt_new = Context.Contract.delegate_opt (B block) infos.contract1 in - let* del = Assert.get_some ~loc:__LOC__ del_opt_new in - let+ _ = Assert.equal_pkh ~loc:__LOC__ del infos.account2.pkh in - {infos with block} - -(* Same as [init_context] but [contract1] self delegate. *) -let init_self_delegated_implicit () = - let open Lwt_result_syntax in - let* infos = init_context () in - let* del_opt = - Context.Contract.delegate_opt (B infos.block) infos.contract1 - in - let* _ = - Assert.is_none - ~loc:__LOC__ - ~pp:(fun fmt _ -> Format.fprintf fmt "should not be delegated") - del_opt - in - let* operation = - Op.delegation - ~force_reveal:true - (B infos.block) - infos.contract1 - (Some infos.account1.pkh) - in - let* block = Block.bake infos.block ~operation in - let* del_opt_new = Context.Contract.delegate_opt (B block) infos.contract1 in - let* del = Assert.get_some ~loc:__LOC__ del_opt_new in - let+ _ = Assert.equal_pkh ~loc:__LOC__ del infos.account1.pkh in - {infos with block} - -(* Local helpers for generating all kind of manager operations. *) - -(* Create a fresh account used for empty implicit account tests. *) -let mk_fresh_contract () = Contract.Implicit Account.(new_account ()).pkh - -let get_pkh source = Context.Contract.pkh source - -let get_pk infos source = - let open Lwt_result_syntax in - let+ account = Context.Contract.manager infos source in - account.pk - -let mk_transaction ?counter ?fee ?gas_limit ?storage_limit ?force_reveal ~source - (infos : infos) = - Op.transaction - ?force_reveal - ?counter - ?fee - ?gas_limit - ?storage_limit - (B infos.block) - source - infos.contract2 - Tez.one - -let mk_delegation ?counter ?fee ?gas_limit ?storage_limit ?force_reveal ~source - (infos : infos) = - Op.delegation - ?force_reveal - ?fee - ?gas_limit - ?counter - ?storage_limit - (B infos.block) - source - (Some infos.account2.pkh) - -let mk_undelegation ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ~source (infos : infos) = - Op.delegation - ?force_reveal - ?fee - ?gas_limit - ?counter - ?storage_limit - (B infos.block) - source - None - -let mk_self_delegation ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ~source (infos : infos) = - Op.delegation - ?force_reveal - ?fee - ?gas_limit - ?counter - ?storage_limit - (B infos.block) - source - (Some (get_pkh source)) - -let mk_origination ?counter ?fee ?gas_limit ?storage_limit ?force_reveal ~source - (infos : infos) = - let open Lwt_result_syntax in - let+ op, _ = - Op.contract_origination - ?force_reveal - ?counter - ?fee - ?gas_limit - ?storage_limit - ~script:Op.dummy_script - (B infos.block) - source - in - op - -let mk_register_global_constant ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = - Op.register_global_constant - ?force_reveal - ?counter - ?fee - ?gas_limit - ?storage_limit - (B infos.block) - ~source - ~value:(Script_repr.lazy_expr (Expr.from_string "Pair 1 2")) - -let mk_set_deposits_limit ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ~source (infos : infos) = - Op.set_deposits_limit - ?force_reveal - ?fee - ?gas_limit - ?storage_limit - ?counter - (B infos.block) - source - None - -let mk_increase_paid_storage ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = - Op.increase_paid_storage - ?force_reveal - ?counter - ?fee - ?gas_limit - ?storage_limit - (B infos.block) - ~source - ~destination:infos.contract_hash - Z.one - -let mk_reveal ?counter ?fee ?gas_limit ?storage_limit ?force_reveal:_ ~source - (infos : infos) = - let open Lwt_result_syntax in - let* pk = get_pk (B infos.block) source in - Op.revelation ?fee ?gas_limit ?counter ?storage_limit (B infos.block) pk - -let mk_tx_rollup_origination ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = - let open Lwt_result_syntax in - let+ op, _rollup = - Op.tx_rollup_origination - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - in - op - -let mk_tx_rollup_submit_batch ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = - Op.tx_rollup_submit_batch - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.tx_rollup - "batch" - -let mk_tx_rollup_commit ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ~source (infos : infos) = - let commitement : Tx_rollup_commitment.Full.t = - { - level = Tx_rollup_level.root; - messages = []; - predecessor = None; - inbox_merkle_root = Tx_rollup_inbox.Merkle.merklize_list []; - } - in - Op.tx_rollup_commit - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.tx_rollup - commitement - -let mk_tx_rollup_return_bond ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = - Op.tx_rollup_return_bond - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.tx_rollup - -let mk_tx_rollup_finalize ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ~source (infos : infos) = - Op.tx_rollup_finalize - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.tx_rollup - -let mk_tx_rollup_remove_commitment ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = - Op.tx_rollup_remove_commitment - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.tx_rollup - -let mk_tx_rollup_reject ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ~source (infos : infos) = - let message, _ = Tx_rollup_message.make_batch "" in - let message_hash = Tx_rollup_message_hash.hash_uncarbonated message in - let message_path = - match Tx_rollup_inbox.Merkle.compute_path [message_hash] 0 with - | Ok message_path -> message_path - | _ -> raise (Invalid_argument "Single_message_inbox.message_path") - in - let proof : Tx_rollup_l2_proof.t = - { - version = 1; - before = `Value Tx_rollup_message_result.empty_l2_context_hash; - after = `Value Context_hash.zero; - state = Seq.empty; - } - in - let previous_message_result : Tx_rollup_message_result.t = - { - context_hash = Tx_rollup_message_result.empty_l2_context_hash; - withdraw_list_hash = Tx_rollup_withdraw_list_hash.empty; - } - in - Op.tx_rollup_reject - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.tx_rollup - Tx_rollup_level.root - message - ~message_position:0 - ~message_path - ~message_result_hash:Tx_rollup_message_result_hash.zero - ~message_result_path:Tx_rollup_commitment.Merkle.dummy_path - ~proof - ~previous_message_result - ~previous_message_result_path:Tx_rollup_commitment.Merkle.dummy_path - -let mk_transfer_ticket ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ~source (infos : infos) = - Op.transfer_ticket - ?fee - ?force_reveal - ?counter - ?gas_limit - ?storage_limit - (B infos.block) - ~source - ~contents:(Script.lazy_expr (Expr.from_string "1")) - ~ty:(Script.lazy_expr (Expr.from_string "nat")) - ~ticketer:infos.contract3 - Z.zero - ~destination:infos.contract2 - Entrypoint.default - -let mk_tx_rollup_dispacth_ticket ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = - let reveal = - Tx_rollup_reveal. - { - contents = Script.lazy_expr (Expr.from_string "1"); - ty = Script.lazy_expr (Expr.from_string "nat"); - ticketer = infos.contract2; - amount = Tx_rollup_l2_qty.of_int64_exn 10L; - claimer = infos.account3.pkh; - } - in - Op.tx_rollup_dispatch_tickets - ?fee - ?force_reveal - ?counter - ?gas_limit - ?storage_limit - (B infos.block) - ~source - ~message_index:0 - ~message_result_path:Tx_rollup_commitment.Merkle.dummy_path - infos.tx_rollup - Tx_rollup_level.root - Context_hash.zero - [reveal] - -let mk_sc_rollup_origination ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = - let open Lwt_result_syntax in - let+ op, _ = - Op.sc_rollup_origination - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - Sc_rollup.Kind.Example_arith - "" - (Script.lazy_expr (Expr.from_string "1")) - in - op - -let sc_dummy_commitment = - let number_of_messages = - match Sc_rollup.Number_of_messages.of_int32 3l with - | None -> assert false - | Some x -> x - in - let number_of_ticks = - match Sc_rollup.Number_of_ticks.of_int32 3000l with - | None -> assert false - | Some x -> x - in - Sc_rollup.Commitment. - { - predecessor = Sc_rollup.Commitment.Hash.zero; - inbox_level = Raw_level.of_int32_exn Int32.zero; - number_of_messages; - number_of_ticks; - compressed_state = Sc_rollup.State_hash.zero; - } - -let mk_sc_rollup_publish ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ~source (infos : infos) = - Op.sc_rollup_publish - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.sc_rollup - sc_dummy_commitment - -let mk_sc_rollup_cement ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ~source (infos : infos) = - Op.sc_rollup_cement - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.sc_rollup - (Sc_rollup.Commitment.hash sc_dummy_commitment) - -let mk_sc_rollup_refute ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ~source (infos : infos) = - let refutation : Sc_rollup.Game.refutation = - {choice = Sc_rollup.Tick.initial; step = Dissection []} - in - Op.sc_rollup_refute - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.sc_rollup - infos.account2.pkh - refutation - false - -let mk_sc_rollup_add_messages ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = - Op.sc_rollup_add_messages - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.sc_rollup - [] - -let mk_sc_rollup_timeout ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ~source (infos : infos) = - Op.sc_rollup_timeout - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.sc_rollup - (Sc_rollup.Game.Index.make infos.account2.pkh infos.account3.pkh) - -let mk_sc_rollup_execute_outbox_message ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = - Op.sc_rollup_execute_outbox_message - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.sc_rollup - (Sc_rollup.Commitment.hash sc_dummy_commitment) - ~outbox_level:Raw_level.root - ~message_index:0 - ~inclusion_proof:"" - ~message:"" - -let mk_sc_rollup_return_bond ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = - Op.sc_rollup_recover_bond - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.sc_rollup - -let mk_dal_publish_slot_header ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = - let open Lwt_result_syntax in - let level = 0 in - let index = 0 in - let header = 0 in - let json_slot = - Data_encoding.Json.from_string - (Format.asprintf - {|{"level":%d,"index":%d,"header":%d}|} - level - index - header) - in - let* json_slot = - match json_slot with Error s -> failwith "%s" s | Ok slot -> return slot - in - let slot = Data_encoding.Json.destruct Dal.Slot.encoding json_slot in - Op.dal_publish_slot_header - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - slot - -(* Helpers for generation of generic check tests by manager operation. *) -(* This type should be extended for each new manager_operation kind - added in the protocol. *) -type manager_operation_kind = - | K_Transaction - | K_Origination - | K_Register_global_constant - | K_Delegation - | K_Undelegation - | K_Self_delegation - | K_Set_deposits_limit - | K_Increase_paid_storage - | K_Reveal - | K_Tx_rollup_origination - | K_Tx_rollup_submit_batch - | K_Tx_rollup_commit - | K_Tx_rollup_return_bond - | K_Tx_rollup_finalize - | K_Tx_rollup_remove_commitment - | K_Tx_rollup_dispatch_tickets - | K_Transfer_ticket - | K_Tx_rollup_reject - | K_Sc_rollup_origination - | K_Sc_rollup_publish - | K_Sc_rollup_cement - | K_Sc_rollup_add_messages - | K_Sc_rollup_refute - | K_Sc_rollup_timeout - | K_Sc_rollup_execute_outbox_message - | K_Sc_rollup_recover_bond - | K_Dal_publish_slot_header - -let select_op = function - | K_Transaction -> mk_transaction - | K_Origination -> mk_origination - | K_Register_global_constant -> mk_register_global_constant - | K_Delegation -> mk_delegation - | K_Undelegation -> mk_undelegation - | K_Self_delegation -> mk_self_delegation - | K_Set_deposits_limit -> mk_set_deposits_limit - | K_Increase_paid_storage -> mk_increase_paid_storage - | K_Reveal -> mk_reveal - | K_Tx_rollup_origination -> mk_tx_rollup_origination - | K_Tx_rollup_submit_batch -> mk_tx_rollup_submit_batch - | K_Tx_rollup_commit -> mk_tx_rollup_commit - | K_Tx_rollup_return_bond -> mk_tx_rollup_return_bond - | K_Tx_rollup_finalize -> mk_tx_rollup_finalize - | K_Tx_rollup_remove_commitment -> mk_tx_rollup_remove_commitment - | K_Tx_rollup_reject -> mk_tx_rollup_reject - | K_Transfer_ticket -> mk_transfer_ticket - | K_Tx_rollup_dispatch_tickets -> mk_tx_rollup_dispacth_ticket - | K_Sc_rollup_origination -> mk_sc_rollup_origination - | K_Sc_rollup_publish -> mk_sc_rollup_publish - | K_Sc_rollup_cement -> mk_sc_rollup_cement - | K_Sc_rollup_refute -> mk_sc_rollup_refute - | K_Sc_rollup_add_messages -> mk_sc_rollup_add_messages - | K_Sc_rollup_timeout -> mk_sc_rollup_timeout - | K_Sc_rollup_execute_outbox_message -> mk_sc_rollup_execute_outbox_message - | K_Sc_rollup_recover_bond -> mk_sc_rollup_return_bond - | K_Dal_publish_slot_header -> mk_dal_publish_slot_header - -let string_of_kind = function - | K_Transaction -> "Transaction" - | K_Delegation -> "Delegation" - | K_Undelegation -> "Undelegation" - | K_Self_delegation -> "Self-delegation" - | K_Set_deposits_limit -> "Set deposits limit" - | K_Origination -> "Origination" - | K_Register_global_constant -> "Register global constant" - | K_Increase_paid_storage -> "Increase paid storage" - | K_Reveal -> "Revelation" - | K_Tx_rollup_origination -> "Tx_rollup_origination" - | K_Tx_rollup_submit_batch -> "Tx_rollup_submit_batch" - | K_Tx_rollup_commit -> "Tx_rollup_commit" - | K_Tx_rollup_return_bond -> "Tx_rollup_return_bond" - | K_Tx_rollup_finalize -> "Tx_rollup_finalize" - | K_Tx_rollup_remove_commitment -> "Tx_rollup_remove_commitment" - | K_Tx_rollup_dispatch_tickets -> "Tx_rollup_dispatch_tickets" - | K_Tx_rollup_reject -> "Tx_rollup_reject" - | K_Transfer_ticket -> "Transfer_ticket" - | K_Sc_rollup_origination -> "Sc_rollup_origination" - | K_Sc_rollup_publish -> "Sc_rollup_publish" - | K_Sc_rollup_cement -> "Sc_rollup_cement" - | K_Sc_rollup_timeout -> "Sc_rollup_timeout" - | K_Sc_rollup_refute -> "Sc_rollup_refute" - | K_Sc_rollup_add_messages -> "Sc_rollup_add_messages" - | K_Sc_rollup_execute_outbox_message -> "Sc_rollup_execute_outbox_message" - | K_Sc_rollup_recover_bond -> "Sc_rollup_return_bond" - | K_Dal_publish_slot_header -> "Dal_publish_slot_header" - -let create_Tztest ?hd_msg test tests_msg operations = - let hd_msg k = - let sk = string_of_kind k in - match hd_msg with - | None -> sk - | Some hd -> Format.sprintf "Batch: %s, %s" hd sk - in - List.map - (fun kind -> - Tztest.tztest - (Format.sprintf "%s with %s" (hd_msg kind) tests_msg) - `Quick - (fun () -> test kind ())) - operations - -let rec create_Tztest_batches test tests_msg operations = - let hdmsg k = Format.sprintf "%s" (string_of_kind k) in - let aux hd_msg test operations = - create_Tztest ~hd_msg test tests_msg operations - in - match operations with - | [] -> [] - | kop :: kops as ops -> - aux (hdmsg kop) (test kop) ops @ create_Tztest_batches test tests_msg kops - -(* Diagnostic helpers. *) -(* The purpose of diagnostic helpers is to state the correct observation - according to the precheck result of a test. *) - -(* For a manager operation a [probes] contains the values required for observing - its precheck success. Its source, fees (sum for a batch), gas_limit - (sum of gas_limit of the batch), and the increment of the counters aka 1 for - a single operation, n for a batch of n manager operations. *) -type probes = { - source : Signature.Public_key_hash.t; - fee : Tez.tez; - gas_limit : Gas.Arith.integral; - nb_counter : Z.t; -} - -let rec contents_infos : - type kind. kind Kind.manager contents_list -> probes tzresult Lwt.t = - fun op -> - let open Lwt_result_syntax in - match op with - | Single (Manager_operation {source; fee; gas_limit; _}) -> - return {source; fee; gas_limit; nb_counter = Z.one} - | Cons (Manager_operation manop, manops) -> - let* probes = contents_infos manops in - let*? fee = manop.fee +? probes.fee in - let gas_limit = Gas.Arith.add probes.gas_limit manop.gas_limit in - let nb_counter = Z.succ probes.nb_counter in - let _ = Assert.equal_pkh ~loc:__LOC__ manop.source probes.source in - return {fee; source = probes.source; gas_limit; nb_counter} - -(* Computes a [probes] from a list of manager contents. *) -let manager_content_infos op = - let (Operation_data {contents; _}) = op.protocol_data in - match contents with - | Single (Manager_operation _) as op -> contents_infos op - | Cons (Manager_operation _, _) as op -> contents_infos op - | _ -> assert false - -(* [observe] asserts the success of precheck only. - Given on one side, a [contract], its initial balance [b_in], its initial - counter [c_in] and potentially the initial gas [g_in] before its prechecking; - and, on the other side, its [probes] and the context after its precheck [i]; - if precheck succeeds then we observe in [i] that: - - [contract] balance decreases by [probes.fee] when [only_precheck] marks that only the precheck - succeeds - - [contract] balance decreases at least by [probes.fee] when ![only_precheck] marks - that the application has succeeded, - - its counter [c_in] increases by [probes.nb_counter], and - - the available gas in the block in [i] decreases by [g_in].*) -let observe ~only_precheck contract b_in c_in g_in probes i = - let open Lwt_result_syntax in - let* b_out = Context.Contract.balance (I i) contract in - let g_out = Gas.block_level (Incremental.alpha_ctxt i) in - let* c_out = Context.Contract.counter (I i) contract in - let*? b_expected = b_in -? probes.fee in - let b_cmp = - Assert.equal - ~loc:__LOC__ - (if only_precheck then Tez.( = ) else Tez.( <= )) - "Balance update" - Tez.pp - in - let* _ = b_cmp b_out b_expected in - let c_expected = Z.add c_in probes.nb_counter in - let _ = - Assert.equal - Z.equal - ~loc:__LOC__ - "Counter incrementation" - Z.pp_print - c_out - c_expected - in - let g_expected = Gas.Arith.sub g_in (Gas.Arith.fp probes.gas_limit) in - Assert.equal - ~loc:__LOC__ - Gas.Arith.equal - "Gas consumption" - Gas.Arith.pp - g_out - g_expected - -let precheck_with_diagnostic ~only_precheck (infos : infos) op = - let open Lwt_result_syntax in - let* i = Incremental.begin_construction infos.block in - let* prbs = manager_content_infos op in - let contract = Contract.Implicit prbs.source in - let* b_in = Context.Contract.balance (I i) contract in - let* c_in = Context.Contract.counter (I i) contract in - let g_in = Gas.block_level (Incremental.alpha_ctxt i) in - let* i = Incremental.precheck_operation i op in - let* _ = Incremental.finalize_block i in - observe ~only_precheck contract b_in c_in g_in prbs i - -(* If only the precheck of an operation succeed; e.g. the rest - of the application failed: - - the fees must be paid, - - the block gas consumption should be decreased, and - - the counter of operation should be incremented - as defined by [observe] with [only_precheck]. *) -let only_precheck_diagnostic (infos : infos) op = - precheck_with_diagnostic ~only_precheck:true infos op - -(* If an manager operation application succeed, the precheck - effects must be observed: - - the fees must be paid, - - the block gas consumption should be decreased, and - - the counter of operation should be incremented - as defined by [observe] with ![only_precheck]. *) -let precheck_diagnostic (infos : infos) op = - precheck_with_diagnostic ~only_precheck:false infos op - -(* [precheck_ko_diagnostic] wraps the [expect_failure] when [op] precheck - failed. It is used in test that expects precheck [op] to fail. *) -let precheck_ko_diagnostic ?(mempool_mode = false) (infos : infos) op - expect_failure = - let open Lwt_result_syntax in - let* i = Incremental.begin_construction infos.block ~mempool_mode in - let* _ = Incremental.add_operation ~expect_failure i op in - return_unit - -(* List of operation kind that must run on generic tests. This list - should be extended for each new manager_operation kind. *) -let subjects = - [ - K_Transaction; - K_Origination; - K_Register_global_constant; - K_Delegation; - K_Undelegation; - K_Self_delegation; - K_Set_deposits_limit; - K_Increase_paid_storage; - K_Reveal; - K_Tx_rollup_origination; - K_Tx_rollup_submit_batch; - K_Tx_rollup_commit; - K_Tx_rollup_return_bond; - K_Tx_rollup_finalize; - K_Tx_rollup_remove_commitment; - K_Tx_rollup_dispatch_tickets; - K_Transfer_ticket; - K_Tx_rollup_reject; - K_Sc_rollup_origination; - K_Sc_rollup_publish; - K_Sc_rollup_cement; - K_Sc_rollup_add_messages; - K_Sc_rollup_refute; - K_Sc_rollup_timeout; - K_Sc_rollup_execute_outbox_message; - K_Sc_rollup_recover_bond; - K_Dal_publish_slot_header; - ] - -let is_consumer = function - | K_Set_deposits_limit | K_Increase_paid_storage | K_Reveal - | K_Self_delegation | K_Delegation | K_Undelegation | K_Tx_rollup_origination - | K_Tx_rollup_submit_batch | K_Tx_rollup_finalize | K_Tx_rollup_commit - | K_Tx_rollup_return_bond | K_Tx_rollup_remove_commitment | K_Tx_rollup_reject - | K_Sc_rollup_add_messages | K_Sc_rollup_origination | K_Sc_rollup_refute - | K_Sc_rollup_timeout | K_Sc_rollup_cement | K_Sc_rollup_publish - | K_Sc_rollup_execute_outbox_message | K_Sc_rollup_recover_bond - | K_Dal_publish_slot_header -> - false - | K_Transaction | K_Origination | K_Register_global_constant - | K_Tx_rollup_dispatch_tickets | K_Transfer_ticket -> - true - -let gas_consumer_in_precheck_subjects, not_gas_consumer_in_precheck_subjects = - List.partition is_consumer subjects - -let revealed_subjects = - List.filter (function K_Reveal -> false | _ -> true) subjects diff --git a/src/proto_014_PtKathma/lib_protocol/test/integration/precheck/test_manager_operation_precheck.ml b/src/proto_014_PtKathma/lib_protocol/test/integration/precheck/test_manager_operation_precheck.ml deleted file mode 100644 index 79831ff4c6082933472274884967fcabfde6bcb4..0000000000000000000000000000000000000000 --- a/src/proto_014_PtKathma/lib_protocol/test/integration/precheck/test_manager_operation_precheck.ml +++ /dev/null @@ -1,570 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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: Protocol (precheck manager) - Invocation: dune exec \ - src/proto_alpha/lib_protocol/test/integration/precheck/main.exe \ - -- test "^Single$" - Subject: Precheck manager operation. -*) - -open Protocol -open Alpha_context -open Manager_operation_helpers - -(* The goal of this test is to ensure that [select_op] generate the - wanted kind of manager operation - - Note: if a new manager operation kind is added in the protocol, - [Manager_operation_helpers.manager_operation_kind] should be - extended. You will also have to extend - [Manager_operation_helpers.select_op] with a new `mk` for this new - operation. Finally the list [Manager_operation_helpers.subjects] - should also be extended to run the precheck test on the new manager - operation kind. *) -let ensure_kind infos kind = - let open Lwt_result_syntax in - let* op = select_op kind infos ~force_reveal:false ~source:infos.contract1 in - let (Operation_data {contents; _}) = op.protocol_data in - match contents with - | Single (Manager_operation {operation; _}) -> ( - match (operation, kind) with - | Transaction _, K_Transaction - | Reveal _, K_Reveal - | Origination _, K_Origination - | Delegation _, K_Delegation - | Delegation _, K_Undelegation - | Delegation _, K_Self_delegation - | Register_global_constant _, K_Register_global_constant - | Set_deposits_limit _, K_Set_deposits_limit - | Increase_paid_storage _, K_Increase_paid_storage - | Tx_rollup_origination, K_Tx_rollup_origination - | Tx_rollup_submit_batch _, K_Tx_rollup_submit_batch - | Tx_rollup_commit _, K_Tx_rollup_commit - | Tx_rollup_return_bond _, K_Tx_rollup_return_bond - | Tx_rollup_finalize_commitment _, K_Tx_rollup_finalize - | Tx_rollup_remove_commitment _, K_Tx_rollup_remove_commitment - | Tx_rollup_rejection _, K_Tx_rollup_reject - | Tx_rollup_dispatch_tickets _, K_Tx_rollup_dispatch_tickets - | Transfer_ticket _, K_Transfer_ticket - | Sc_rollup_originate _, K_Sc_rollup_origination - | Sc_rollup_add_messages _, K_Sc_rollup_add_messages - | Sc_rollup_cement _, K_Sc_rollup_cement - | Sc_rollup_publish _, K_Sc_rollup_publish - | Sc_rollup_refute _, K_Sc_rollup_refute - | Sc_rollup_timeout _, K_Sc_rollup_timeout - | Sc_rollup_execute_outbox_message _, K_Sc_rollup_execute_outbox_message - | Sc_rollup_recover_bond _, K_Sc_rollup_recover_bond - | Dal_publish_slot_header _, K_Dal_publish_slot_header -> - return_unit - | ( ( Transaction _ | Origination _ | Register_global_constant _ - | Delegation _ | Set_deposits_limit _ | Increase_paid_storage _ - | Reveal _ | Tx_rollup_origination | Tx_rollup_submit_batch _ - | Tx_rollup_commit _ | Tx_rollup_return_bond _ - | Tx_rollup_finalize_commitment _ | Tx_rollup_remove_commitment _ - | Tx_rollup_dispatch_tickets _ | Transfer_ticket _ - | Tx_rollup_rejection _ | Sc_rollup_originate _ | Sc_rollup_publish _ - | Sc_rollup_cement _ | Sc_rollup_add_messages _ | Sc_rollup_refute _ - | Sc_rollup_timeout _ | Sc_rollup_execute_outbox_message _ - | Sc_rollup_recover_bond _ | Dal_publish_slot_header _ - | Sc_rollup_dal_slot_subscribe _ ), - _ ) -> - assert false) - | Single _ -> assert false - | Cons _ -> assert false - -let ensure_manager_operation_coverage () = - let open Lwt_result_syntax in - let* infos = init_context () in - List.iter_es (fun kind -> ensure_kind infos kind) subjects - -let test_ensure_manager_operation_coverage () = - Tztest.tztest - (Format.sprintf "Ensure manager_operation coverage") - `Quick - (fun () -> ensure_manager_operation_coverage ()) - -(* Negative tests assert the case where precheck must fail. *) - -(* Precheck fails if the gas limit is too low. - - This test asserts that the precheck of a manager's operation - with a too low gas limit fails at precheck with an - [Gas_quota_exceeded_init_deserialize] error. - This test applies on manager operations that do not - consume gas in their specific part of precheck. *) -let low_gas_limit_diagnostic (infos : infos) op = - let expect_failure errs = - match errs with - | [ - Environment.Ecoproto_error - Validate_operation.Manager.Gas_quota_exceeded_init_deserialize; - Environment.Ecoproto_error Raw_context.Operation_quota_exceeded; - ] -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - precheck_ko_diagnostic infos op expect_failure - -let test_low_gas_limit kind () = - let open Lwt_result_syntax in - let* infos = init_context () in - let gas_limit = Op.Low in - let* op = - select_op ~gas_limit ~force_reveal:true ~source:infos.contract1 kind infos - in - low_gas_limit_diagnostic infos op - -let generate_low_gas_limit () = - create_Tztest - test_low_gas_limit - "Gas_limit too low." - gas_consumer_in_precheck_subjects - -(* Precheck fails if the gas limit is too high. - - This test asserts that the precheck of a manager operation with - a gas limit too high fails at precheck with an [Gas_limit_too_high] - error. It applies on every kind of manager operation. *) -let high_gas_limit_diagnostic (infos : infos) op = - let expect_failure errs = - match errs with - | [Environment.Ecoproto_error Gas.Gas_limit_too_high] -> return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - precheck_ko_diagnostic infos op expect_failure - -let test_high_gas_limit kind () = - let open Lwt_result_syntax in - let* infos = init_context () in - let gas_limit = Op.Custom_gas (Gas.Arith.integral_of_int_exn 10_000_000) in - let* op = - select_op ~gas_limit ~force_reveal:true ~source:infos.contract1 kind infos - in - high_gas_limit_diagnostic infos op - -let generate_high_gas_limit () = - create_Tztest test_high_gas_limit "Gas_limit too high." subjects - -(* Precheck fails if the storage limit is too high. - - This test asserts that a manager operation with a storage limit - too high fails at precheck with [Storage_limit_too_high] error. - It applies to every kind of manager operation. *) -let high_storage_limit_diagnostic (infos : infos) op = - let expect_failure errs = - match errs with - | [Environment.Ecoproto_error Fees_storage.Storage_limit_too_high] -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - precheck_ko_diagnostic infos op expect_failure - -let test_high_storage_limit kind () = - let open Lwt_result_syntax in - let* infos = init_context () in - let storage_limit = Z.of_int max_int in - let* op = - select_op - ~storage_limit - ~force_reveal:true - ~source:infos.contract1 - kind - infos - in - high_storage_limit_diagnostic infos op - -let generate_high_storage_limit () = - create_Tztest test_high_gas_limit "Storage_limit too high." subjects - -(* Precheck fails if the counter is in the future. - - This test asserts that a manager operation with a counter in the - future -- aka greater than the successor of the manager's counter - stored in the current context -- fails with [Counter_in_the_future] error. - It applies to every kind of manager operation. *) -let high_counter_diagnostic (infos : infos) op = - let expect_failure errs = - match errs with - | [Environment.Ecoproto_error (Contract_storage.Counter_in_the_future _)] -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - precheck_ko_diagnostic infos op expect_failure - -let test_high_counter kind () = - let open Lwt_result_syntax in - let* infos = init_context () in - let counter = Z.of_int max_int in - let* op = - select_op ~counter ~force_reveal:true ~source:infos.contract1 kind infos - in - high_counter_diagnostic infos op - -let generate_high_counter () = - create_Tztest test_high_counter "Counter too high." subjects - -(* Precheck fails if the counter is in the past. - - This test asserts that a manager operation with a counter in the past -- aka - smaller than the successor of the manager's counter stored in the current - context -- fails with [Counter_in_the_past] error. - It applies to every kind of manager operation. *) -let low_counter_diagnostic (infos : infos) op = - let expect_failure errs = - match errs with - | [Environment.Ecoproto_error (Contract_storage.Counter_in_the_past _)] -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - precheck_ko_diagnostic infos op expect_failure - -let test_low_counter kind () = - let open Lwt_result_syntax in - let* infos = init_context () in - let* current_counter = - Context.Contract.counter (B infos.block) infos.contract1 - in - let counter = Z.sub current_counter Z.one in - let* op = - select_op ~counter ~force_reveal:true ~source:infos.contract1 kind infos - in - low_counter_diagnostic infos op - -let generate_low_counter () = - create_Tztest test_low_counter "Counter too low." subjects - -(* Precheck fails if the source is not allocated. - - This test asserts that a manager operation which manager's contract - is not allocated fails with [Empty_implicit_contract] error. - It applies on every kind of manager operation. *) -let not_allocated_diagnostic (infos : infos) op = - let expect_failure errs = - match errs with - | [Environment.Ecoproto_error (Contract_storage.Empty_implicit_contract _)] - -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - precheck_ko_diagnostic infos op expect_failure - -let test_not_allocated kind () = - let open Lwt_result_syntax in - let* infos = init_context () in - let* op = - select_op ~force_reveal:false ~source:(mk_fresh_contract ()) kind infos - in - not_allocated_diagnostic infos op - -let generate_not_allocated () = - create_Tztest test_not_allocated "not allocated source." subjects - -(* Precheck fails if the source is unrevealed. - - This test asserts that a manager operation with an unrevealed source's - contract fails at precheck with [Unrevealed_manager_key]. - It applies on every kind of manager operation except [Revelation]. *) -let unrevealed_key_diagnostic (infos : infos) op = - let expect_failure errs = - match errs with - | [ - Environment.Ecoproto_error - (Contract_manager_storage.Unrevealed_manager_key _); - ] -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - precheck_ko_diagnostic infos op expect_failure - -let test_unrevealed_key kind () = - let open Lwt_result_syntax in - let* infos = init_context () in - let* op = select_op ~force_reveal:false ~source:infos.contract1 kind infos in - unrevealed_key_diagnostic infos op - -let generate_unrevealed_key () = - create_Tztest - test_unrevealed_key - "unrevealed source (find_manager_public_key)." - revealed_subjects - -(* Precheck fails if the source's balance is not enough to pay the fees. - - This test asserts that precheck of a manager operation fails if the - source's balance is lesser than the manager operation's fee. - It applies on every kind of manager operation. *) -let high_fee_diagnostic (infos : infos) op = - let expect_failure errs = - match errs with - | [ - Environment.Ecoproto_error (Contract_storage.Balance_too_low _); - Environment.Ecoproto_error (Tez_repr.Subtraction_underflow _); - ] -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - precheck_ko_diagnostic infos op expect_failure - -let test_high_fee kind () = - let open Lwt_result_syntax in - let* infos = init_context () in - let*? fee = Tez.(one +? one) |> Environment.wrap_tzresult in - let* op = - select_op ~fee ~force_reveal:true ~source:infos.contract1 kind infos - in - high_fee_diagnostic infos op - -let generate_tests_high_fee () = - create_Tztest test_high_fee "not enough for fee payment." subjects - -(* Precheck fails if the fee payment empties the balance of a - delegated implicit contract. - - This test asserts that in case that: - - the source is a delegated implicit contract, and - - the fee is the exact balance of source. - then, precheck fails with [Empty_implicit_delegated_contract] error. - It applies to every kind of manager operation except [Revelation].*) -let emptying_delegated_implicit_diagnostic (infos : infos) op = - let expect_failure errs = - match errs with - | [ - Environment.Ecoproto_error - (Contract_storage.Empty_implicit_delegated_contract _); - ] -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - precheck_ko_diagnostic infos op expect_failure - -let test_emptying_delegated_implicit kind () = - let open Lwt_result_syntax in - let* infos = init_delegated_implicit () in - let* fee = Context.Contract.balance (B infos.block) infos.contract1 in - let* op = - select_op ~fee ~force_reveal:false ~source:infos.contract1 kind infos - in - emptying_delegated_implicit_diagnostic infos op - -let generate_tests_emptying_delegated_implicit () = - create_Tztest - test_emptying_delegated_implicit - "just enough funds to empty a delegated source." - revealed_subjects - -(* Precheck fails if there is not enough available gas in the block. - - This test asserts that precheck fails with: - - [Gas_limit_too_high;Block_quota_exceeded] in mempool mode, - | [Block_quota_exceeded] in other mode - with gas limit exceeds the available gas in the block. - It applies to every kind of manager operation. *) -let exceeding_block_gas_diagnostic ~mempool_mode (infos : infos) op = - let expect_failure errs = - match errs with - | [Environment.Ecoproto_error Gas.Block_quota_exceeded] - when not mempool_mode -> - return_unit - | [ - Environment.Ecoproto_error Gas.Gas_limit_too_high; - Environment.Ecoproto_error Gas.Block_quota_exceeded; - ] - when mempool_mode -> - (* In mempool_mode, batch that exceed [operation_gas_limit] needs - to be refused. [Gas.Block_quota_exceeded] only return a - temporary error. [Gas.Gas_limit_too_high], which is a - permanent error, is added to the error trace to ensure that - the batch is refused. *) - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - precheck_ko_diagnostic infos op expect_failure ~mempool_mode - -let test_exceeding_block_gas ~mempool_mode kind () = - let open Lwt_result_syntax in - let* infos = init_context ~hard_gas_limit_per_block:gb_limit () in - let gas_limit = - Op.Custom_gas (Gas.Arith.add gb_limit Gas.Arith.(integral_of_int_exn 1)) - in - let* operation = - select_op ~force_reveal:true ~source:infos.contract1 ~gas_limit kind infos - in - exceeding_block_gas_diagnostic ~mempool_mode infos operation - -let generate_tests_exceeding_block_gas () = - create_Tztest - (test_exceeding_block_gas ~mempool_mode:false) - "too much gas consumption." - subjects - -let generate_tests_exceeding_block_gas_mp_mode () = - create_Tztest - (test_exceeding_block_gas ~mempool_mode:true) - "too much gas consumption in mempool mode." - subjects - -(* Positive tests. - - Tests that precheck succeeds when: - - it empties the balance of a self_delegated implicit source, - - it empties the balance of an undelegated implicit source, and - - in case: - - the counter is the successor of the one stored in the context, - - the fee is lesser than the balance, - - the storage limit is lesser than the maximum authorized storage, - - the gas limit is: - - lesser than the available gas in the block, - - less than the maximum gas consumable by an operation, and - - greater than the minimum gas consumable by an operation. - Notice that the first two only precheck succeeds while in the last case, - the full application also succeeds. - In the first 2 case, we observe in the output context that: - - the counter is the successor of the one stored in the initial context, - - the balance decreased by fee, - - the available gas in the block decreased by gas limit. - In the last case, we observe in the output context that: - - the counter is the successor of the one stored in the initial context, - - the balance is at least decreased by fee, - - the available gas in the block decreased by gas limit. *) - -(* Fee payment that emptying a self_delegated implicit. *) -let test_emptying_self_delegated_implicit kind () = - let open Lwt_result_syntax in - let* infos = init_self_delegated_implicit () in - let* fee = Context.Contract.balance (B infos.block) infos.contract1 in - let* op = - select_op ~fee ~force_reveal:false ~source:infos.contract1 kind infos - in - only_precheck_diagnostic infos op - -let generate_tests_emptying_self_delegated_implicit () = - create_Tztest - test_emptying_self_delegated_implicit - "passes precheck and empties a self-delegated source." - subjects - -(* Minimum gas cost to pass the precheck: - - cost_of_manager_operation for the generic part - - 100 (empiric) for the specific part (script decoding or hash costs) *) -let empiric_minimal_gas_cost_for_precheck = - Gas.Arith.integral_of_int_exn - (Michelson_v1_gas.Internal_for_tests.int_cost_of_manager_operation + 100) - -let test_emptying_undelegated_implicit kind () = - let open Lwt_result_syntax in - let* infos = init_context () in - let gas_limit = Op.Custom_gas empiric_minimal_gas_cost_for_precheck in - let* fee = Context.Contract.balance (B infos.block) infos.contract1 in - let* op = - select_op - ~fee - ~gas_limit - ~force_reveal:true - ~source:infos.contract1 - kind - infos - in - only_precheck_diagnostic infos op - -let generate_tests_emptying_undelegated_implicit () = - create_Tztest - test_emptying_undelegated_implicit - "passes precheck and empties an undelegated source." - subjects - -(* Fee payment.*) -let test_precheck kind () = - let open Lwt_result_syntax in - let* infos = init_context () in - let* counter = Context.Contract.counter (B infos.block) infos.contract1 in - let source = infos.contract1 in - let* operation = select_op ~counter ~force_reveal:true ~source kind infos in - precheck_diagnostic infos operation - -let generate_tests_precheck () = - create_Tztest test_precheck "passes precheck." subjects - -let sanity_tests = - test_ensure_manager_operation_coverage () :: generate_tests_precheck () - -let gas_tests = - generate_low_gas_limit () @ generate_high_gas_limit () - @ generate_tests_exceeding_block_gas () - @ generate_tests_exceeding_block_gas_mp_mode () - -let storage_tests = generate_high_storage_limit () - -let fee_tests = - generate_tests_high_fee () - @ generate_tests_emptying_delegated_implicit () - @ generate_tests_emptying_self_delegated_implicit () - @ generate_tests_emptying_undelegated_implicit () - -let contract_tests = - generate_high_counter () @ generate_low_counter () @ generate_not_allocated () - @ generate_unrevealed_key () diff --git a/src/proto_014_PtKathma/lib_protocol/test/integration/precheck/dune b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/dune similarity index 77% rename from src/proto_014_PtKathma/lib_protocol/test/integration/precheck/dune rename to src/proto_014_PtKathma/lib_protocol/test/integration/validate/dune index 0aab47b27e377d06c26e46f4f89dd3ac836a5d58..9e56b2994a37280604b29ba4365b31f710a8ce2a 100644 --- a/src/proto_014_PtKathma/lib_protocol/test/integration/precheck/dune +++ b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/dune @@ -1,12 +1,13 @@ ; This file was automatically generated, do not edit. ; Edit file manifest/main.ml instead. -(executable - (name main) +(executables + (names main test_1m_restriction) (libraries alcotest-lwt tezos-base tezos-protocol-014-PtKathma + qcheck-alcotest tezos-client-014-PtKathma tezos-014-PtKathma-test-helpers tezos-base-test-helpers) @@ -23,3 +24,8 @@ (alias runtest) (package tezos-protocol-014-PtKathma-tests) (action (run %{dep:./main.exe}))) + +(rule + (alias runtest) + (package tezos-protocol-014-PtKathma-tests) + (action (run %{dep:./test_1m_restriction.exe}))) diff --git a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/generators.ml b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/generators.ml new file mode 100644 index 0000000000000000000000000000000000000000..dd40f8c10039719726fa31e63a3c2592ca785ec0 --- /dev/null +++ b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/generators.ml @@ -0,0 +1,263 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +open Protocol +open Alpha_context +open Manager_operation_helpers + +let lwt_run f = + match Lwt_main.run f with + | Error err -> + QCheck.Test.fail_reportf "@.Lwt_main.run error: %a@." pp_print_trace err + | Ok v -> v + +(** {2 Datatypes} *) + +(** Constraints on generated values. + + {ul + {li [Free] states that nothing has to be generated} + + {li [Pure n] generate n} + + {li [Less {n;origin}] (resp Greater) states the expected + constraints for the generated values that must be lesser (resp + greater) than [n] and shrink toward [origin] in case of error} + + {li [Range {min;max;origin}] states the expected constraints for + the generated values that must be between [min] and [max] and + shrink toward [origin] in case of error.}} *) +type cstrs = + | Free + | Pure of int + | Less of {n : int; origin : int} + | Greater of {n : int; origin : int} + | Range of {min : int; max : int; origin : int} + +(** Gas frequency. *) +type gas_freq = { + low : int; + max : int; + high : int; + zero : int; + custom : int * cstrs; +} + +(** Operation constraints. *) +type operation_cstrs = { + counter : cstrs; + fee : cstrs; + gas_limit : gas_freq; + storage_limit : cstrs; + force_reveal : bool option; + amount : cstrs; +} + +(** Context constraints. *) +type ctxt_cstrs = { + hard_gas_limit_per_block : cstrs; + src_cstrs : cstrs; + dest_cstrs : cstrs; + del_cstrs : cstrs; + tx_cstrs : cstrs; + sc_cstrs : cstrs; +} +(** {2 Default values} *) + +(** Default constraint. *) +let default_cstrs = Free + +(** Default gas frequency. *) +let default_gas_freq = + {low = 0; max = 0; high = 1; zero = 0; custom = (0, Free)} + +(** Default constraints for operation. *) +let default_operation_cstrs = + { + counter = default_cstrs; + fee = default_cstrs; + gas_limit = default_gas_freq; + storage_limit = default_cstrs; + force_reveal = None; + amount = default_cstrs; + } + +(** Default constraints for context. *) +let default_ctxt_cstrs = + { + hard_gas_limit_per_block = default_cstrs; + src_cstrs = default_cstrs; + dest_cstrs = default_cstrs; + del_cstrs = default_cstrs; + tx_cstrs = default_cstrs; + sc_cstrs = default_cstrs; + } + +(** {2 Generators} *) + +(** Generator of positive integers. *) +let gen_pos : cstrs -> int option QCheck2.Gen.t = + fun c -> + let open QCheck2.Gen in + match c with + | Free -> pure None + | Pure n -> pure (Some n) + | Less {n; origin} -> + let+ v = int_range ~origin 0 n in + Some v + | Greater {n; origin} -> + let+ v = int_range ~origin n max_int in + Some v + | Range {min; max; origin} -> + let+ v = int_range ~origin min max in + Some v + +(** Generator for Z.t that is used for counter and gas limit. *) +let gen_z : cstrs -> Z.t option QCheck2.Gen.t = + fun cstrs -> + let open QCheck2.Gen in + let+ v = gen_pos cstrs in + Option.map Z.of_int v + +(** Generator for Tez.t. *) +let gen_tez : cstrs -> Tez.t option QCheck2.Gen.t = + fun cstrs -> + let open QCheck2.Gen in + let+ amount = gen_pos cstrs in + match amount with + | Some amount -> + let amount = Int64.of_int amount in + Tez.of_mutez amount + | None -> None + +(** Generator for gas integral. *) +let gen_gas_integral : cstrs -> Gas.Arith.integral option QCheck2.Gen.t = + fun cstrs -> + let open QCheck2.Gen in + let+ v = gen_pos cstrs in + Option.map Gas.Arith.integral_of_int_exn v + +(** Generator for Op.gas_limit. *) +let gen_gas_limit : gas_freq -> Op.gas_limit option QCheck2.Gen.t = + fun gas_freq -> + let open QCheck2.Gen in + frequency + [ + (gas_freq.low, return (Some Op.Low)); + (gas_freq.max, return (Some Op.Max)); + (gas_freq.high, return (Some Op.High)); + (gas_freq.zero, return (Some Op.Zero)); + (let freq, cstrs = gas_freq.custom in + ( freq, + let+ gas = gen_gas_integral cstrs in + match gas with None -> None | Some g -> Some (Op.Custom_gas g) )); + ] + +(** Generator for manager_operation_kind. *) +let gen_kind : + manager_operation_kind list -> manager_operation_kind QCheck2.Gen.t = + fun subjects -> QCheck2.Gen.oneofl subjects + +(** Generator for mode. *) +let gen_mode : mode QCheck2.Gen.t = + QCheck2.Gen.oneofl [Construction; Mempool; Application] + +(** Generator for operation requirements. *) +let gen_operation_req : + operation_cstrs -> + manager_operation_kind list -> + operation_req QCheck2.Gen.t = + fun {counter; fee; gas_limit; storage_limit; force_reveal; amount} subjects -> + let open QCheck2.Gen in + let* kind = gen_kind subjects in + let* counter = gen_z counter in + let* fee = gen_tez fee in + let* gas_limit = gen_gas_limit gas_limit in + let* storage_limit = gen_z storage_limit in + let+ amount = gen_tez amount in + {kind; counter; fee; gas_limit; storage_limit; force_reveal; amount} + +(** Generator for a pair of operations with the same source and + sequential counters.*) +let gen_2_operation_req : + operation_cstrs -> + manager_operation_kind list -> + (operation_req * operation_req) QCheck2.Gen.t = + fun op_cstrs subjects -> + let open QCheck2.Gen in + let* op1 = + gen_operation_req {op_cstrs with force_reveal = Some true} subjects + in + let counter = match op1.counter with Some x -> Z.to_int x | None -> 1 in + let op_cstr = + { + {op_cstrs with counter = Pure (counter + 2)} with + force_reveal = Some false; + } + in + let+ op2 = gen_operation_req op_cstr subjects in + (op1, op2) + +(** Generator for context requirement. *) +let gen_ctxt_req : ctxt_cstrs -> ctxt_req QCheck2.Gen.t = + fun { + hard_gas_limit_per_block; + src_cstrs; + dest_cstrs; + del_cstrs; + tx_cstrs; + sc_cstrs; + } -> + let open QCheck2.Gen in + let* hard_gas_limit_per_block = gen_gas_integral hard_gas_limit_per_block in + let* fund_src = gen_tez src_cstrs in + let* fund_dest = gen_tez dest_cstrs in + let* fund_del = gen_tez del_cstrs in + let* fund_tx = gen_tez tx_cstrs in + let+ fund_sc = gen_tez sc_cstrs in + { + hard_gas_limit_per_block; + fund_src; + fund_dest; + fund_del; + fund_tx; + fund_sc; + flags = all_enabled; + } + +(** {2 Wrappers} *) + +let wrap ~name ?print ?count ?check ~(gen : 'a QCheck2.Gen.t) + (f : 'a -> bool tzresult Lwt.t) = + Lib_test.Qcheck2_helpers.qcheck_make_result + ~name + ?print + ?count + ?check + ~pp_error:pp_print_trace + ~gen + (fun a -> Lwt_main.run (f a)) + +let wrap_mode infos op mode = validate_diagnostic ~mode infos op diff --git a/src/proto_014_PtKathma/lib_protocol/test/integration/precheck/main.ml b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/main.ml similarity index 69% rename from src/proto_014_PtKathma/lib_protocol/test/integration/precheck/main.ml rename to src/proto_014_PtKathma/lib_protocol/test/integration/validate/main.ml index 9e58c8ee0a29d40a59b7ffd8ee1f32ee950b930d..1f6fca58d06a9fc3ef1887bec073a0f513d9cf51 100644 --- a/src/proto_014_PtKathma/lib_protocol/test/integration/precheck/main.ml +++ b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/main.ml @@ -26,22 +26,27 @@ (** Testing ------- Component: Protocol - Invocation: dune runtest src/proto_alpha/lib_protocol/test/integration/precheck - Subject: Integration > Precheck + Invocation: dune runtest src/proto_014_PtKathma/lib_protocol/test/integration/validate + Subject: Integration > Validate *) let () = Alcotest_lwt.run - "protocol > integration > precheck" + "protocol > integration > validate" [ - ("sanity checks", Test_manager_operation_precheck.sanity_tests); - ("Single: gas checks", Test_manager_operation_precheck.gas_tests); - ("Single: storage checks", Test_manager_operation_precheck.storage_tests); - ("Single: fees checks", Test_manager_operation_precheck.fee_tests); - ("Single: contract checks", Test_manager_operation_precheck.contract_tests); + ("sanity checks", Test_manager_operation_validation.sanity_tests); + ("Single: gas checks", Test_manager_operation_validation.gas_tests); + ("Single: storage checks", Test_manager_operation_validation.storage_tests); + ("Single: fees checks", Test_manager_operation_validation.fee_tests); + ( "Single: contract checks", + Test_manager_operation_validation.contract_tests ); ( "Batched: contract checks", - Test_batched_manager_operation_precheck.contract_tests ); - ("Batched: gas checks", Test_batched_manager_operation_precheck.gas_tests); - ("Batched: fees checks", Test_batched_manager_operation_precheck.fee_tests); + Test_batched_manager_operation_validation.contract_tests ); + ( "Batched: gas checks", + Test_batched_manager_operation_validation.gas_tests ); + ( "Batched: fees checks", + Test_batched_manager_operation_validation.fee_tests ); + ( "Flags: feature flag checks", + Test_manager_operation_validation.flags_tests ); ] |> Lwt_main.run diff --git a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/manager_operation_helpers.ml b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/manager_operation_helpers.ml new file mode 100644 index 0000000000000000000000000000000000000000..25fb7cac301f3448fab69d82b3e810223484b957 --- /dev/null +++ b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/manager_operation_helpers.ml @@ -0,0 +1,1405 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +open Protocol +open Alpha_context +open Test_tez + +(** {2 Constants} *) + +(** Hard gas limit *) + +let gb_limit = Gas.Arith.(integral_of_int_exn 100_000) + +let half_gb_limit = Gas.Arith.(integral_of_int_exn 50_000) + +(** {2 Datatypes} *) + +(** Context abstraction in a test. *) +type ctxt = { + block : Block.t; + originated_contract : Contract_hash.t; + tx_rollup : Tx_rollup.t option; + sc_rollup : Sc_rollup.t option; +} + +(** Accounts manipulated in the tests. + By convention, each field name specifies the role + of the account in a test. It is the case in most of the tests. + In smart contructors of operations, it happens that in impossible case, + [source] is used as a dummy value. + In some test that requires a second source, [del] will be used as the second + source. *) +type accounts = { + source : Account.t; + dest : Account.t option; + del : Account.t option; + tx : Account.t option; + sc : Account.t option; +} + +(** Infos describes the information of the setting for a test: the + context and used accounts. *) +type infos = {ctxt : ctxt; accounts : accounts} + +(** This type should be extended for each new manager_operation kind + added in the protocol. See + [test_manager_operation_validation.ensure_kind] for more + information on how we ensure that this type is extended for each + new manager_operation kind. *) +type manager_operation_kind = + | K_Transaction + | K_Origination + | K_Register_global_constant + | K_Delegation + | K_Undelegation + | K_Self_delegation + | K_Set_deposits_limit + | K_Reveal + | K_Increase_paid_storage + | K_Tx_rollup_origination + | K_Tx_rollup_submit_batch + | K_Tx_rollup_commit + | K_Tx_rollup_return_bond + | K_Tx_rollup_finalize + | K_Tx_rollup_remove_commitment + | K_Tx_rollup_dispatch_tickets + | K_Transfer_ticket + | K_Tx_rollup_reject + | K_Sc_rollup_origination + | K_Sc_rollup_publish + | K_Sc_rollup_cement + | K_Sc_rollup_add_messages + | K_Sc_rollup_refute + | K_Sc_rollup_timeout + | K_Sc_rollup_execute_outbox_message + | K_Sc_rollup_recover_bond + | K_Dal_publish_slot_header + +(** The requirements for a tested manager operation. *) +type operation_req = { + kind : manager_operation_kind; + counter : counter option; + fee : Tez.t option; + gas_limit : Op.gas_limit option; + storage_limit : counter option; + force_reveal : bool option; + amount : Tez.t option; +} + +(** Feature flags requirements for a context setting for a test. *) +type feature_flags = {dal : bool; scoru : bool; toru : bool} + +(** The requirements for a context setting for a test. *) +type ctxt_req = { + hard_gas_limit_per_block : Gas.Arith.integral option; + fund_src : Tez.t option; + fund_dest : Tez.t option; + fund_del : Tez.t option; + fund_tx : Tez.t option; + fund_sc : Tez.t option; + flags : feature_flags; +} + +(** Validation mode. + + FIXME: https://gitlab.com/tezos/tezos/-/issues/3365 + This type should be replaced by the one defined + in validation, type mode in `validate_operation`, when it would + include the distinction between Contruction and Application. *) +type mode = Construction | Mempool | Application + +(** {2 Default values} *) +let all_enabled = {dal = true; scoru = true; toru = true} + +let disabled_dal = {all_enabled with dal = false} + +let disabled_scoru = {all_enabled with scoru = false} + +let disabled_toru = {all_enabled with toru = false} + +let ctxt_req_default_to_flag flags = + { + hard_gas_limit_per_block = None; + fund_src = Some Tez.one; + fund_dest = Some Tez.one; + fund_del = Some Tez.one; + fund_tx = Some Tez.one; + fund_sc = Some Tez.one; + flags; + } + +let ctxt_req_default = ctxt_req_default_to_flag all_enabled + +let operation_req_default kind = + { + kind; + counter = None; + fee = None; + gas_limit = None; + storage_limit = None; + force_reveal = None; + amount = None; + } + +(** {2 String of datatypes} *) + +let kind_to_string = function + | K_Transaction -> "Transaction" + | K_Delegation -> "Delegation" + | K_Undelegation -> "Undelegation" + | K_Self_delegation -> "Self-delegation" + | K_Set_deposits_limit -> "Set deposits limit" + | K_Origination -> "Origination" + | K_Register_global_constant -> "Register global constant" + | K_Reveal -> "Revelation" + | K_Increase_paid_storage -> "Increase paid storage" + | K_Tx_rollup_origination -> "Tx_rollup_origination" + | K_Tx_rollup_submit_batch -> "Tx_rollup_submit_batch" + | K_Tx_rollup_commit -> "Tx_rollup_commit" + | K_Tx_rollup_return_bond -> "Tx_rollup_return_bond" + | K_Tx_rollup_finalize -> "Tx_rollup_finalize" + | K_Tx_rollup_remove_commitment -> "Tx_rollup_remove_commitment" + | K_Tx_rollup_dispatch_tickets -> "Tx_rollup_dispatch_tickets" + | K_Tx_rollup_reject -> "Tx_rollup_reject" + | K_Transfer_ticket -> "Transfer_ticket" + | K_Sc_rollup_origination -> "Sc_rollup_origination" + | K_Sc_rollup_publish -> "Sc_rollup_publish" + | K_Sc_rollup_cement -> "Sc_rollup_cement" + | K_Sc_rollup_timeout -> "Sc_rollup_timeout" + | K_Sc_rollup_refute -> "Sc_rollup_refute" + | K_Sc_rollup_add_messages -> "Sc_rollup_add_messages" + | K_Sc_rollup_execute_outbox_message -> "Sc_rollup_execute_outbox_message" + | K_Sc_rollup_recover_bond -> "Sc_rollup_recover_bond" + | K_Dal_publish_slot_header -> "Dal_publish_slot_header" + +(** {2 Pretty-printers} *) +let pp_opt pp v = + let open Format in + pp_print_option ~none:(fun fmt () -> fprintf fmt "None") pp v + +let pp_operation_req pp + {kind; counter; fee; gas_limit; storage_limit; force_reveal; amount} = + Format.fprintf + pp + "@[Operation_req:@,\ + kind: %s@,\ + counter: %a@,\ + fee: %a@,\ + gas_limit: %a@,\ + storage_limit: %a@,\ + force_reveal: %a@,\ + amount: %a@,\ + @]" + (kind_to_string kind) + (pp_opt Z.pp_print) + counter + (pp_opt Tez.pp) + fee + (pp_opt Op.pp_gas_limit) + gas_limit + (pp_opt Z.pp_print) + storage_limit + (pp_opt (fun fmt -> Format.fprintf fmt "%b")) + force_reveal + (pp_opt Tez.pp) + amount + +let pp_2_operation_req pp (op_req1, op_req2) = + Format.fprintf + pp + "[ %a,@ and %a,@ @]" + pp_operation_req + op_req1 + pp_operation_req + op_req2 + +let pp_ctxt_req pp + { + hard_gas_limit_per_block; + fund_src; + fund_dest; + fund_del; + fund_tx; + fund_sc; + flags; + } = + Format.fprintf + pp + "@[Ctxt_req:@,\ + hard_gas_limit_per_block:%a@,\ + fund_src: %a tz@,\ + fund_dest: %a tz@,\ + fund_del: %a tz@,\ + fund_tx: %a tz@,\ + fund_sc: %a tz@,\ + dal_flag: %a@,\ + scoru_flag: %a@,\ + toru_flag: %a@,\ + @]" + (pp_opt Gas.Arith.pp_integral) + hard_gas_limit_per_block + (pp_opt Tez.pp) + fund_src + (pp_opt Tez.pp) + fund_dest + (pp_opt Tez.pp) + fund_del + (pp_opt Tez.pp) + fund_tx + (pp_opt Tez.pp) + fund_sc + Format.pp_print_bool + flags.dal + Format.pp_print_bool + flags.scoru + Format.pp_print_bool + flags.toru + +let pp_mode pp = function + | Construction -> Format.fprintf pp "Construction" + | Mempool -> Format.fprintf pp "Mempool" + | Application -> Format.fprintf pp "Block" + +(** {2 Short-cuts} *) +let contract_of (account : Account.t) = Contract.Implicit account.pkh + +(** Make a [mempool_mode], aka a boolean, as used in incremental from + a [mode]. *) +let mempool_mode_of = function Mempool -> true | _ -> false + +let get_pk infos source = + let open Lwt_result_syntax in + let+ account = Context.Contract.manager infos source in + account.pk + +(** Operation for specific context. *) +let self_delegate block pkh = + let open Lwt_result_syntax in + let contract = Contract.Implicit pkh in + let* operation = + Op.delegation ~force_reveal:true (B block) contract (Some pkh) + in + let* block = Block.bake block ~operation in + let* del_opt_new = Context.Contract.delegate_opt (B block) contract in + let* del = Assert.get_some ~loc:__LOC__ del_opt_new in + let+ _ = Assert.equal_pkh ~loc:__LOC__ del pkh in + block + +let delegation block delegator delegate = + let open Lwt_result_syntax in + let delegate_pkh = delegate.Account.pkh in + let contract_delegator = contract_of delegator in + let contract_delegate = contract_of delegate in + let* operation = + Op.delegation + ~force_reveal:true + (B block) + contract_delegate + (Some delegate_pkh) + in + let* block = Block.bake block ~operation in + let* operation = + Op.delegation + ~force_reveal:true + (B block) + contract_delegator + (Some delegate_pkh) + in + let* block = Block.bake block ~operation in + let* del_opt_new = + Context.Contract.delegate_opt (B block) contract_delegator + in + let* del = Assert.get_some ~loc:__LOC__ del_opt_new in + let+ _ = Assert.equal_pkh ~loc:__LOC__ del delegate_pkh in + block + +let originate_tx_rollup block rollup_account = + let open Lwt_result_syntax in + let rollup_contract = contract_of rollup_account in + let* rollup_origination, tx_rollup = + Op.tx_rollup_origination ~force_reveal:true (B block) rollup_contract + in + let+ block = Block.bake ~operation:rollup_origination block in + (block, tx_rollup) + +let originate_sc_rollup block rollup_account = + let open Lwt_result_syntax in + let rollup_contract = contract_of rollup_account in + let* rollup_origination, sc_rollup = + Op.sc_rollup_origination + ~force_reveal:true + (B block) + rollup_contract + Sc_rollup.Kind.Example_arith + "" + (Script.lazy_expr (Expr.from_string "1")) + in + let+ block = Block.bake ~operation:rollup_origination block in + (block, sc_rollup) + +(** {2 Setting's context construction} *) + +let fund_account block bootstrap account fund = + let open Lwt_result_syntax in + let* counter = Context.Contract.counter (B block) bootstrap in + let* fund = + match fund with + | None -> return Tez.one + | Some fund -> + let* source_balance = Context.Contract.balance (B block) bootstrap in + if Tez.(fund > source_balance) then + Lwt.return (Environment.wrap_tzresult Tez.(source_balance -? one)) + else return fund + in + let* operation = + Op.transaction + ~counter + ~gas_limit:Op.High + (B block) + bootstrap + (Contract.Implicit account) + fund + in + let*! b = Block.bake ~operation block in + match b with Error _ -> failwith "Funding account error" | Ok b -> return b + +(** The generic setting for a test is built up according to a context + requirement. It provides a context and accounts where the accounts + have been created and funded according to the context + requirements.*) +let init_ctxt : ctxt_req -> infos tzresult Lwt.t = + fun { + hard_gas_limit_per_block; + fund_src; + fund_dest; + fund_del; + fund_tx; + fund_sc; + flags; + } -> + let open Lwt_result_syntax in + let create_and_fund ?originate_rollup block bootstrap fund = + match fund with + | None -> return (block, None, None) + | Some _ -> + let account = Account.new_account () in + let* block = fund_account block bootstrap account.pkh fund in + let+ block, rollup = + match originate_rollup with + | None -> return (block, None) + | Some f -> + let+ block, rollup = f block account in + (block, Some rollup) + in + (block, Some account, rollup) + in + let* block, bootstraps = + Context.init_n + 6 + ~consensus_threshold:0 + ?hard_gas_limit_per_block + ~tx_rollup_enable:flags.toru + ~tx_rollup_sunset_level:Int32.max_int + ~sc_rollup_enable:flags.scoru + ~dal_enable:flags.dal + () + in + let get_bootstrap bootstraps n = Stdlib.List.nth bootstraps n in + let source = Account.new_account () in + let* block = + fund_account block (get_bootstrap bootstraps 0) source.pkh fund_src + in + let* block, dest, _ = + create_and_fund block (get_bootstrap bootstraps 1) fund_dest + in + let* block, del, _ = + create_and_fund block (get_bootstrap bootstraps 2) fund_del + in + let* block, tx, tx_rollup = + if flags.toru then + create_and_fund + ~originate_rollup:(fun infos account -> + originate_tx_rollup infos account) + block + (get_bootstrap bootstraps 3) + fund_tx + else return (block, None, None) + in + let* block, sc, sc_rollup = + if flags.scoru then + create_and_fund + ~originate_rollup:(fun infos account -> + originate_sc_rollup infos account) + block + (get_bootstrap bootstraps 4) + fund_sc + else return (block, None, None) + in + let* create_contract_hash, originated_contract = + Op.contract_origination_hash + (B block) + (get_bootstrap bootstraps 5) + ~fee:Tez.zero + ~script:Op.dummy_script + in + let+ block = Block.bake ~operation:create_contract_hash block in + let ctxt = {block; originated_contract; tx_rollup; sc_rollup} in + {ctxt; accounts = {source; dest; del; tx; sc}} + +(** In addition of building up a context according to a context + requirement, source is self-delegated. + + See [init_ctxt] description. *) +let ctxt_with_self_delegation : ctxt_req -> infos tzresult Lwt.t = + fun ctxt_req -> + let open Lwt_result_syntax in + let* infos = init_ctxt ctxt_req in + let+ block = self_delegate infos.ctxt.block infos.accounts.source.pkh in + let ctxt = {infos.ctxt with block} in + {infos with ctxt} + +(** In addition of building up a context accordning to a context + requirement, source delegates to del. + + See [init_ctxt] description. *) +let ctxt_with_delegation : ctxt_req -> infos tzresult Lwt.t = + fun ctxt_req -> + let open Lwt_result_syntax in + let* infos = init_ctxt ctxt_req in + let* delegate = + match infos.accounts.del with + | None -> failwith "Delegate account should be funded" + | Some a -> return a + in + let+ block = delegation infos.ctxt.block infos.accounts.source delegate in + let ctxt = {infos.ctxt with block} in + {infos with ctxt} + +let default_init_ctxt () = init_ctxt ctxt_req_default + +let default_init_with_flags flags = init_ctxt (ctxt_req_default_to_flag flags) + +let default_ctxt_with_self_delegation () = + ctxt_with_self_delegation ctxt_req_default + +let default_ctxt_with_delegation () = ctxt_with_delegation ctxt_req_default + +(** {2 Smart constructors} *) + +(** Smart contructors to forge manager operations according to + operation requirements in a test setting. *) + +let mk_transaction (oinfos : operation_req) (infos : infos) = + Op.transaction + ?force_reveal:oinfos.force_reveal + ?counter:oinfos.counter + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?storage_limit:oinfos.storage_limit + (B infos.ctxt.block) + (contract_of infos.accounts.source) + (contract_of + (match infos.accounts.dest with + | None -> infos.accounts.source + | Some dest -> dest)) + (match oinfos.amount with None -> Tez.zero | Some amount -> amount) + +let mk_delegation (oinfos : operation_req) (infos : infos) = + Op.delegation + ?force_reveal:oinfos.force_reveal + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + (B infos.ctxt.block) + (contract_of infos.accounts.source) + (Some + (match infos.accounts.del with + | None -> infos.accounts.source.pkh + | Some delegate -> delegate.pkh)) + +let mk_undelegation (oinfos : operation_req) (infos : infos) = + Op.delegation + ?force_reveal:oinfos.force_reveal + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + (B infos.ctxt.block) + (contract_of infos.accounts.source) + None + +let mk_self_delegation (oinfos : operation_req) (infos : infos) = + Op.delegation + ?force_reveal:oinfos.force_reveal + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + (B infos.ctxt.block) + (contract_of infos.accounts.source) + (Some infos.accounts.source.pkh) + +let mk_origination (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let+ op, _ = + Op.contract_origination + ?force_reveal:oinfos.force_reveal + ?counter:oinfos.counter + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?storage_limit:oinfos.storage_limit + ~script:Op.dummy_script + (B infos.ctxt.block) + (contract_of infos.accounts.source) + in + op + +let mk_register_global_constant (oinfos : operation_req) (infos : infos) = + Op.register_global_constant + ?force_reveal:oinfos.force_reveal + ?counter:oinfos.counter + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?storage_limit:oinfos.storage_limit + (B infos.ctxt.block) + ~source:(contract_of infos.accounts.source) + ~value:(Script_repr.lazy_expr (Expr.from_string "Pair 1 2")) + +let mk_set_deposits_limit (oinfos : operation_req) (infos : infos) = + Op.set_deposits_limit + ?force_reveal:oinfos.force_reveal + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?storage_limit:oinfos.storage_limit + ?counter:oinfos.counter + (B infos.ctxt.block) + (contract_of infos.accounts.source) + None + +let mk_increase_paid_storage (oinfos : operation_req) (infos : infos) = + Op.increase_paid_storage + ?force_reveal:oinfos.force_reveal + ?counter:oinfos.counter + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?storage_limit:oinfos.storage_limit + (B infos.ctxt.block) + ~source:(contract_of infos.accounts.source) + ~destination:infos.ctxt.originated_contract + Z.one + +let mk_reveal (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* pk = get_pk (B infos.ctxt.block) (contract_of infos.accounts.source) in + Op.revelation + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + (B infos.ctxt.block) + pk + +let mk_tx_rollup_origination (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let+ op, _rollup = + Op.tx_rollup_origination + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + ?force_reveal:oinfos.force_reveal + (B infos.ctxt.block) + (contract_of infos.accounts.source) + in + op + +let tx_rollup_of = function + | Some tx_rollup -> return tx_rollup + | None -> failwith "Tx_rollup not created in this context" + +let sc_rollup_of = function + | Some sc_rollup -> return sc_rollup + | None -> failwith "Sc_rollup not created in this context" + +let mk_tx_rollup_submit_batch (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* tx_rollup = tx_rollup_of infos.ctxt.tx_rollup in + Op.tx_rollup_submit_batch + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + ?force_reveal:oinfos.force_reveal + (B infos.ctxt.block) + (contract_of infos.accounts.source) + tx_rollup + "batch" + +let mk_tx_rollup_commit (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* tx_rollup = tx_rollup_of infos.ctxt.tx_rollup in + let commitement : Tx_rollup_commitment.Full.t = + { + level = Tx_rollup_level.root; + messages = []; + predecessor = None; + inbox_merkle_root = Tx_rollup_inbox.Merkle.merklize_list []; + } + in + Op.tx_rollup_commit + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + ?force_reveal:oinfos.force_reveal + (B infos.ctxt.block) + (contract_of infos.accounts.source) + tx_rollup + commitement + +let mk_tx_rollup_return_bond (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* tx_rollup = tx_rollup_of infos.ctxt.tx_rollup in + Op.tx_rollup_return_bond + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + ?force_reveal:oinfos.force_reveal + (B infos.ctxt.block) + (contract_of infos.accounts.source) + tx_rollup + +let mk_tx_rollup_finalize (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* tx_rollup = tx_rollup_of infos.ctxt.tx_rollup in + Op.tx_rollup_finalize + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + ?force_reveal:oinfos.force_reveal + (B infos.ctxt.block) + (contract_of infos.accounts.source) + tx_rollup + +let mk_tx_rollup_remove_commitment (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* tx_rollup = tx_rollup_of infos.ctxt.tx_rollup in + Op.tx_rollup_remove_commitment + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + ?force_reveal:oinfos.force_reveal + (B infos.ctxt.block) + (contract_of infos.accounts.source) + tx_rollup + +let mk_tx_rollup_reject (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* tx_rollup = tx_rollup_of infos.ctxt.tx_rollup in + let message, _ = Tx_rollup_message.make_batch "" in + let message_hash = Tx_rollup_message_hash.hash_uncarbonated message in + let message_path = + match Tx_rollup_inbox.Merkle.compute_path [message_hash] 0 with + | Ok message_path -> message_path + | _ -> raise (Invalid_argument "Single_message_inbox.message_path") + in + let proof : Tx_rollup_l2_proof.t = + { + version = 1; + before = `Value Tx_rollup_message_result.empty_l2_context_hash; + after = `Value Context_hash.zero; + state = Seq.empty; + } + in + let previous_message_result : Tx_rollup_message_result.t = + { + context_hash = Tx_rollup_message_result.empty_l2_context_hash; + withdraw_list_hash = Tx_rollup_withdraw_list_hash.empty; + } + in + Op.tx_rollup_reject + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + ?force_reveal:oinfos.force_reveal + (B infos.ctxt.block) + (contract_of infos.accounts.source) + tx_rollup + Tx_rollup_level.root + message + ~message_position:0 + ~message_path + ~message_result_hash:Tx_rollup_message_result_hash.zero + ~message_result_path:Tx_rollup_commitment.Merkle.dummy_path + ~proof + ~previous_message_result + ~previous_message_result_path:Tx_rollup_commitment.Merkle.dummy_path + +let mk_transfer_ticket (oinfos : operation_req) (infos : infos) = + Op.transfer_ticket + ?fee:oinfos.fee + ?force_reveal:oinfos.force_reveal + ?counter:oinfos.counter + ?gas_limit:oinfos.gas_limit + ?storage_limit:oinfos.storage_limit + (B infos.ctxt.block) + ~source:(contract_of infos.accounts.source) + ~contents:(Script.lazy_expr (Expr.from_string "1")) + ~ty:(Script.lazy_expr (Expr.from_string "nat")) + ~ticketer: + (contract_of + (match infos.accounts.tx with + | None -> infos.accounts.source + | Some tx -> tx)) + Z.zero + ~destination: + (contract_of + (match infos.accounts.dest with + | None -> infos.accounts.source + | Some dest -> dest)) + Entrypoint.default + +let mk_tx_rollup_dispacth_ticket (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* tx_rollup = tx_rollup_of infos.ctxt.tx_rollup in + let reveal = + Tx_rollup_reveal. + { + contents = Script.lazy_expr (Expr.from_string "1"); + ty = Script.lazy_expr (Expr.from_string "nat"); + ticketer = + contract_of + (match infos.accounts.dest with + | None -> infos.accounts.source + | Some dest -> dest); + amount = Tx_rollup_l2_qty.of_int64_exn 10L; + claimer = + (match infos.accounts.dest with + | None -> infos.accounts.source.pkh + | Some dest -> dest.pkh); + } + in + Op.tx_rollup_dispatch_tickets + ?fee:oinfos.fee + ?force_reveal:oinfos.force_reveal + ?counter:oinfos.counter + ?gas_limit:oinfos.gas_limit + ?storage_limit:oinfos.storage_limit + (B infos.ctxt.block) + ~source:(contract_of infos.accounts.source) + ~message_index:0 + ~message_result_path:Tx_rollup_commitment.Merkle.dummy_path + tx_rollup + Tx_rollup_level.root + Context_hash.zero + [reveal] + +let mk_sc_rollup_origination (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let+ op, _ = + Op.sc_rollup_origination + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + ?force_reveal:oinfos.force_reveal + (B infos.ctxt.block) + (contract_of infos.accounts.source) + Sc_rollup.Kind.Example_arith + "" + (Script.lazy_expr (Expr.from_string "1")) + in + op + +let sc_dummy_commitment = + let number_of_messages = + match Sc_rollup.Number_of_messages.of_int32 3l with + | None -> assert false + | Some x -> x + in + let number_of_ticks = + match Sc_rollup.Number_of_ticks.of_int32 3000l with + | None -> assert false + | Some x -> x + in + Sc_rollup.Commitment. + { + predecessor = Sc_rollup.Commitment.Hash.zero; + inbox_level = Raw_level.of_int32_exn Int32.zero; + number_of_messages; + number_of_ticks; + compressed_state = Sc_rollup.State_hash.zero; + } + +let mk_sc_rollup_publish (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* sc_rollup = sc_rollup_of infos.ctxt.sc_rollup in + Op.sc_rollup_publish + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + ?force_reveal:oinfos.force_reveal + (B infos.ctxt.block) + (contract_of infos.accounts.source) + sc_rollup + sc_dummy_commitment + +let mk_sc_rollup_cement (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* sc_rollup = sc_rollup_of infos.ctxt.sc_rollup in + Op.sc_rollup_cement + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + ?force_reveal:oinfos.force_reveal + (B infos.ctxt.block) + (contract_of infos.accounts.source) + sc_rollup + (Sc_rollup.Commitment.hash sc_dummy_commitment) + +let mk_sc_rollup_refute (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* sc_rollup = sc_rollup_of infos.ctxt.sc_rollup in + let refutation : Sc_rollup.Game.refutation = + {choice = Sc_rollup.Tick.initial; step = Dissection []} + in + Op.sc_rollup_refute + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + ?force_reveal:oinfos.force_reveal + (B infos.ctxt.block) + (contract_of infos.accounts.source) + sc_rollup + (match infos.accounts.dest with + | None -> infos.accounts.source.pkh + | Some dest -> dest.pkh) + refutation + false + +let mk_sc_rollup_add_messages (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* sc_rollup = sc_rollup_of infos.ctxt.sc_rollup in + Op.sc_rollup_add_messages + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + ?force_reveal:oinfos.force_reveal + (B infos.ctxt.block) + (contract_of infos.accounts.source) + sc_rollup + [""] + +let mk_sc_rollup_timeout (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* sc_rollup = sc_rollup_of infos.ctxt.sc_rollup in + Op.sc_rollup_timeout + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + ?force_reveal:oinfos.force_reveal + (B infos.ctxt.block) + (contract_of infos.accounts.source) + sc_rollup + (Sc_rollup.Game.Index.make + infos.accounts.source.pkh + (match infos.accounts.dest with + | None -> infos.accounts.source.pkh + | Some dest -> dest.pkh)) + +let mk_sc_rollup_execute_outbox_message (oinfos : operation_req) (infos : infos) + = + let open Lwt_result_syntax in + let* sc_rollup = sc_rollup_of infos.ctxt.sc_rollup in + Op.sc_rollup_execute_outbox_message + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + ?force_reveal:oinfos.force_reveal + (B infos.ctxt.block) + (contract_of infos.accounts.source) + sc_rollup + (Sc_rollup.Commitment.hash sc_dummy_commitment) + ~outbox_level:(Raw_level.of_int32_exn 0l) + ~message_index:0 + ~inclusion_proof:"xyz" + ~message:"xyz" + +let mk_sc_rollup_return_bond (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* sc_rollup = sc_rollup_of infos.ctxt.sc_rollup in + Op.sc_rollup_recover_bond + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + ?force_reveal:oinfos.force_reveal + (B infos.ctxt.block) + (contract_of infos.accounts.source) + sc_rollup + +let mk_dal_publish_slot_header (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let level = 0 in + let index = 0 in + let header = 0 in + let json_slot = + Data_encoding.Json.from_string + (Format.asprintf + {|{"level":%d,"index":%d,"header":%d}|} + level + index + header) + in + let* json_slot = + match json_slot with Error s -> failwith "%s" s | Ok slot -> return slot + in + let slot = Data_encoding.Json.destruct Dal.Slot.encoding json_slot in + Op.dal_publish_slot_header + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + ?force_reveal:oinfos.force_reveal + (B infos.ctxt.block) + (contract_of infos.accounts.source) + slot + +(** {2 Helpers for generation of generic check tests by manager operation} *) + +(** Generic forge for any kind of manager operation according to + operation requirements in a specific test setting. *) +let select_op (op_req : operation_req) (infos : infos) = + let mk_op = + match op_req.kind with + | K_Transaction -> mk_transaction + | K_Origination -> mk_origination + | K_Register_global_constant -> mk_register_global_constant + | K_Delegation -> mk_delegation + | K_Undelegation -> mk_undelegation + | K_Self_delegation -> mk_self_delegation + | K_Set_deposits_limit -> mk_set_deposits_limit + | K_Reveal -> mk_reveal + | K_Increase_paid_storage -> mk_increase_paid_storage + | K_Tx_rollup_origination -> mk_tx_rollup_origination + | K_Tx_rollup_submit_batch -> mk_tx_rollup_submit_batch + | K_Tx_rollup_commit -> mk_tx_rollup_commit + | K_Tx_rollup_return_bond -> mk_tx_rollup_return_bond + | K_Tx_rollup_finalize -> mk_tx_rollup_finalize + | K_Tx_rollup_remove_commitment -> mk_tx_rollup_remove_commitment + | K_Tx_rollup_reject -> mk_tx_rollup_reject + | K_Transfer_ticket -> mk_transfer_ticket + | K_Tx_rollup_dispatch_tickets -> mk_tx_rollup_dispacth_ticket + | K_Sc_rollup_origination -> mk_sc_rollup_origination + | K_Sc_rollup_publish -> mk_sc_rollup_publish + | K_Sc_rollup_cement -> mk_sc_rollup_cement + | K_Sc_rollup_refute -> mk_sc_rollup_refute + | K_Sc_rollup_add_messages -> mk_sc_rollup_add_messages + | K_Sc_rollup_timeout -> mk_sc_rollup_timeout + | K_Sc_rollup_execute_outbox_message -> mk_sc_rollup_execute_outbox_message + | K_Sc_rollup_recover_bond -> mk_sc_rollup_return_bond + | K_Dal_publish_slot_header -> mk_dal_publish_slot_header + in + mk_op op_req infos + +let create_Tztest ?hd_msg test tests_msg operations = + let tl_msg k = + let sk = kind_to_string k in + match hd_msg with None -> sk | Some hd -> Format.sprintf "%s, %s" hd sk + in + List.map + (fun kind -> + Tztest.tztest + (Format.sprintf "%s [%s]" tests_msg (tl_msg kind)) + `Quick + (fun () -> test kind ())) + operations + +let rec create_Tztest_batches test tests_msg operations = + let hdmsg k = Format.sprintf "%s" (kind_to_string k) in + let aux hd_msg test operations = + create_Tztest ~hd_msg test tests_msg operations + in + match operations with + | [] -> [] + | kop :: kops as ops -> + aux (hdmsg kop) (test kop) ops @ create_Tztest_batches test tests_msg kops + +(** {2 Diagnostic helpers.} *) + +(** The purpose of diagnostic helpers is to state the correct + observation according to the validate result of a test. *) + +(** For a manager operation a [probes] contains the values required + for observing its validate success. Its source, fees (sum for a + batch), gas_limit (sum of gas_limit of the batch), and the + increment of the counters aka 1 for a single operation, n for a + batch of n manager operations. *) +type probes = { + source : Signature.Public_key_hash.t; + fee : Tez.tez; + gas_limit : Gas.Arith.integral; + nb_counter : Z.t; +} + +let rec contents_infos : + type kind. kind Kind.manager contents_list -> probes tzresult Lwt.t = + fun op -> + let open Lwt_result_syntax in + match op with + | Single (Manager_operation {source; fee; gas_limit; _}) -> + return {source; fee; gas_limit; nb_counter = Z.one} + | Cons (Manager_operation manop, manops) -> + let* probes = contents_infos manops in + let*? fee = manop.fee +? probes.fee in + let gas_limit = Gas.Arith.add probes.gas_limit manop.gas_limit in + let nb_counter = Z.succ probes.nb_counter in + let _ = Assert.equal_pkh ~loc:__LOC__ manop.source probes.source in + return {fee; source = probes.source; gas_limit; nb_counter} + +(** Computes a [probes] from a list of manager contents. *) +let manager_content_infos op = + let (Operation_data {contents; _}) = op.protocol_data in + match contents with + | Single (Manager_operation _) as op -> contents_infos op + | Cons (Manager_operation _, _) as op -> contents_infos op + | _ -> failwith "Should only handle manager operation" + +(** We need a way to get the available gas in a context of type + block. *) +let available_gas = function + | Context.I inc -> Some (Gas.block_level (Incremental.alpha_ctxt inc)) + | B _ -> None + +(** Computes the witness value in a state. The witness values are the + the initial balance of source, its initial counter and the + available gas in the state. The available gas is computed only + when the context is an incremental one. *) +let witness ctxt source = + let open Lwt_result_syntax in + let* b_in = Context.Contract.balance ctxt source in + let+ c_in = Context.Contract.counter ctxt source in + let g_in = available_gas ctxt in + (b_in, c_in, g_in) + +(** According to the witness in pre-state and the probes, computes the + expected outputs. In any mode the expected witness: + - the balance of source should be the one in the pre-state minus + the fee of probes, + - the counter of source should be the one in the pre-state plus + the number of counter in probes. + + Concerning the expected available gas in the block: - In + [Application] mode, it cannot be computed, so we do not expect any, + - In [Mempool] mode, it is the remaining gas after removing the gas + of probes gas from an empty block, - In the [Construction] mode, it + is the remaining gas after removing the gas of probes from the + available gas in the pre-state.*) +let expected_witness witness probes ~mode ctxt = + let open Lwt_result_syntax in + let b_in, c_in, g_in = witness in + let*? b_expected = b_in -? probes.fee in + let c_expected = Z.add c_in probes.nb_counter in + let+ g_expected = + match (g_in, mode) with + | Some g_in, Construction -> + return_some (Gas.Arith.sub g_in (Gas.Arith.fp probes.gas_limit)) + | _, Mempool -> + Context.get_constants ctxt >>=? fun c -> + return_some + (Gas.Arith.sub + (Gas.Arith.fp c.parametric.hard_gas_limit_per_block) + (Gas.Arith.fp probes.gas_limit)) + | None, Application -> return_none + | Some _, Application -> + failwith "In application mode witness should not care about gas level" + | None, Construction -> + failwith "In Construction mode the witness should return a gas level" + in + (b_expected, c_expected, g_expected) + +(** The validity of a test in positve case, observes that validation + of a manager operation implies the fee payment. This observation + differs according to the validation calling [mode] (see type mode + for more details). Given the values of witness in the pre-state, + the probes of the operation probes and the values of witness in the + post-state, if the validation succeeds then we observe in the + post-state: + + The balance of source decreases by the fee of probes when + [only_validate] marks that only the validate succeeds. + + The balance of source decreases at least by fee of probes when + [not only_validate] marks that the application has succeeded, + + Its counter in the pre-state increases by the number of counter of + probes. + + The remaining gas in the pre-state decreases by the gas of probes, + in [Construction] and [Mempool] mode. + + In [Mempool] mode, the remaining gas in the pre-state is always + the available gas in an empty block. + + In the [Application] mode, we do not perform any check on the + available gas. *) +let observe ~only_validate ~mode ctxt_pre ctxt_post op = + let open Lwt_result_syntax in + let* probes = manager_content_infos op in + let contract = Contract.Implicit probes.source in + let* witness_in = witness ctxt_pre contract in + let* b_out, c_out, g_out = witness ctxt_post contract in + let* b_expected, c_expected, g_expected = + expected_witness witness_in probes ~mode ctxt_post + in + let b_cmp = + Assert.equal + ~loc:__LOC__ + (if only_validate then Tez.( = ) else Tez.( <= )) + (if only_validate then "Balance update (=)" else "Balance update (<=)") + Tez.pp + in + let* _ = b_cmp b_out b_expected in + let _ = + Assert.equal + Z.equal + ~loc:__LOC__ + "Counter incrementation" + Z.pp_print + c_out + c_expected + in + let g_msg = + match mode with + | Application -> "Gas consumption (application)" + | Mempool -> "Gas consumption (mempool)" + | Construction -> "Gas consumption (construction)" + in + match g_expected with + | None -> Assert.is_none ~loc:__LOC__ ~pp:Gas.Arith.pp g_out + | Some g_expected -> + let* g_out = Assert.get_some ~loc:__LOC__ g_out in + Assert.equal + ~loc:__LOC__ + Gas.Arith.equal + g_msg + Gas.Arith.pp + g_out + g_expected + +let observe_list ~only_validate ~mode ctxt_pre ctxt_post ops = + List.iter + (fun op -> + let _ = observe ~only_validate ~mode ctxt_pre ctxt_post op in + ()) + ops + +let validate_operations inc_in ops = + let open Lwt_result_syntax in + List.fold_left_es + (fun inc op -> + let* inc_out = Incremental.validate_operation inc op in + return inc_out) + inc_in + ops + +(** In [Construction] and [Mempool] mode, the pre-state provide an + incremental, whereas in the [Application] mode, it is the block in + the setting context of the test. *) +let pre_state_of_mode ~mode infos = + let open Lwt_result_syntax in + match mode with + | Construction | Mempool -> + let+ inc = Incremental.begin_construction infos.ctxt.block in + Context.I inc + | Application -> return (Context.B infos.ctxt.block) + +(** In [Construction] and [Mempool] mode, the post-state is + incrementally built upon a pre-state, whereas in the [Application] + mode it is obtained by baking. *) +let post_state_of_mode ~mode ctxt ops infos = + let open Lwt_result_syntax in + match (mode, ctxt) with + | (Construction | Mempool), Context.I inc_pre -> + let* inc_post = validate_operations inc_pre ops in + let+ block = Incremental.finalize_block inc_post in + (Context.I inc_post, {infos with ctxt = {infos.ctxt with block}}) + | Application, Context.B b -> + let+ block = Block.bake ~baking_mode:Application ~operations:ops b in + (Context.B block, {infos with ctxt = {infos.ctxt with block}}) + | Application, Context.I _ -> + failwith "In Application mode, context should not be an Incremental" + | (Construction | Mempool), Context.B _ -> + failwith "In (Partial) Contruction mode, context should not be a Block" + +(** A positive test builds a pre-state from a mode, and a setting + context, then it computes a post-state from the mode, the setting + context and the operations. Finally, it observes the result + according to the only_validate status for each operation. + + See [observe] for more details on the observational validation. *) +let validate_with_diagnostic ~only_validate ~mode (infos : infos) ops = + let open Lwt_result_syntax in + let* ctxt_pre = pre_state_of_mode ~mode infos in + let* ctxt_post, infos = post_state_of_mode ~mode ctxt_pre ops infos in + let _ = observe_list ~only_validate ~mode ctxt_pre ctxt_post ops in + return infos + +(** If only the operation validation succeeds; e.g. the rest of the + application failed then [only_validate] must be set for the + observation validation. + + Default mode is [Construction]. See [observe] for more details. *) +let only_validate_diagnostic ?(mode = Construction) (infos : infos) ops = + validate_with_diagnostic ~only_validate:true ~mode infos ops + +(** If the whole operation application succeeds; e.g. the fee + payment and the full application succeed then [not only_validate] + must be set. + + Default mode is [Construction]. *) +let validate_diagnostic ?(mode = Construction) (infos : infos) ops = + validate_with_diagnostic ~only_validate:false ~mode infos ops + +let add_operations ~expect_failure inc_in ops = + let open Lwt_result_syntax in + let* last, ops = + match List.rev ops with + | op :: rev_ops -> return (op, List.rev rev_ops) + | [] -> failwith "Empty list of operations given to add_operations" + in + let* inc = + List.fold_left_es + (fun inc op -> + let* inc = Incremental.validate_operation inc op in + return inc) + inc_in + ops + in + Incremental.validate_operation inc last ~expect_failure + +(** [validate_ko_diagnostic] wraps the [expect_failure] when [op] + validate failed. It is used in test that expects validate of the + last operation of a list of operations to fail. *) +let validate_ko_diagnostic ?(mode = Construction) (infos : infos) ops + expect_failure = + let open Lwt_result_syntax in + match mode with + | Construction | Mempool -> + let* i = + Incremental.begin_construction + infos.ctxt.block + ~mempool_mode:(mempool_mode_of mode) + in + let* _ = add_operations ~expect_failure i ops in + return_unit + | Application -> ( + let*! res = + Block.bake ~baking_mode:Application ~operations:ops infos.ctxt.block + in + match res with + | Error tr -> expect_failure tr + | _ -> failwith "Block application was expected to fail") + +(** List of operation kind that must run on generic tests. This list + should be extended for each new manager_operation kind. *) +let subjects = + [ + K_Transaction; + K_Origination; + K_Register_global_constant; + K_Delegation; + K_Undelegation; + K_Self_delegation; + K_Set_deposits_limit; + K_Increase_paid_storage; + K_Reveal; + K_Tx_rollup_origination; + K_Tx_rollup_submit_batch; + K_Tx_rollup_commit; + K_Tx_rollup_return_bond; + K_Tx_rollup_finalize; + K_Tx_rollup_remove_commitment; + K_Tx_rollup_dispatch_tickets; + K_Transfer_ticket; + K_Tx_rollup_reject; + K_Sc_rollup_origination; + K_Sc_rollup_publish; + K_Sc_rollup_cement; + K_Sc_rollup_add_messages; + K_Sc_rollup_refute; + K_Sc_rollup_timeout; + K_Sc_rollup_execute_outbox_message; + K_Sc_rollup_recover_bond; + K_Dal_publish_slot_header; + ] + +let is_consumer = function + | K_Set_deposits_limit | K_Increase_paid_storage | K_Reveal + | K_Self_delegation | K_Delegation | K_Undelegation | K_Tx_rollup_origination + | K_Tx_rollup_submit_batch | K_Tx_rollup_finalize | K_Tx_rollup_commit + | K_Tx_rollup_return_bond | K_Tx_rollup_remove_commitment | K_Tx_rollup_reject + | K_Sc_rollup_add_messages | K_Sc_rollup_origination | K_Sc_rollup_refute + | K_Sc_rollup_timeout | K_Sc_rollup_cement | K_Sc_rollup_publish + | K_Sc_rollup_execute_outbox_message | K_Sc_rollup_recover_bond + | K_Dal_publish_slot_header -> + false + | K_Transaction | K_Origination | K_Register_global_constant + | K_Tx_rollup_dispatch_tickets | K_Transfer_ticket -> + true + +let gas_consumer_in_validate_subjects, not_gas_consumer_in_validate_subjects = + List.partition is_consumer subjects + +let revealed_subjects = + List.filter (function K_Reveal -> false | _ -> true) subjects + +let is_disabled flags = function + | K_Transaction | K_Origination | K_Register_global_constant | K_Delegation + | K_Undelegation | K_Self_delegation | K_Set_deposits_limit | K_Reveal + | K_Increase_paid_storage -> + false + | K_Tx_rollup_origination | K_Tx_rollup_submit_batch | K_Tx_rollup_commit + | K_Tx_rollup_return_bond | K_Tx_rollup_finalize + | K_Tx_rollup_remove_commitment | K_Tx_rollup_dispatch_tickets + | K_Transfer_ticket | K_Tx_rollup_reject -> + flags.toru = false + | K_Sc_rollup_origination | K_Sc_rollup_publish | K_Sc_rollup_cement + | K_Sc_rollup_add_messages | K_Sc_rollup_refute | K_Sc_rollup_timeout + | K_Sc_rollup_execute_outbox_message | K_Sc_rollup_recover_bond -> + flags.scoru = false + | K_Dal_publish_slot_header -> flags.dal = false diff --git a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_1m_restriction.ml b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_1m_restriction.ml new file mode 100644 index 0000000000000000000000000000000000000000..6950d40876aee3466bf60230798264bdfabb3dc6 --- /dev/null +++ b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_1m_restriction.ml @@ -0,0 +1,242 @@ +(*****************************************************************************) +(* *) +(* 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: Protocol (validate manager) + Invocation: dune exec \ + src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_1m_restriction.exe + Subject: 1M restriction in validation of manager operation. +*) + +open Protocol +open Manager_operation_helpers +open Generators + +(** Local default values for the tests. *) +let ctxt_cstrs_default = + { + default_ctxt_cstrs with + src_cstrs = Greater {n = 15000; origin = 15000}; + dest_cstrs = Pure 15000; + del_cstrs = Pure 15000; + tx_cstrs = Pure 15000; + sc_cstrs = Pure 15000; + } + +let op_cstrs_default b = + { + default_operation_cstrs with + fee = Range {min = 0; max = 1_000; origin = 1_000}; + force_reveal = Some b; + amount = Range {min = 0; max = 10_000; origin = 10_000}; + } + +let print_one_op (ctxt_req, op_req, mode) = + Format.asprintf + "@[Generator printer:@,%a@,%a@,%a@]" + pp_ctxt_req + ctxt_req + pp_operation_req + op_req + pp_mode + mode + +let print_two_ops (ctxt_req, op_req, op_req', mode) = + Format.asprintf + "@[Generator printer:@,%a@,%a@,%a@,%a@]" + pp_ctxt_req + ctxt_req + pp_operation_req + op_req + pp_operation_req + op_req' + pp_mode + mode + +let print_ops_pair (ctxt_req, op_req, mode) = + Format.asprintf + "@[Generator printer:@,%a@,%a@,%a@]" + pp_ctxt_req + ctxt_req + pp_2_operation_req + op_req + pp_mode + mode + +(** The application of a valid operation succeeds, at least, to perform + the fee payment. *) +let positive_validated_op = + let gen = + QCheck2.Gen.triple + (Generators.gen_ctxt_req ctxt_cstrs_default) + (Generators.gen_operation_req (op_cstrs_default true) subjects) + Generators.gen_mode + in + wrap + ~count:1000 + ~print:print_one_op + ~name:"Positive validated op" + ~gen + (fun (ctxt_req, operation_req, mode) -> + let open Lwt_result_syntax in + let* infos = init_ctxt ctxt_req in + let* op = select_op operation_req infos in + let* _infos = wrap_mode infos [op] mode in + return_true) + +(** Under 1M restriction, neither a block nor a prevalidator's valid + pool should contain two operations with the same manager. It + raises a Manager_restriction error. *) +let negative_validated_two_ops_of_same_manager = + let gen = + QCheck2.Gen.quad + (Generators.gen_ctxt_req ctxt_cstrs_default) + (Generators.gen_operation_req (op_cstrs_default true) subjects) + (Generators.gen_operation_req (op_cstrs_default false) revealed_subjects) + Generators.gen_mode + in + let expect_failure = function + | [ + Environment.Ecoproto_error + (Validate_operation.Manager.Manager_restriction _); + ] -> + return_unit + | err -> + failwith + "Error trace:@,\ + \ %a does not match the \ + [Validate_operation.Manager.Manager_restriction] error" + Error_monad.pp_print_trace + err + in + wrap + ~count:1000 + ~print:print_two_ops + ~name:"Negative -- 1M" + ~gen + (fun (ctxt_req, operation_req, operation_req2, mode) -> + let open Lwt_result_syntax in + let* infos = init_ctxt ctxt_req in + let* op1 = select_op operation_req infos in + let* op2 = select_op operation_req2 infos in + let* _ = validate_ko_diagnostic ~mode infos [op1; op2] expect_failure in + return_true) + +(** Under 1M restriction, a batch of two operations cannot be replaced + by two single operations. *) +let negative_batch_of_two_is_not_two_single = + let gen = + QCheck2.Gen.triple + (Generators.gen_ctxt_req ctxt_cstrs_default) + (Generators.gen_2_operation_req + (op_cstrs_default false) + revealed_subjects) + Generators.gen_mode + in + let expect_failure _ = return_unit in + wrap + ~count:1000 + ~print:print_ops_pair + ~name:"Batch is not sequence of Single" + ~gen + (fun (ctxt_req, operation_req, mode) -> + let open Lwt_result_syntax in + let* infos = init_ctxt ctxt_req in + let* op1 = select_op (fst operation_req) infos in + let* op2 = select_op (snd operation_req) infos in + let source = contract_of infos.accounts.source in + let* batch = + Op.batch_operations ~source (B infos.ctxt.block) [op1; op2] + in + let* _ = validate_diagnostic ~mode infos [batch] in + let* _ = validate_ko_diagnostic ~mode infos [op1; op2] expect_failure in + return_true) + +(** The applications of two covalid operations in a certain context + succeed, at least, to perform the fee payment of both, in whatever + application order. *) +let valid_context_free = + let gen = + QCheck2.Gen.quad + (Generators.gen_ctxt_req ctxt_cstrs_default) + (Generators.gen_operation_req (op_cstrs_default true) revealed_subjects) + (Generators.gen_operation_req (op_cstrs_default true) revealed_subjects) + Generators.gen_mode + in + wrap + ~count:1000 + ~print:print_two_ops + ~name:"Under 1M, co-valid ops commute" + ~gen + (fun (ctxt_req, operation_req, operation_req', mode) -> + let open Lwt_result_syntax in + let* infos = init_ctxt ctxt_req in + let* op1 = select_op operation_req infos in + let infos2 = + { + infos with + accounts = + { + infos.accounts with + source = + (match infos.accounts.del with + | None -> assert false + | Some s -> s); + }; + } + in + let* op2 = select_op operation_req' infos2 in + let* _ = validate_diagnostic ~mode infos [op1; op2] in + let* _ = validate_diagnostic ~mode infos [op2; op1] in + return_true) + +open Lib_test.Qcheck2_helpers + +let positive_tests = qcheck_wrap [positive_validated_op] + +let two_op_from_same_manager_tests = + qcheck_wrap [negative_validated_two_ops_of_same_manager] + +let batch_is_not_singles_tests = + qcheck_wrap [negative_batch_of_two_is_not_two_single] + +let conflict_free_tests = qcheck_wrap [valid_context_free] + +let qcheck_tests = ("Positive tests", positive_tests) + +let qcheck_tests2 = + ("Only one manager op per manager", two_op_from_same_manager_tests) + +let qcheck_tests3 = + ("A batch differs from a sequence", batch_is_not_singles_tests) + +let qcheck_tests4 = + ("Fee payment of two covalid operations commute", conflict_free_tests) + +let () = + Alcotest.run + "1M QCheck" + [qcheck_tests; qcheck_tests2; qcheck_tests3; qcheck_tests4] diff --git a/src/proto_014_PtKathma/lib_protocol/test/integration/precheck/test_batched_manager_operation_precheck.ml b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_batched_manager_operation_validation.ml similarity index 61% rename from src/proto_014_PtKathma/lib_protocol/test/integration/precheck/test_batched_manager_operation_precheck.ml rename to src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_batched_manager_operation_validation.ml index 28bcc3c6fb299a816383446b6a6b54d11a765a5b..12f3dc3df4db96b505c3455729cda3a76ed1d2c3 100644 --- a/src/proto_014_PtKathma/lib_protocol/test/integration/precheck/test_batched_manager_operation_precheck.ml +++ b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_batched_manager_operation_validation.ml @@ -25,20 +25,20 @@ (** Testing ------- - Component: Protocol (precheck manager) + Component: Protocol (validate manager) Invocation: dune exec \ - src/proto_alpha/lib_protocol/test/integration/precheck/main.exe \ + src/proto_014_PtKathma/lib_protocol/test/integration/validate/main.exe \ -- test "^Batched" - Subject: Precheck manager operation. + Subject: Validation of batched manager operation. *) open Protocol open Alpha_context open Manager_operation_helpers -(* Tests on operation batches. *) +(** {2 Tests on operation batches} *) -(* Revelation should not occur elsewhere than in first position +(** Revelation should not occur elsewhere than in first position in a batch.*) let batch_reveal_in_the_middle_diagnostic (infos : infos) op = let expect_failure errs = @@ -54,40 +54,62 @@ let batch_reveal_in_the_middle_diagnostic (infos : infos) op = Error_monad.pp_print_trace err in - precheck_ko_diagnostic infos op expect_failure + validate_ko_diagnostic infos op expect_failure let test_batch_reveal_in_the_middle kind1 kind2 () = let open Lwt_result_syntax in - let* infos = init_context () in - let* counter = Context.Contract.counter (B infos.block) infos.contract1 in - let counter = counter in - let fee = Tez.one_mutez in + let* infos = default_init_ctxt () in + let* counter = + Context.Contract.counter + (B infos.ctxt.block) + (contract_of infos.accounts.source) + in let counter = Z.succ counter in let* operation1 = - select_op ~counter ~force_reveal:false ~source:infos.contract1 kind1 infos + select_op + { + (operation_req_default kind1) with + force_reveal = Some false; + counter = Some counter; + } + infos in let counter = Z.succ counter in - let* reveal = mk_reveal ~fee ~counter ~source:infos.contract1 infos in + let* reveal = + mk_reveal + { + (operation_req_default K_Reveal) with + fee = Some Tez.one_mutez; + counter = Some counter; + } + infos + in let counter = Z.succ counter in let* operation2 = - select_op ~counter ~force_reveal:false ~source:infos.contract1 kind2 infos + select_op + { + (operation_req_default kind2) with + force_reveal = Some false; + counter = Some counter; + } + infos in let* batch = Op.batch_operations ~recompute_counters:false - ~source:infos.contract1 - (Context.B infos.block) + ~source:(contract_of infos.accounts.source) + (Context.B infos.ctxt.block) [operation1; reveal; operation2] in - batch_reveal_in_the_middle_diagnostic infos batch + batch_reveal_in_the_middle_diagnostic infos [batch] let generate_batches_reveal_in_the_middle () = create_Tztest_batches test_batch_reveal_in_the_middle - "reveal should occur only at the beginning of a batch." + "Reveal should only occur at the beginning of a batch." revealed_subjects -(* A batch of manager operation contains at most one Revelation.*) +(** A batch of manager operation contains at most one Revelation.*) let batch_two_reveals_diagnostic (infos : infos) op = let expected_failure errs = match errs with @@ -102,30 +124,54 @@ let batch_two_reveals_diagnostic (infos : infos) op = Error_monad.pp_print_trace err in - precheck_ko_diagnostic infos op expected_failure + validate_ko_diagnostic infos op expected_failure let test_batch_two_reveals kind () = let open Lwt_result_syntax in - let* infos = init_context () in - let* counter = Context.Contract.counter (B infos.block) infos.contract1 in - let counter = counter in - let fee = Tez.one_mutez in + let* infos = default_init_ctxt () in + let* counter = + Context.Contract.counter + (B infos.ctxt.block) + (contract_of infos.accounts.source) + in let counter = Z.succ counter in - let* reveal = mk_reveal ~fee ~counter ~source:infos.contract1 infos in + let* reveal = + mk_reveal + { + (operation_req_default K_Reveal) with + fee = Some Tez.one_mutez; + counter = Some counter; + } + infos + in let counter = Z.succ counter in - let* reveal1 = mk_reveal ~fee ~counter ~source:infos.contract1 infos in + let* reveal1 = + mk_reveal + { + (operation_req_default K_Reveal) with + fee = Some Tez.one_mutez; + counter = Some counter; + } + infos + in let counter = Z.succ counter in let* operation = - select_op ~counter ~force_reveal:false ~source:infos.contract1 kind infos + select_op + { + (operation_req_default kind) with + force_reveal = Some false; + counter = Some counter; + } + infos in let* batch = Op.batch_operations ~recompute_counters:false - ~source:infos.contract1 - (Context.B infos.block) + ~source:(contract_of infos.accounts.source) + (Context.B infos.ctxt.block) [reveal; reveal1; operation] in - batch_two_reveals_diagnostic infos batch + batch_two_reveals_diagnostic infos [batch] let generate_tests_batches_two_reveals () = create_Tztest @@ -133,7 +179,7 @@ let generate_tests_batches_two_reveals () = "Only one revelation per batch." revealed_subjects -(* Every manager operation in a batch concerns the same source.*) +(** Every manager operation in a batch concerns the same source.*) let batch_two_sources_diagnostic (infos : infos) op = let expect_failure errs = match errs with @@ -147,27 +193,42 @@ let batch_two_sources_diagnostic (infos : infos) op = Error_monad.pp_print_trace err in - precheck_ko_diagnostic infos op expect_failure + validate_ko_diagnostic infos op expect_failure let test_batch_two_sources kind1 kind2 () = let open Lwt_result_syntax in - let* infos = init_context () in - let* counter = Context.Contract.counter (B infos.block) infos.contract1 in + let* infos = default_init_ctxt () in + let source = contract_of infos.accounts.source in + let* counter = Context.Contract.counter (B infos.ctxt.block) source in let counter = Z.succ counter in let* operation1 = - select_op ~counter ~force_reveal:true ~source:infos.contract1 kind1 infos + select_op + { + (operation_req_default kind1) with + force_reveal = Some true; + counter = Some counter; + } + infos + in + let infos = + let source2 = + match infos.accounts.del with None -> assert false | Some s -> s + in + {infos with accounts = {infos.accounts with source = source2}} in let* operation2 = - select_op ~force_reveal:false ~source:infos.contract2 kind2 infos + select_op + {(operation_req_default kind2) with force_reveal = Some false} + infos in let* batch = Op.batch_operations ~recompute_counters:false - ~source:infos.contract1 - (Context.B infos.block) + ~source + (Context.B infos.ctxt.block) [operation1; operation2] in - batch_two_sources_diagnostic infos batch + batch_two_sources_diagnostic infos [batch] let generate_batches_two_sources () = create_Tztest_batches @@ -175,21 +236,29 @@ let generate_batches_two_sources () = "Only one source per batch." revealed_subjects -(* Counters in a batch should be a sequence from the successor of +(** Counters in a batch should be a sequence from the successor of the stored counter associated to source in the initial context. *) let test_batch_inconsistent_counters kind1 kind2 () = let open Lwt_result_syntax in - let* infos = init_context () in - let* counter = Context.Contract.counter (B infos.block) infos.contract1 in - let fee = Tez.one_mutez in - let* reveal = mk_reveal ~fee ~counter ~source:infos.contract1 infos in + let* infos = default_init_ctxt () in + let source = contract_of infos.accounts.source in + let* counter = Context.Contract.counter (B infos.ctxt.block) source in + let fee = Some Tez.one_mutez in + let op_infos = operation_req_default K_Reveal in + let op_infos = {{op_infos with fee} with counter = Some counter} in + let* reveal = mk_reveal op_infos infos in let counter0 = counter in let counter = Z.succ counter in let counter2 = Z.succ counter in let counter3 = Z.succ counter2 in - let source = infos.contract1 in let operation counter kind = - select_op ~counter ~force_reveal:false ~source kind infos + select_op + { + (operation_req_default kind) with + counter = Some counter; + force_reveal = Some false; + } + infos in let op_counter = operation counter in let op_counter0 = operation counter0 in @@ -201,7 +270,7 @@ let test_batch_inconsistent_counters kind1 kind2 () = Op.batch_operations ~recompute_counters:false ~source - (Context.B infos.block) + (Context.B infos.ctxt.block) [reveal; op1; op2] in let* op1 = op_counter2 kind1 in @@ -210,7 +279,7 @@ let test_batch_inconsistent_counters kind1 kind2 () = Op.batch_operations ~recompute_counters:false ~source - (Context.B infos.block) + (Context.B infos.ctxt.block) [reveal; op1; op2] in let* op1 = op_counter kind1 in @@ -219,7 +288,7 @@ let test_batch_inconsistent_counters kind1 kind2 () = Op.batch_operations ~recompute_counters:false ~source - (Context.B infos.block) + (Context.B infos.ctxt.block) [reveal; op1; op2] in let* op1 = op_counter2 kind1 in @@ -228,7 +297,7 @@ let test_batch_inconsistent_counters kind1 kind2 () = Op.batch_operations ~recompute_counters:false ~source - (Context.B infos.block) + (Context.B infos.ctxt.block) [reveal; op1; op2] in let* op1 = op_counter0 kind1 in @@ -237,7 +306,7 @@ let test_batch_inconsistent_counters kind1 kind2 () = Op.batch_operations ~recompute_counters:false ~source - (Context.B infos.block) + (Context.B infos.ctxt.block) [reveal; op1; op2] in let expect_failure errs = @@ -252,7 +321,7 @@ let test_batch_inconsistent_counters kind1 kind2 () = Error_monad.pp_print_trace err in - let* i = Incremental.begin_construction infos.block in + let* i = Incremental.begin_construction infos.ctxt.block in let* _ = Incremental.add_operation ~expect_failure i batch_same in let* _ = Incremental.add_operation ~expect_failure i batch_in_the_future in let* _ = Incremental.add_operation ~expect_failure i batch_missing_one in @@ -266,23 +335,41 @@ let generate_batches_inconsistent_counters () = "Counters in a batch should be a sequence." revealed_subjects -(* A batch that consumes all the balance for fees can only face the total +(** A batch that consumes all the balance for fees can only face the total consumption at the end of the batch. *) let test_batch_emptying_balance_in_the_middle kind1 kind2 () = let open Lwt_result_syntax in - let* infos = init_context () in - let* counter = Context.Contract.counter (B infos.block) infos.contract1 in - let* init_bal = Context.Contract.balance (B infos.block) infos.contract1 in + let* infos = default_init_ctxt () in + let source = contract_of infos.accounts.source in + let* counter = Context.Contract.counter (B infos.ctxt.block) source in + let* init_bal = Context.Contract.balance (B infos.ctxt.block) source in let counter = counter in - let source = infos.contract1 in - let* reveal = mk_reveal ~counter ~source infos in + let* reveal = + mk_reveal + {(operation_req_default K_Reveal) with counter = Some counter} + infos + in let counter = Z.succ counter in let operation fee = - select_op ~fee ~counter ~force_reveal:false ~source kind1 infos + select_op + { + (operation_req_default kind1) with + force_reveal = Some false; + counter = Some counter; + fee = Some fee; + } + infos in let counter = Z.succ counter in let operation2 fee = - select_op ~fee ~counter ~force_reveal:false ~source kind2 infos + select_op + { + (operation_req_default kind2) with + force_reveal = Some false; + counter = Some counter; + fee = Some fee; + } + infos in let* op_case1 = operation init_bal in let* op2_case1 = operation2 Tez.zero in @@ -290,10 +377,10 @@ let test_batch_emptying_balance_in_the_middle kind1 kind2 () = Op.batch_operations ~recompute_counters:false ~source - (Context.B infos.block) + (Context.B infos.ctxt.block) [reveal; op_case1; op2_case1] in - let* i = Incremental.begin_construction infos.block in + let* i = Incremental.begin_construction infos.ctxt.block in let expect_failure errs = match errs with | [Environment.Ecoproto_error (Contract_storage.Empty_implicit_contract _)] @@ -314,36 +401,44 @@ let generate_batches_emptying_balance_in_the_middle () = "Fee payment emptying balance should occurs at the end of the batch." revealed_subjects -(* A batch of manager operation must not exceed the initial available gas in the block. *) +(** A batch of manager operation must not exceed the initial available gas in the block. *) let test_batch_exceeding_block_gas ~mempool_mode kind1 kind2 () = let open Lwt_result_syntax in - let* infos = init_context ~hard_gas_limit_per_block:gb_limit () in - let* counter = Context.Contract.counter (B infos.block) infos.contract1 in + let ctxt_req = + {ctxt_req_default with hard_gas_limit_per_block = Some gb_limit} + in + let* infos = init_ctxt ctxt_req in + let source = contract_of infos.accounts.source in + let* counter = Context.Contract.counter (B infos.ctxt.block) source in let g_limit = Gas.Arith.add gb_limit Gas.Arith.(integral_of_int_exn 1) in let half_limit = Gas.Arith.add half_gb_limit Gas.Arith.(integral_of_int_exn 1) in - let counter = counter in - let source = infos.contract1 in - let* reveal = mk_reveal ~counter ~source infos in + let* reveal = + mk_reveal + {(operation_req_default K_Reveal) with counter = Some counter} + infos + in let counter = Z.succ counter in let operation gas_limit = select_op - ~gas_limit:(Custom_gas gas_limit) - ~counter - ~force_reveal:false - ~source - kind1 + { + (operation_req_default kind1) with + force_reveal = Some false; + counter = Some counter; + gas_limit = Some (Custom_gas gas_limit); + } infos in let counter = Z.succ counter in let operation2 gas_limit = select_op - ~gas_limit:(Custom_gas gas_limit) - ~counter - ~force_reveal:false - ~source - kind2 + { + (operation_req_default kind2) with + force_reveal = Some false; + counter = Some counter; + gas_limit = Some (Custom_gas gas_limit); + } infos in let* op_case1 = operation g_limit in @@ -356,24 +451,24 @@ let test_batch_exceeding_block_gas ~mempool_mode kind1 kind2 () = Op.batch_operations ~recompute_counters:false ~source - (Context.B infos.block) + (Context.B infos.ctxt.block) [reveal; op_case1; op2_case1] in let* case3 = Op.batch_operations ~recompute_counters:false ~source - (Context.B infos.block) + (Context.B infos.ctxt.block) [reveal; op_case3; op2_case3] in let* case2 = Op.batch_operations ~recompute_counters:false ~source - (Context.B infos.block) + (Context.B infos.ctxt.block) [reveal; op_case2; op2_case2] in - let* i = Incremental.begin_construction infos.block ~mempool_mode in + let* i = Incremental.begin_construction infos.ctxt.block ~mempool_mode in let expect_failure errs = match errs with | [Environment.Ecoproto_error Gas.Block_quota_exceeded] @@ -408,24 +503,41 @@ let generate_batches_exceeding_block_gas_mp_mode () = "Too much gas consumption in mempool mode." revealed_subjects -(* A batch that consumes all the balance for fees only at the end of - the batch passes precheck.*) +(** A batch that consumes all the balance for fees only at the end of + the batch passes validate.*) let test_batch_balance_just_enough kind1 kind2 () = let open Lwt_result_syntax in - let* infos = init_context () in - let* counter = Context.Contract.counter (B infos.block) infos.contract1 in - let* init_bal = Context.Contract.balance (B infos.block) infos.contract1 in + let* infos = default_init_ctxt () in + let source = contract_of infos.accounts.source in + let* counter = Context.Contract.counter (B infos.ctxt.block) source in + let* init_bal = Context.Contract.balance (B infos.ctxt.block) source in let*? half_init_bal = Environment.wrap_tzresult @@ Tez.(init_bal /? 2L) in - let counter = counter in - let source = infos.contract1 in - let* reveal = mk_reveal ~counter ~source infos in + let* reveal = + mk_reveal + {(operation_req_default K_Reveal) with counter = Some counter} + infos + in let counter = Z.succ counter in let operation fee = - select_op ~fee ~counter ~force_reveal:false ~source kind1 infos + select_op + { + (operation_req_default kind1) with + force_reveal = Some false; + counter = Some counter; + fee = Some fee; + } + infos in let counter = Z.succ counter in let operation2 fee = - select_op ~fee ~counter ~force_reveal:false ~source kind2 infos + select_op + { + (operation_req_default kind2) with + force_reveal = Some false; + counter = Some counter; + fee = Some fee; + } + infos in let* op_case2 = operation Tez.zero in let* op2_case2 = operation2 init_bal in @@ -435,47 +547,63 @@ let test_batch_balance_just_enough kind1 kind2 () = Op.batch_operations ~recompute_counters:false ~source - (Context.B infos.block) + (Context.B infos.ctxt.block) [reveal; op_case3; op2_case3] in let* case2 = Op.batch_operations ~recompute_counters:false ~source - (Context.B infos.block) + (Context.B infos.ctxt.block) [reveal; op_case2; op2_case2] in - let* _ = precheck_diagnostic infos case2 in - precheck_diagnostic infos case3 + let* _ = validate_diagnostic infos [case2] in + let* _ = validate_diagnostic infos [case3] in + return_unit let generate_batches_balance_just_enough () = create_Tztest_batches test_batch_balance_just_enough - "(Positive test) Fee payment emptying balance in a batch." + "Fee payment emptying balance in a batch." revealed_subjects -(* Simple reveal followed by a transaction. *) +(** Simple reveal followed by a transaction. *) let test_batch_reveal_transaction_ok () = let open Lwt_result_syntax in - let* infos = init_context () in - let* counter = Context.Contract.counter (B infos.block) infos.contract1 in + let* infos = default_init_ctxt () in + let source = contract_of infos.accounts.source in + let* counter = Context.Contract.counter (B infos.ctxt.block) source in let counter = counter in let fee = Tez.one_mutez in - let source = infos.contract1 in - let* reveal = mk_reveal ~fee ~counter ~source infos in + let* reveal = + mk_reveal + { + (operation_req_default K_Reveal) with + fee = Some fee; + counter = Some counter; + } + infos + in let counter = Z.succ counter in let* transaction = - mk_transaction ~counter ~force_reveal:false ~source infos + mk_transaction + { + (operation_req_default K_Reveal) with + counter = Some counter; + force_reveal = Some false; + } + infos in let* batch = Op.batch_operations ~recompute_counters:false ~source - (Context.B infos.block) + (Context.B infos.ctxt.block) [reveal; transaction] in - let* _i = Incremental.begin_construction infos.block in - precheck_diagnostic infos batch + let* _i = Incremental.begin_construction infos.ctxt.block in + let* _ = validate_diagnostic infos [batch] in + return_unit let contract_tests = generate_batches_reveal_in_the_middle () @@ -484,7 +612,7 @@ let contract_tests = @ generate_batches_inconsistent_counters () @ [ Tztest.tztest - "Prechecked a batch with a reveal and a transaction." + "Validate a batch with a reveal and a transaction." `Quick test_batch_reveal_transaction_ok; ] diff --git a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_manager_operation_validation.ml b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_manager_operation_validation.ml new file mode 100644 index 0000000000000000000000000000000000000000..ed3c312e9b6fec50b6f2f167fc1356d2f7415bbd --- /dev/null +++ b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_manager_operation_validation.ml @@ -0,0 +1,780 @@ +(*****************************************************************************) +(* *) +(* 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: Protocol (validate manager) + Invocation: dune exec \ + src/proto_014_PtKathma/lib_protocol/test/integration/validate/main.exe \ + -- test "^Single" + Subject: Validation of manager operation. +*) + +open Protocol +open Alpha_context +open Manager_operation_helpers + +(** The goal of this test is to ensure that [select_op] generate the + wanted kind of manager operation + + Note: if a new manager operation kind is added in the protocol, + [Manager_operation_helpers.manager_operation_kind] should be + extended. You will also have to extend + [Manager_operation_helpers.select_op] with a new `mk` for this new + operation. Finally the list [Manager_operation_helpers.subjects] + should also be extended to run the validate test on the new manager + operation kind. *) +let ensure_kind infos kind = + let open Lwt_result_syntax in + let* op = + select_op + {(operation_req_default kind) with force_reveal = Some false} + infos + in + let (Operation_data {contents; _}) = op.protocol_data in + match contents with + | Single (Manager_operation {operation; _}) -> ( + match (operation, kind) with + | Transaction _, K_Transaction + | Reveal _, K_Reveal + | Origination _, K_Origination + | Delegation _, K_Delegation + | Delegation _, K_Undelegation + | Delegation _, K_Self_delegation + | Register_global_constant _, K_Register_global_constant + | Set_deposits_limit _, K_Set_deposits_limit + | Increase_paid_storage _, K_Increase_paid_storage + | Tx_rollup_origination, K_Tx_rollup_origination + | Tx_rollup_submit_batch _, K_Tx_rollup_submit_batch + | Tx_rollup_commit _, K_Tx_rollup_commit + | Tx_rollup_return_bond _, K_Tx_rollup_return_bond + | Tx_rollup_finalize_commitment _, K_Tx_rollup_finalize + | Tx_rollup_remove_commitment _, K_Tx_rollup_remove_commitment + | Tx_rollup_rejection _, K_Tx_rollup_reject + | Tx_rollup_dispatch_tickets _, K_Tx_rollup_dispatch_tickets + | Transfer_ticket _, K_Transfer_ticket + | Sc_rollup_originate _, K_Sc_rollup_origination + | Sc_rollup_add_messages _, K_Sc_rollup_add_messages + | Sc_rollup_cement _, K_Sc_rollup_cement + | Sc_rollup_publish _, K_Sc_rollup_publish + | Sc_rollup_refute _, K_Sc_rollup_refute + | Sc_rollup_timeout _, K_Sc_rollup_timeout + | Sc_rollup_execute_outbox_message _, K_Sc_rollup_execute_outbox_message + | Sc_rollup_recover_bond _, K_Sc_rollup_recover_bond + | Dal_publish_slot_header _, K_Dal_publish_slot_header -> + return_unit + | ( ( Transaction _ | Origination _ | Register_global_constant _ + | Delegation _ | Set_deposits_limit _ | Increase_paid_storage _ + | Reveal _ | Tx_rollup_origination | Tx_rollup_submit_batch _ + | Tx_rollup_commit _ | Tx_rollup_return_bond _ + | Tx_rollup_finalize_commitment _ | Tx_rollup_remove_commitment _ + | Tx_rollup_dispatch_tickets _ | Transfer_ticket _ + | Tx_rollup_rejection _ | Sc_rollup_originate _ | Sc_rollup_publish _ + | Sc_rollup_cement _ | Sc_rollup_add_messages _ | Sc_rollup_refute _ + | Sc_rollup_timeout _ | Sc_rollup_execute_outbox_message _ + | Sc_rollup_recover_bond _ | Dal_publish_slot_header _ + | Sc_rollup_dal_slot_subscribe _ ), + _ ) -> + assert false) + | Single _ -> assert false + | Cons _ -> assert false + +let ensure_manager_operation_coverage () = + let open Lwt_result_syntax in + let* infos = default_init_ctxt () in + List.iter_es (fun kind -> ensure_kind infos kind) subjects + +let test_ensure_manager_operation_coverage () = + Tztest.tztest + (Format.sprintf "Ensure manager_operation coverage") + `Quick + (fun () -> ensure_manager_operation_coverage ()) + +(** {2 Negative tests assert the case where validate must fail} *) + +(** Validate fails if the gas limit is too low. + + This test asserts that the validation of a manager operation + with a too low gas limit fails at validate with an + [Gas_quota_exceeded_init_deserialize] error. + This test applies on manager operations that do not + consume gas in their specific part of validate. *) +let low_gas_limit_diagnostic (infos : infos) op = + let expect_failure errs = + match errs with + | [ + Environment.Ecoproto_error + Validate_operation.Manager.Gas_quota_exceeded_init_deserialize; + Environment.Ecoproto_error Raw_context.Operation_quota_exceeded; + ] -> + return_unit + | err -> + failwith + "Error trace:@, %a does not match the expected one" + Error_monad.pp_print_trace + err + in + validate_ko_diagnostic infos op expect_failure + +let test_low_gas_limit kind () = + let open Lwt_result_syntax in + let* infos = default_init_ctxt () in + let* op = + select_op + { + (operation_req_default kind) with + gas_limit = Some Op.Low; + force_reveal = Some true; + } + infos + in + low_gas_limit_diagnostic infos [op] + +let generate_low_gas_limit () = + create_Tztest + test_low_gas_limit + "Gas_limit too low." + gas_consumer_in_validate_subjects + +(** Validate fails if the gas limit is too high. + + This test asserts that the validation of a manager operation with + a gas limit too high fails at validate with an [Gas_limit_too_high] + error. It applies on every kind of manager operation. *) +let high_gas_limit_diagnostic (infos : infos) op = + let expect_failure errs = + match errs with + | [Environment.Ecoproto_error Gas.Gas_limit_too_high] -> return_unit + | err -> + failwith + "Error trace:@, %a does not match the expected one" + Error_monad.pp_print_trace + err + in + validate_ko_diagnostic infos op expect_failure + +let test_high_gas_limit kind () = + let open Lwt_result_syntax in + let* infos = default_init_ctxt () in + let* op = + select_op + { + (operation_req_default kind) with + force_reveal = Some true; + gas_limit = + Some (Op.Custom_gas (Gas.Arith.integral_of_int_exn 10_000_000)); + } + infos + in + high_gas_limit_diagnostic infos [op] + +let generate_high_gas_limit () = + create_Tztest test_high_gas_limit "Gas_limit too high." subjects + +(** Validate fails if the storage limit is too high. + + This test asserts that a manager operation with a storage limit + too high fails at validation with [Storage_limit_too_high] error. + It applies to every kind of manager operation. *) +let high_storage_limit_diagnostic (infos : infos) op = + let expect_failure errs = + match errs with + | [Environment.Ecoproto_error Fees_storage.Storage_limit_too_high] -> + return_unit + | err -> + failwith + "Error trace:@, %a does not match the expected one" + Error_monad.pp_print_trace + err + in + validate_ko_diagnostic infos op expect_failure + +let test_high_storage_limit kind () = + let open Lwt_result_syntax in + let* infos = default_init_ctxt () in + let* op = + select_op + { + (operation_req_default kind) with + force_reveal = Some true; + storage_limit = Some (Z.of_int max_int); + } + infos + in + high_storage_limit_diagnostic infos [op] + +let generate_high_storage_limit () = + create_Tztest test_high_gas_limit "Storage_limit too high." subjects + +(** Validate fails if the counter is in the future. + + This test asserts that the validation of + a manager operation with a counter in the + future -- aka greater than the successor of the manager counter + stored in the current context -- fails with [Counter_in_the_future] error. + It applies to every kind of manager operation. *) +let high_counter_diagnostic (infos : infos) op = + let expect_failure errs = + match errs with + | [Environment.Ecoproto_error (Contract_storage.Counter_in_the_future _)] -> + return_unit + | err -> + failwith + "Error trace:@, %a does not match the expected one" + Error_monad.pp_print_trace + err + in + validate_ko_diagnostic infos op expect_failure + +let test_high_counter kind () = + let open Lwt_result_syntax in + let* infos = default_init_ctxt () in + let* op = + select_op + { + (operation_req_default kind) with + force_reveal = Some true; + counter = Some (Z.of_int max_int); + } + infos + in + high_counter_diagnostic infos [op] + +let generate_high_counter () = + create_Tztest test_high_counter "Counter too high." subjects + +(** Validate fails if the counter is in the past. + + This test asserts that the validation of a manager operation with a + counter in the past -- aka smaller than the successor of the + manager counter stored in the current context -- fails with + [Counter_in_the_past] error. It applies to every kind of manager + operation. *) +let low_counter_diagnostic (infos : infos) op = + let expect_failure errs = + match errs with + | [Environment.Ecoproto_error (Contract_storage.Counter_in_the_past _)] -> + return_unit + | err -> + failwith + "Error trace:@, %a does not match the expected one" + Error_monad.pp_print_trace + err + in + validate_ko_diagnostic infos op expect_failure + +let test_low_counter kind () = + let open Lwt_result_syntax in + let* infos = default_init_ctxt () in + let* current_counter = + Context.Contract.counter + (B infos.ctxt.block) + (contract_of infos.accounts.source) + in + let* op = + select_op + { + (operation_req_default kind) with + force_reveal = Some true; + counter = Some (Z.sub current_counter Z.one); + } + infos + in + low_counter_diagnostic infos [op] + +let generate_low_counter () = + create_Tztest test_low_counter "Counter too low." subjects + +(** Validate fails if the source is not allocated. + + This test asserts that the validation of a manager operation which + manager contract is not allocated fails with + [Empty_implicit_contract] error. It applies on every kind of + manager operation. *) +let not_allocated_diagnostic (infos : infos) op = + let expect_failure errs = + match errs with + | [Environment.Ecoproto_error (Contract_storage.Empty_implicit_contract _)] + -> + return_unit + | err -> + failwith + "Error trace:@, %a does not match the expected one" + Error_monad.pp_print_trace + err + in + validate_ko_diagnostic infos op expect_failure + +let test_not_allocated kind () = + let open Lwt_result_syntax in + let* infos = default_init_ctxt () in + let* op = + select_op + {(operation_req_default kind) with force_reveal = Some false} + { + infos with + accounts = {infos.accounts with source = Account.(new_account ())}; + } + in + not_allocated_diagnostic infos [op] + +let generate_not_allocated () = + create_Tztest test_not_allocated "Not allocated source." subjects + +(** Validate fails if the source is unrevealed. + + This test asserts that a manager operation with an unrevealed source + contract fails at validation with [Unrevealed_manager_key]. + It applies on every kind of manager operation except [Revelation]. *) +let unrevealed_key_diagnostic (infos : infos) op = + let expect_failure errs = + match errs with + | [ + Environment.Ecoproto_error + (Contract_manager_storage.Unrevealed_manager_key _); + ] -> + return_unit + | err -> + failwith + "Error trace:@, %a does not match the expected one" + Error_monad.pp_print_trace + err + in + validate_ko_diagnostic infos op expect_failure + +let test_unrevealed_key kind () = + let open Lwt_result_syntax in + let* infos = default_init_ctxt () in + let* op = + select_op + {(operation_req_default kind) with force_reveal = Some false} + infos + in + unrevealed_key_diagnostic infos [op] + +let generate_unrevealed_key () = + create_Tztest + test_unrevealed_key + "Unrevealed source (find_manager_public_key)." + revealed_subjects + +(** Validate fails if the source balance is not enough to pay the fees. + + This test asserts that validation of a manager operation fails if the + source balance is lesser than the manager operation fee. + It applies on every kind of manager operation. *) +let high_fee_diagnostic (infos : infos) op = + let expect_failure errs = + match errs with + | [ + Environment.Ecoproto_error (Contract_storage.Balance_too_low _); + Environment.Ecoproto_error (Tez_repr.Subtraction_underflow _); + ] -> + return_unit + | err -> + failwith + "Error trace:@, %a does not match the expected one" + Error_monad.pp_print_trace + err + in + validate_ko_diagnostic infos op expect_failure + +let test_high_fee kind () = + let open Lwt_result_syntax in + let* infos = default_init_ctxt () in + let*? fee = Tez.(one +? one) |> Environment.wrap_tzresult in + let* op = + select_op + { + (operation_req_default kind) with + force_reveal = Some true; + fee = Some fee; + } + infos + in + high_fee_diagnostic infos [op] + +let generate_tests_high_fee () = + create_Tztest test_high_fee "Balance too low for fee payment." subjects + +(** Validate fails if the fee payment empties the balance of a + delegated implicit contract. + + This test asserts that in case that: + - the source is a delegated implicit contract, and + - the fee is the exact balance of source. + then, validate fails with [Empty_implicit_delegated_contract] error. + It applies to every kind of manager operation except [Revelation].*) +let emptying_delegated_implicit_diagnostic (infos : infos) op = + let expect_failure errs = + match errs with + | [ + Environment.Ecoproto_error + (Contract_storage.Empty_implicit_delegated_contract _); + ] -> + return_unit + | err -> + failwith + "Error trace:@, %a does not match the expected one" + Error_monad.pp_print_trace + err + in + validate_ko_diagnostic infos op expect_failure + +let test_emptying_delegated_implicit kind () = + let open Lwt_result_syntax in + let* infos = default_ctxt_with_delegation () in + let* fee = + Context.Contract.balance + (B infos.ctxt.block) + (contract_of infos.accounts.source) + in + let* op = + select_op + { + (operation_req_default kind) with + force_reveal = Some false; + fee = Some fee; + } + infos + in + emptying_delegated_implicit_diagnostic infos [op] + +let generate_tests_emptying_delegated_implicit () = + create_Tztest + test_emptying_delegated_implicit + "Just enough funds to empty a delegated source." + revealed_subjects + +(** Validate fails if there is not enough available gas in the block. + + This test asserts that validate fails with: + - [Gas_limit_too_high;Block_quota_exceeded] in mempool mode, + - [Block_quota_exceeded] in other mode + with gas limit exceeds the available gas in the block. + It applies to every kind of manager operation. *) +let exceeding_block_gas_diagnostic ~mode (infos : infos) op = + let expect_failure errs = + match (errs, mode) with + | ( [Environment.Ecoproto_error Gas.Block_quota_exceeded], + (Construction | Application) ) -> + return_unit + | ( [ + Environment.Ecoproto_error Gas.Gas_limit_too_high; + Environment.Ecoproto_error Gas.Block_quota_exceeded; + ], + Mempool ) -> + (* In mempool_mode, batch that exceed [operation_gas_limit] needs + to be refused. [Gas.Block_quota_exceeded] only return a + temporary error. [Gas.Gas_limit_too_high], which is a + permanent error, is added to the error trace to ensure that + the batch is refused. *) + return_unit + | err, _ -> + failwith + "Error trace:@, %a does not match the expected one" + Error_monad.pp_print_trace + err + in + validate_ko_diagnostic infos op expect_failure ~mode + +let test_exceeding_block_gas ~mode kind () = + let open Lwt_result_syntax in + let ctxt_req = + {ctxt_req_default with hard_gas_limit_per_block = Some gb_limit} + in + let* infos = init_ctxt ctxt_req in + let* operation = + select_op + { + (operation_req_default kind) with + force_reveal = Some true; + gas_limit = + Some + (Op.Custom_gas + (Gas.Arith.add gb_limit Gas.Arith.(integral_of_int_exn 1))); + } + infos + in + exceeding_block_gas_diagnostic ~mode infos [operation] + +let generate_tests_exceeding_block_gas () = + create_Tztest + (test_exceeding_block_gas ~mode:Construction) + "Too much gas consumption." + subjects + +let generate_tests_exceeding_block_gas_mp_mode () = + create_Tztest + (test_exceeding_block_gas ~mode:Mempool) + "Too much gas consumption in mempool mode." + subjects + +(** {2 Positive tests} *) + +(** Tests that validate succeeds when: + - it empties the balance of a self_delegated implicit source, + - it empties the balance of an undelegated implicit source, and + - in case: + - the counter is the successor of the one stored in the context, + - the fee is lesser than the balance, + - the storage limit is lesser than the maximum authorized storage, + - the gas limit is: + - lesser than the available gas in the block, + - less than the maximum gas consumable by an operation, and + - greater than the minimum gas consumable by an operation. + + Notice that in the first two cases only validate succeeds while + in the last case, the full application also succeeds. + In the first 2 case, we observe in the output context that: + - the counter is the successor of the one stored in the initial context, + - the balance decreased by fee, + - the available gas in the block decreased by gas limit. + In the last case, we observe in the output context that: + - the counter is the successor of the one stored in the initial context, + - the balance is at least decreased by fee, + - the available gas in the block decreased by gas limit. *) + +(** Fee payment that emptying a self_delegated implicit. *) +let test_emptying_self_delegated_implicit kind () = + let open Lwt_result_syntax in + let* infos = default_ctxt_with_self_delegation () in + let* fee = + Context.Contract.balance + (B infos.ctxt.block) + (contract_of infos.accounts.source) + in + let* op = + select_op + { + (operation_req_default kind) with + force_reveal = Some false; + fee = Some fee; + } + infos + in + let* _ = only_validate_diagnostic infos [op] in + return_unit + +let generate_tests_emptying_self_delegated_implicit () = + create_Tztest + test_emptying_self_delegated_implicit + "Validate and empties a self-delegated source." + subjects + +(** Minimum gas cost to pass the validation: + - cost_of_manager_operation for the generic part + - 100 (empiric) for the specific part (script decoding or hash costs) *) +let empiric_minimal_gas_cost_for_validate = + Gas.Arith.integral_of_int_exn + (Michelson_v1_gas.Internal_for_tests.int_cost_of_manager_operation + 100) + +let test_emptying_undelegated_implicit kind () = + let open Lwt_result_syntax in + let* infos = default_init_ctxt () in + let* fee = + Context.Contract.balance + (B infos.ctxt.block) + (contract_of infos.accounts.source) + in + let* op = + select_op + { + (operation_req_default kind) with + force_reveal = Some true; + fee = Some fee; + gas_limit = Some (Op.Custom_gas empiric_minimal_gas_cost_for_validate); + } + infos + in + let* _ = only_validate_diagnostic infos [op] in + return_unit + +let generate_tests_emptying_undelegated_implicit () = + create_Tztest + test_emptying_undelegated_implicit + "Validate and empties an undelegated source." + subjects + +(** No gas consumer with the minimal gas limit for manager operations + passes validate. *) +let test_low_gas_limit_no_consumer kind () = + let open Lwt_result_syntax in + let* infos = default_init_ctxt () in + let* op = + select_op + { + (operation_req_default kind) with + force_reveal = Some true; + gas_limit = Some Op.Low; + } + infos + in + validate_diagnostic infos [op] + +let generate_low_gas_limit_no_consumer () = + create_Tztest + test_low_gas_limit + "passes validate with minimal gas limit for manager operations." + gas_consumer_in_validate_subjects + +(** Fee payment.*) +let test_validate kind () = + let open Lwt_result_syntax in + let* infos = default_init_ctxt () in + let* counter = + Context.Contract.counter + (B infos.ctxt.block) + (contract_of infos.accounts.source) + in + let* op = + select_op + { + (operation_req_default kind) with + force_reveal = Some true; + counter = Some counter; + } + infos + in + let* _ = validate_diagnostic infos [op] in + return_unit + +let generate_tests_validate () = + create_Tztest test_validate "Validate." subjects + +(* Feature flags.*) + +(* Select the error according to the positionned flag. + We assume that only one feature is disabled. *) +let flag_expect_failure flags errs = + match errs with + | [ + Environment.Ecoproto_error + Validate_operation.Manager.Sc_rollup_feature_disabled; + ] + when flags.scoru = false -> + return_unit + | [ + Environment.Ecoproto_error + Validate_operation.Manager.Tx_rollup_feature_disabled; + ] + when flags.toru = false -> + return_unit + | [Environment.Ecoproto_error Dal_errors.Dal_feature_disabled] + when flags.dal = false -> + return_unit + | err -> + failwith + "Error trace:@, %a does not match the expected one" + Error_monad.pp_print_trace + err + +(* Tests that operations depending on feature flags are not valid + when the flag is set as disable. + + See [is_disabled] and the [flags] in `manager_operation_helpers`. + We assume that only one flag is set at false in flag. + + In order to forge Toru, Scoru or Dal operation when the correspondong + feature is disable, we use a [infos_op] with default requirements, + so that we have a Tx_rollup.t and a Sc_rollup.t. *) +let test_feature_flags flags kind () = + let open Lwt_result_syntax in + let* infos_op = default_init_ctxt () in + let* infos = default_init_with_flags flags in + let infos = + { + infos with + ctxt = + { + infos.ctxt with + tx_rollup = infos_op.ctxt.tx_rollup; + sc_rollup = infos_op.ctxt.sc_rollup; + }; + } + in + let* counter = + Context.Contract.counter + (B infos.ctxt.block) + (contract_of infos.accounts.source) + in + let* op = + select_op + { + {(operation_req_default kind) with force_reveal = Some true} with + counter = Some counter; + } + infos + in + let* _ = + if is_disabled flags kind then + validate_ko_diagnostic infos [op] (flag_expect_failure flags) + else + let* _ = validate_diagnostic infos [op] in + return_unit + in + return_unit + +let generate_dal_flag () = + create_Tztest + (test_feature_flags disabled_dal) + "Validate with dal disabled." + subjects + +let generate_scoru_flag () = + create_Tztest + (test_feature_flags disabled_scoru) + "Validate with scoru disabled." + subjects + +let generate_toru_flag () = + create_Tztest + (test_feature_flags disabled_toru) + "Validate with toru disabled." + subjects + +let sanity_tests = + test_ensure_manager_operation_coverage () :: generate_tests_validate () + +let gas_tests = + generate_low_gas_limit () @ generate_high_gas_limit () + @ generate_tests_exceeding_block_gas () + @ generate_tests_exceeding_block_gas_mp_mode () + @ generate_low_gas_limit_no_consumer () + +let storage_tests = generate_high_storage_limit () + +let fee_tests = + generate_tests_high_fee () + @ generate_tests_emptying_delegated_implicit () + @ generate_tests_emptying_self_delegated_implicit () + @ generate_tests_emptying_undelegated_implicit () + +let contract_tests = + generate_high_counter () @ generate_low_counter () @ generate_not_allocated () + @ generate_unrevealed_key () + +let flags_tests = + generate_dal_flag () @ generate_toru_flag () @ generate_scoru_flag () diff --git a/src/proto_alpha/lib_benchmark/execution_context.ml b/src/proto_alpha/lib_benchmark/execution_context.ml index 86fbdd7278e7e06ecbc7145e122df9f5e09f128a..a44d25fc872136505947f21c3d718837b35a21e4 100644 --- a/src/proto_alpha/lib_benchmark/execution_context.ml +++ b/src/proto_alpha/lib_benchmark/execution_context.ml @@ -58,9 +58,9 @@ let make ~rng_state = let level = Script_int.zero_n in let open Script_interpreter in (match context with - | `Mem_block (block, (bs1, bs2, _, _, _)) -> + | `Mem_block (block, (bs1, _, _, _, _)) -> let source = bs1 in - let payer = bs2 in + let payer = Contract_helpers.default_payer in let self = Contract_helpers.default_self in let step_constants = { diff --git a/src/proto_alpha/lib_benchmarks_proto/interpreter_benchmarks.ml b/src/proto_alpha/lib_benchmarks_proto/interpreter_benchmarks.ml index d372190f4510618057ec5fedf746585198488780..735f29f015b85cc054fd4142130c1f3ee49ba584 100644 --- a/src/proto_alpha/lib_benchmarks_proto/interpreter_benchmarks.ml +++ b/src/proto_alpha/lib_benchmarks_proto/interpreter_benchmarks.ml @@ -2978,11 +2978,10 @@ module Registration_section = struct ~cont_and_stack_sampler:(fun _cfg _rng_state -> let open Script_typed_ir in let open Alpha_context in - let zero = Contract.Implicit Signature.Public_key_hash.zero in let step_constants = { - source = zero; - payer = zero; + source = Contract.Implicit Signature.Public_key_hash.zero; + payer = Signature.Public_key_hash.zero; self = Contract_hash.zero; amount = Tez.zero; balance = Tez.zero; diff --git a/src/proto_alpha/lib_client/client_proto_fa12.mli b/src/proto_alpha/lib_client/client_proto_fa12.mli index 76800482921ca900650c3b0496ec9506b0b37a28..4817f9c68295ededefd170fb10fa918288f77be6 100644 --- a/src/proto_alpha/lib_client/client_proto_fa12.mli +++ b/src/proto_alpha/lib_client/client_proto_fa12.mli @@ -155,7 +155,7 @@ val run_view_action : ?source:Contract.t -> contract:Contract_hash.t -> action:action -> - ?payer:Contract.t -> + ?payer:Signature.public_key_hash -> ?gas:Gas.Arith.integral -> unparsing_mode:Script_ir_translator.unparsing_mode -> unit -> diff --git a/src/proto_alpha/lib_client/client_proto_programs.ml b/src/proto_alpha/lib_client/client_proto_programs.ml index e2e7d31e3803719f9df725ee37a1a49f05879354..728e9ec1baaa1e6c2ab1add4c4726f99ac79b753 100644 --- a/src/proto_alpha/lib_client/client_proto_programs.ml +++ b/src/proto_alpha/lib_client/client_proto_programs.ml @@ -126,7 +126,7 @@ type simulation_params = { now : Script_timestamp.t option; level : Script_int.n Script_int.num option; source : Contract.t option; - payer : Contract.t option; + payer : Signature.public_key_hash option; gas : Gas.Arith.integral option; } diff --git a/src/proto_alpha/lib_client/client_proto_programs.mli b/src/proto_alpha/lib_client/client_proto_programs.mli index dbe6e154e2ab9da1994cf9d051fca871ddd0cf6f..40d5acac1b4f50bc1df8a041a3a5c481f7c4a1dd 100644 --- a/src/proto_alpha/lib_client/client_proto_programs.mli +++ b/src/proto_alpha/lib_client/client_proto_programs.mli @@ -39,7 +39,7 @@ type simulation_params = { now : Script_timestamp.t option; level : Script_int.n Script_int.num option; source : Contract.t option; - payer : Contract.t option; + payer : Signature.public_key_hash option; gas : Gas.Arith.integral option; } diff --git a/src/proto_alpha/lib_client_commands/client_proto_fa12_commands.ml b/src/proto_alpha/lib_client_commands/client_proto_fa12_commands.ml index 3c276d20c0df7a949d323a1681644a232f5657cb..e647c63f2f4e49b15db4a4fc6f698b50ae4ebabb 100644 --- a/src/proto_alpha/lib_client_commands/client_proto_fa12_commands.ml +++ b/src/proto_alpha/lib_client_commands/client_proto_fa12_commands.ml @@ -66,8 +66,8 @@ let as_arg = () let payer_arg = - Client_proto_contracts.ContractAlias.destination_arg - ~name:"payer" + Client_keys.Public_key_hash.source_arg + ~long:"payer" ~doc:"name of the payer (i.e. SOURCE) contract for the transaction" () diff --git a/src/proto_alpha/lib_client_commands/client_proto_programs_commands.ml b/src/proto_alpha/lib_client_commands/client_proto_programs_commands.ml index d82c6be1bc6c8e9a372a055057149908d1129358..39241974d1204dc7ce436f088fe77d967ecf5f12 100644 --- a/src/proto_alpha/lib_client_commands/client_proto_programs_commands.ml +++ b/src/proto_alpha/lib_client_commands/client_proto_programs_commands.ml @@ -91,8 +91,8 @@ let commands () = () in let payer_arg = - ContractAlias.destination_arg - ~name:"payer" + Client_keys.Public_key_hash.source_arg + ~long:"payer" ~doc:"name of the payer (i.e. SOURCE) contract for the transaction" () in diff --git a/src/proto_alpha/lib_delegate/baking_actions.ml b/src/proto_alpha/lib_delegate/baking_actions.ml index c88a975828bcdd54ee34092290ed7a86be7c956b..58d91acbc7bac687eb2832c160806e5e52d6b5c5 100644 --- a/src/proto_alpha/lib_delegate/baking_actions.ml +++ b/src/proto_alpha/lib_delegate/baking_actions.ml @@ -340,6 +340,9 @@ let inject_preendorsements ~state_recorder state ~preendorsements ~updated_state (* N.b. signing a lot of operations may take some time *) (* Don't parallelize signatures: the signer might not be able to handle concurrent requests *) + let block_location = + Baking_files.resolve_location ~chain_id `Highwatermarks + in List.filter_map_es (fun (delegate, consensus_content) -> Events.(emit signing_preendorsement delegate) >>= fun () -> @@ -352,10 +355,8 @@ let inject_preendorsements ~state_recorder state ~preendorsements ~updated_state let contents = Single (Preendorsement consensus_content) in let level = Raw_level.to_int32 consensus_content.level in let round = consensus_content.round in + let sk_uri = delegate.secret_key_uri in cctxt#with_lock (fun () -> - let block_location = - Baking_files.resolve_location ~chain_id `Highwatermarks - in let delegate = delegate.public_key_hash in Baking_highwatermarks.may_sign_preendorsement cctxt @@ -382,9 +383,7 @@ let inject_preendorsements ~state_recorder state ~preendorsements ~updated_state Operation.unsigned_encoding unsigned_operation in - (* TODO: do we want to reload the sk uri or not ? *) - Client_keys.get_key cctxt delegate.public_key_hash >>=? fun (_, _, sk) -> - Client_keys.sign cctxt ~watermark sk unsigned_operation_bytes + Client_keys.sign cctxt ~watermark sk_uri unsigned_operation_bytes else fail (Baking_highwatermarks.Block_previously_preendorsed {round; level})) >>= function @@ -427,6 +426,9 @@ let sign_endorsements state endorsements = (* N.b. signing a lot of operations may take some time *) (* Don't parallelize signatures: the signer might not be able to handle concurrent requests *) + let block_location = + Baking_files.resolve_location ~chain_id `Highwatermarks + in List.filter_map_es (fun (delegate, consensus_content) -> Events.(emit signing_endorsement delegate) >>= fun () -> @@ -442,14 +444,13 @@ let sign_endorsements state endorsements = in let level = Raw_level.to_int32 consensus_content.level in let round = consensus_content.round in + let sk_uri = delegate.secret_key_uri in cctxt#with_lock (fun () -> - let block_location = - Baking_files.resolve_location ~chain_id `Highwatermarks - in + let delegate = delegate.public_key_hash in Baking_highwatermarks.may_sign_endorsement cctxt block_location - ~delegate:delegate.public_key_hash + ~delegate ~level ~round >>=? function @@ -457,7 +458,7 @@ let sign_endorsements state endorsements = Baking_highwatermarks.record_endorsement cctxt block_location - ~delegate:delegate.public_key_hash + ~delegate ~level ~round >>=? fun () -> return_true @@ -471,11 +472,8 @@ let sign_endorsements state endorsements = Operation.unsigned_encoding unsigned_operation in - (* TODO: do we want to reload the sk uri or not ? *) - Client_keys.get_key cctxt delegate.public_key_hash >>=? fun (_, _, sk) -> - Client_keys.sign cctxt ~watermark sk unsigned_operation_bytes - else - fail (Baking_highwatermarks.Block_previously_preendorsed {round; level})) + Client_keys.sign cctxt ~watermark sk_uri unsigned_operation_bytes + else fail (Baking_highwatermarks.Block_previously_endorsed {round; level})) >>= function | Error err -> Events.(emit skipping_endorsement (delegate, err)) >>= fun () -> diff --git a/src/proto_alpha/lib_parameters/default_parameters.ml b/src/proto_alpha/lib_parameters/default_parameters.ml index 458df999709af3bd11428a1579868c2e078cb78d..af4b89778c34f47e4f426ca47b097f974f112866 100644 --- a/src/proto_alpha/lib_parameters/default_parameters.ml +++ b/src/proto_alpha/lib_parameters/default_parameters.ml @@ -89,7 +89,7 @@ let constants_mainnet = Constants.Parametric.preserved_cycles = 5; blocks_per_cycle = 8192l; blocks_per_commitment = 64l; - nonce_revelation_threshold = 32l; + nonce_revelation_threshold = 256l; blocks_per_stake_snapshot = 512l; cycles_per_voting_period = 5l; hard_gas_limit_per_operation = Gas.Arith.(integral_of_int_exn 1_040_000); @@ -97,13 +97,13 @@ let constants_mainnet = proof_of_work_threshold = Int64.(sub (shift_left 1L 46) 1L); tokens_per_roll = Tez.(mul_exn one 6_000); (* VDF's difficulty must be a multiple of `nonce_revelation_threshold` times - the block time. At the moment it is equal to 1B = 1000 * 5 * .2M with - - 1000 ~= 32 * 30 that is nonce_revelation_threshold * block time + the block time. At the moment it is equal to 8B = 8000 * 5 * .2M with + - 8000 ~= 256 * 30 that is nonce_revelation_threshold * block time - .2M ~= number of modular squaring per second on benchmark machine with 2.8GHz CPU - 5: security factor (strictly higher than the ratio between highest CPU clock rate and benchmark machine that is 8.43/2.8 ~= 3 *) - vdf_difficulty = 1_000_000_000L; + vdf_difficulty = 8_000_000_000L; seed_nonce_revelation_tip = (match Tez.(one /? 8L) with Ok c -> c | Error _ -> assert false); origination_size = 257; diff --git a/src/proto_alpha/lib_plugin/RPC.ml b/src/proto_alpha/lib_plugin/RPC.ml index daaac1c42cd298cc851ca6ebb11c76622cedfbf8..4ef926e5a978f9ab0d58d94f4707a46313ae590a 100644 --- a/src/proto_alpha/lib_plugin/RPC.ml +++ b/src/proto_alpha/lib_plugin/RPC.ml @@ -164,7 +164,7 @@ module Scripts = struct (opt "balance" Tez.encoding) (req "chain_id" Chain_id.encoding) (opt "source" Contract.encoding) - (opt "payer" Contract.encoding) + (opt "payer" Contract.implicit_encoding) (opt "self" Contract.originated_encoding) (dft "entrypoint" Entrypoint.simple_encoding Entrypoint.default)) (obj4 @@ -217,7 +217,7 @@ module Scripts = struct (req "input" Script.expr_encoding) (req "chain_id" Chain_id.encoding) (opt "source" Contract.encoding) - (opt "payer" Contract.encoding) + (opt "payer" Contract.implicit_encoding) (opt "gas" Gas.Arith.z_integral_encoding) (req "unparsing_mode" unparsing_mode_encoding) (opt "now" Script_timestamp.encoding) @@ -233,7 +233,7 @@ module Scripts = struct (dft "unlimited_gas" bool false) (req "chain_id" Chain_id.encoding) (opt "source" Contract.encoding) - (opt "payer" Contract.encoding) + (opt "payer" Contract.implicit_encoding) (opt "gas" Gas.Arith.z_integral_encoding) (req "unparsing_mode" unparsing_mode_encoding) (opt "now" Script_timestamp.encoding)) @@ -901,7 +901,7 @@ module Scripts = struct type run_code_config = { balance : Tez.t; self : Contract_hash.t; - payer : Contract.t; + payer : Signature.public_key_hash; source : Contract.t; } @@ -928,6 +928,14 @@ module Scripts = struct balance >>=? fun (ctxt, _) -> return (ctxt, dummy_contract_hash) in + let source_and_payer ~src_opt ~pay_opt ~default_src = + match (src_opt, pay_opt) with + | None, None -> + (Contract.Originated default_src, Signature.Public_key_hash.zero) + | Some c, None -> (c, Signature.Public_key_hash.zero) + | None, Some c -> (Contract.Implicit c, c) + | Some src, Some pay -> (src, pay) + in let configure_contracts ctxt script balance ~src_opt ~pay_opt ~self_opt = (match self_opt with | None -> @@ -942,12 +950,7 @@ module Scripts = struct >>=? fun bal -> return (ctxt, addr, bal)) >>=? fun (ctxt, self, balance) -> let source, payer = - match (src_opt, pay_opt) with - | None, None -> - let self = Contract.Originated self in - (self, self) - | Some c, None | None, Some c -> (c, c) - | Some src, Some pay -> (src, pay) + source_and_payer ~src_opt ~pay_opt ~default_src:self in return (ctxt, {balance; self; source; payer}) in @@ -1134,8 +1137,8 @@ module Scripts = struct entrypoint, input, chain_id, - source, - payer, + src_opt, + pay_opt, gas, unparsing_mode, now, @@ -1160,11 +1163,7 @@ module Scripts = struct Tez.zero >>=? fun (ctxt, viewer_contract) -> let source, payer = - match (source, payer) with - | Some source, Some payer -> (source, payer) - | Some source, None -> (source, source) - | None, Some payer -> (payer, payer) - | None, None -> (contract, contract) + source_and_payer ~src_opt ~pay_opt ~default_src:contract_hash in let gas = Option.value @@ -1234,8 +1233,8 @@ module Scripts = struct input, unlimited_gas, chain_id, - source, - payer, + src_opt, + pay_opt, gas, unparsing_mode, now ), @@ -1253,11 +1252,7 @@ module Scripts = struct >>=? fun (input_ty, output_ty) -> Contract.get_balance ctxt contract >>=? fun balance -> let source, payer = - match (source, payer) with - | Some source, Some payer -> (source, payer) - | Some source, None -> (source, source) - | None, Some payer -> (payer, payer) - | None, None -> (contract, contract) + source_and_payer ~src_opt ~pay_opt ~default_src:contract_hash in let now = match now with None -> Script_timestamp.now ctxt | Some t -> t diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index ab984536b588abd62ca706fdaeca89db5fcfebcf..ef33c165a54e054d83553d0520050dc059c475e4 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -1633,6 +1633,8 @@ module Contract : sig include BASIC_DATA with type t := t + val implicit_encoding : Signature.public_key_hash Data_encoding.t + val originated_encoding : Contract_hash.t Data_encoding.t val in_memory_size : t -> Cache_memory_helpers.sint diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index 89eb16234ab45b222f7e3210388f66801bcc6475..3f9accf971246dc31b5cf1516b998d69fb6907f8 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -837,7 +837,7 @@ let apply_transaction_to_smart_contract ~ctxt ~source ~contract_hash ~amount let open Script_interpreter in { source; - payer = Contract.Implicit payer; + payer; self = contract_hash; amount; chain_id; @@ -3098,7 +3098,7 @@ let apply_liquidity_baking_subsidy ctxt ~toggle_vote = entrypoint. *) { source = liquidity_baking_cpmm_contract; - payer = liquidity_baking_cpmm_contract; + payer = Signature.Public_key_hash.zero; self = liquidity_baking_cpmm_contract_hash; amount = liquidity_baking_subsidy; balance; diff --git a/src/proto_alpha/lib_protocol/init_storage.ml b/src/proto_alpha/lib_protocol/init_storage.ml index b23f509b66ab1dc991ca06e014970da48a559207..90393d2182357be142a5879a3e124a08a27e5fff 100644 --- a/src/proto_alpha/lib_protocol/init_storage.ml +++ b/src/proto_alpha/lib_protocol/init_storage.ml @@ -25,31 +25,27 @@ (* *) (*****************************************************************************) -(* - To add invoices, you can use a helper function like this one: - - (** Invoice a contract at a given address with a given amount. Returns the - updated context and a balance update receipt (singleton list). The address - must be a valid base58 hash, otherwise this is no-op and returns an empty - receipts list. +(** Invoice a contract at a given address with a given amount. Returns the + updated context and a balance update receipt (singleton list). The address + must be a valid base58 hash, otherwise this is no-op and returns an empty + receipts list. - Do not fail if something goes wrong. - *) - let invoice_contract ctxt ~address ~amount_mutez = - match Tez_repr.of_mutez amount_mutez with - | None -> Lwt.return (ctxt, []) - | Some amount -> ( - ( Contract_repr.of_b58check address >>?= fun recipient -> - Token.transfer - ~origin:Protocol_migration - ctxt - `Invoice - (`Contract recipient) - amount ) - >|= function - | Ok res -> res - | Error _ -> (ctxt, [])) + Do not fail if something goes wrong. *) +let invoice_contract ctxt ~address ~amount_mutez = + match Tez_repr.of_mutez amount_mutez with + | None -> Lwt.return (ctxt, []) + | Some amount -> ( + ( Contract_repr.of_b58check address >>?= fun recipient -> + Token.transfer + ~origin:Protocol_migration + ctxt + `Invoice + (`Contract recipient) + amount ) + >|= function + | Ok res -> res + | Error _ -> (ctxt, [])) (* To patch code of legacy contracts you can add a helper function here and call @@ -147,7 +143,11 @@ let prepare_first_block chain_id ctxt ~typecheck ~level ~timestamp = Storage.Tenderbake.First_level_of_protocol.update ctxt level >>=? fun ctxt -> Patch_dictator_for_ghostnet.patch_constant chain_id ctxt >>= fun ctxt -> - return (ctxt, [])) + invoice_contract + ctxt + ~address:"tz1X81bCXPtMiHu1d4UZF4GPhMPkvkp56ssb" + ~amount_mutez:3_000_000_000L + >>= fun (ctxt, balance_updates) -> return (ctxt, balance_updates)) >>=? fun (ctxt, balance_updates) -> Receipt_repr.group_balance_updates balance_updates >>?= fun balance_updates -> Storage.Pending_migration.Balance_updates.add ctxt balance_updates diff --git a/src/proto_alpha/lib_protocol/raw_context.ml b/src/proto_alpha/lib_protocol/raw_context.ml index 28af84754b98d8a202203a5a273bda68755ca7f4..a34b0145576cbea7c545515a79ace8e55dadbc1c 100644 --- a/src/proto_alpha/lib_protocol/raw_context.ml +++ b/src/proto_alpha/lib_protocol/raw_context.ml @@ -909,8 +909,8 @@ let prepare_first_block ~level ~timestamp ctxt = blocks_per_cycle = c.blocks_per_cycle; blocks_per_commitment = c.blocks_per_commitment; nonce_revelation_threshold = - (if Compare.Int32.(32l < c.blocks_per_commitment) then 32l - else c.blocks_per_commitment); + (if Compare.Int32.(256l < c.blocks_per_cycle) then 256l + else (* not on mainnet *) Int32.div c.blocks_per_cycle 2l); blocks_per_stake_snapshot = c.blocks_per_stake_snapshot; cycles_per_voting_period = c.cycles_per_voting_period; hard_gas_limit_per_operation = c.hard_gas_limit_per_operation; @@ -918,9 +918,8 @@ let prepare_first_block ~level ~timestamp ctxt = proof_of_work_threshold = c.proof_of_work_threshold; tokens_per_roll = c.tokens_per_roll; vdf_difficulty = - (if Compare.Int32.(32l < c.blocks_per_commitment) then - 1_000_000_000L - else 50_000L); + (if Compare.Int32.(256l < c.blocks_per_cycle) then 8_000_000_000L + else (* not on mainnet *) 50_000L); seed_nonce_revelation_tip = c.seed_nonce_revelation_tip; origination_size = c.origination_size; max_operations_time_to_live = c.max_operations_time_to_live; diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml index 0432fb11ef57b5ef64375da4393e693450546d98..9178b58ed9538b7cdc1ca8237103a84ad4536a04 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter.ml @@ -91,7 +91,7 @@ module S = Saturation_repr type step_constants = Script_typed_ir.step_constants = { source : Contract.t; - payer : Contract.t; + payer : Signature.public_key_hash; self : Contract_hash.t; amount : Tez.t; balance : Tez.t; @@ -1208,7 +1208,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = let hash = Raw_hashes.sha512 bytes in (step [@ocaml.tailcall]) g gas k ks hash stack | ISource (_, k) -> - let destination : Destination.t = Contract sc.payer in + let destination : Destination.t = Contract (Implicit sc.payer) in let res = {destination; entrypoint = Entrypoint.default} in (step [@ocaml.tailcall]) g gas k ks res (accu, stack) | ISender (_, k) -> diff --git a/src/proto_alpha/lib_protocol/script_interpreter.mli b/src/proto_alpha/lib_protocol/script_interpreter.mli index 797a02f17f824d551ded98d018a0e0f2bf4a0f75..bcca460b020ff01665b55914e43a266cd0a43a44 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.mli +++ b/src/proto_alpha/lib_protocol/script_interpreter.mli @@ -62,7 +62,7 @@ type execution_result = { type step_constants = Script_typed_ir.step_constants = { source : Contract.t; - payer : Contract.t; + payer : Signature.public_key_hash; self : Contract_hash.t; amount : Tez.t; balance : Tez.t; diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.ml b/src/proto_alpha/lib_protocol/script_typed_ir.ml index 60514a7975b4373920e4445072a319aecf99879d..e47943604c640e74284d6bd17af94cb3dce271ee 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir.ml @@ -41,7 +41,7 @@ open Dependent_bool type step_constants = { source : Contract.t; (** The address calling this contract, as returned by SENDER. *) - payer : Contract.t; + payer : Signature.public_key_hash; (** The address of the implicit account that initiated the chain of contract calls, as returned by SOURCE. *) self : Contract_hash.t; (** The address of the contract being executed, as returned by SELF and SELF_ADDRESS. diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.mli b/src/proto_alpha/lib_protocol/script_typed_ir.mli index 010b1ab6f20abd2681836ab42021857aac8121da..0af068f38163302b9085be70d12101c17f00d0df 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.mli +++ b/src/proto_alpha/lib_protocol/script_typed_ir.mli @@ -31,7 +31,7 @@ open Dependent_bool type step_constants = { source : Contract.t; - payer : Contract.t; + payer : Signature.public_key_hash; self : Contract_hash.t; amount : Tez.t; balance : Tez.t; 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 4053b8f6b9b59ddc9c504e196e044583d720c52b..ec4d76ef14250674f6e1508eb787a40ac6a67247 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/contract_helpers.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/contract_helpers.ml @@ -69,13 +69,15 @@ let fake_KT1 = let default_self = fake_KT1 -let default_source = Contract.Implicit Signature.Public_key_hash.zero +let default_payer = Signature.Public_key_hash.zero + +let default_source = Contract.Implicit default_payer let default_step_constants = Script_interpreter. { source = default_source; - payer = default_source; + payer = default_payer; self = default_self; amount = Tez.zero; balance = Tez.zero; diff --git a/src/proto_alpha/lib_protocol/test/helpers/incremental.ml b/src/proto_alpha/lib_protocol/test/helpers/incremental.ml index 195e94ff58fb9f05fd82941c0c93cdcf7435c44c..6d2ad1339282d58eba1e2c14cfb63016656464d8 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/incremental.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/incremental.ml @@ -169,10 +169,10 @@ let apply_operation ?(check_size = true) st op = Constants_repr.max_operation_data_length))) ; apply_operation st.state op >|= Environment.wrap_tzresult -let precheck_operation ?expect_failure ?check_size st op = +let validate_operation ?expect_failure ?check_size st op = apply_operation ?check_size st op >>= fun result -> match (expect_failure, result) with - | Some _, Ok _ -> failwith "Error expected while prechecking operation" + | Some _, Ok _ -> failwith "Error expected while validating operation" | Some f, Error err -> f err >|=? fun () -> st | None, Error err -> failwith "Error %a was not expected" pp_print_trace err | None, Ok (state, (Operation_metadata _ as metadata)) diff --git a/src/proto_alpha/lib_protocol/test/helpers/incremental.mli b/src/proto_alpha/lib_protocol/test/helpers/incremental.mli index 53a824fde6b5df853bb3ebc7410fbbc3d527f17e..804a282f813d7a5ec1634e6a8d4dfcbbd388c955 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/incremental.mli +++ b/src/proto_alpha/lib_protocol/test/helpers/incremental.mli @@ -57,23 +57,23 @@ val begin_construction : Block.t -> incremental tzresult Lwt.t -(** [precheck_operation ?expect_failure ?check_size i op] tries to - precheck [op] in the validation state of [i]. If the precheck +(** [validate_operation ?expect_failure ?check_size i op] tries to + validate [op] in the validation state of [i]. If the validation succeeds, the function returns the incremental value with a - validation state updated after the precheck. Otherwise raise the - error from the prechecking of [op]. + validation state updated after the validate. Otherwise raise the + error from the validation of [op]. Optional arguments allow to override defaults: {ul {li [?expect_failure:(error list -> unit tzresult Lwt.t)]: - precheck of [op] is expected to fail and [expect_failure] should - handle the error. In case precheck does not fail and an - [expect_failure] is provided, [precheck_operation] fails.} + validation of [op] is expected to fail and [expect_failure] should + handle the error. In case validate does not fail and an + [expect_failure] is provided, [validate_operation] fails.} {li [?check_size:bool]: enable the check that an operation size should not exceed [Constants_repr.max_operation_data_length]. Enabled (set to [true]) by default. }} *) -val precheck_operation : +val validate_operation : ?expect_failure:(error list -> unit tzresult Lwt.t) -> ?check_size:bool -> incremental -> @@ -82,16 +82,16 @@ val precheck_operation : (** [add_operation ?expect_failure ?expect_apply_failure ?check_size i op] tries to apply [op] in the validation state of [i]. If the - precheck of [op] succeeds, the function returns the incremental + validation of [op] succeeds, the function returns the incremental value with a validation state updated after the application of - [op]. Otherwise raise the error from the prechecking of [op]. + [op]. Otherwise raise the error from the validation of [op]. Optional arguments allow to override defaults: {ul {li [?expect_failure:(error list -> unit tzresult Lwt.t)]: - precheck of [op] is expected to fail and [expect_failure] should - handle the error. In case precheck does not fail and - [expect_failure] is provided, [precheck_operation] fails.} + validation of [op] is expected to fail and [expect_failure] should + handle the error. In case validate does not fail and + [expect_failure] is provided, [validate_operation] fails.} {ul {li [?expect_apply_failure:(error list -> unit tzresult Lwt.t)]: application of [op] is expected to fail and diff --git a/src/proto_alpha/lib_protocol/test/helpers/op.ml b/src/proto_alpha/lib_protocol/test/helpers/op.ml index b06aa3c76c1ad4244e2a6c0bca4f2150a13e3e4d..ffc6e2daadfcceb70530c60c8c3d0e48417ca512 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/op.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/op.ml @@ -170,6 +170,15 @@ let resolve_gas_limit ctxt = function | Zero -> return Gas.Arith.zero | Custom_gas x -> return x +let pp_gas_limit fmt = function + | Max -> Format.fprintf fmt "Max" + | High -> + Format.fprintf fmt "High: %a" Gas.Arith.pp_integral default_high_gas_limit + | Low -> + Format.fprintf fmt "Low: %a" Gas.Arith.pp_integral default_low_gas_limit + | Zero -> Format.fprintf fmt "Zero: %a" Gas.Arith.pp_integral Gas.Arith.zero + | Custom_gas x -> Format.fprintf fmt "Custom: %a" Gas.Arith.pp_integral x + let combine_operations ?public_key ?counter ?spurious_operation ~source ctxt (packed_operations : packed_operation list) = assert (match packed_operations with [] -> false | _ :: _ -> true) ; diff --git a/src/proto_alpha/lib_protocol/test/helpers/op.mli b/src/proto_alpha/lib_protocol/test/helpers/op.mli index 951547cd2ab9595a04c08e9d0b40bbdd72c021fd..c96b2140df28512518319788e983b53831c13cf6 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/op.mli +++ b/src/proto_alpha/lib_protocol/test/helpers/op.mli @@ -69,6 +69,9 @@ type gas_limit = | Zero | Custom_gas of Gas.Arith.integral +(** Pretty printer for gas_limit type. *) +val pp_gas_limit : Format.formatter -> gas_limit -> unit + val transaction : ?force_reveal:bool -> ?counter:Z.t -> diff --git a/src/proto_alpha/lib_protocol/test/integration/precheck/manager_operation_helpers.ml b/src/proto_alpha/lib_protocol/test/integration/precheck/manager_operation_helpers.ml deleted file mode 100644 index 8da4b841045325615952fa3838d3e223ec1d54a5..0000000000000000000000000000000000000000 --- a/src/proto_alpha/lib_protocol/test/integration/precheck/manager_operation_helpers.ml +++ /dev/null @@ -1,958 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -open Protocol -open Alpha_context -open Test_tez - -(* Hard gas limit *) -let gb_limit = Gas.Arith.(integral_of_int_exn 100_000) - -let half_gb_limit = Gas.Arith.(integral_of_int_exn 50_000) - -type infos = { - block : Block.t; - account1 : Account.t; - contract1 : Contract.t; - account2 : Account.t; - contract2 : Contract.t; - account3 : Account.t; - contract3 : Contract.t; - contract_hash : Contract_hash.t; - tx_rollup : Tx_rollup.t; - sc_rollup : Sc_rollup.t; -} - -(* Initialize an [infos] record with a context enabling tx and sc - rollup, funded accounts, tx_rollup, sc_rollup *) -let init_context ?hard_gas_limit_per_block () = - let open Lwt_result_syntax in - let* b, bootstrap_contract = - Context.init1 - ~consensus_threshold:0 - ?hard_gas_limit_per_block - ~tx_rollup_enable:true - ~tx_rollup_sunset_level:Int32.max_int - ~sc_rollup_enable:true - ~dal_enable:true - () - in - (* Set a gas_limit to avoid the default gas_limit of the helpers - ([hard_gas_limit_per_operation]) *) - let gas_limit = Op.Custom_gas (Gas.Arith.integral_of_int_exn 10_000) in - (* Create and fund an account use for originate a Tx and a Sc - rollup *) - let rollup_account = Account.new_account () in - let rollup_contract = Contract.Implicit rollup_account.pkh in - let counter = Z.zero in - let* fund_rollup_account = - Op.transaction - ~force_reveal:true - ~counter - ~gas_limit - (B b) - bootstrap_contract - rollup_contract - Tez.one - in - let* b = Block.bake ~operation:fund_rollup_account b in - let counter2 = Z.succ counter in - let* rollup_origination, tx_rollup = - Op.tx_rollup_origination - ~force_reveal:true - ~counter:counter2 - ~gas_limit - (B b) - rollup_contract - in - let* _, sc_rollup = - Op.sc_rollup_origination - ~counter:counter2 - ~gas_limit - (B b) - rollup_contract - Sc_rollup.Kind.Example_arith - "" - (Script.lazy_expr (Expr.from_string "1")) - in - let* b = Block.bake ~operation:rollup_origination b in - (* Create and fund three accounts *) - let account1 = Account.new_account () in - let contract1 = Contract.Implicit account1.pkh in - let counter = Z.succ counter in - let* fund_account1 = - Op.transaction - ~counter - ~gas_limit - (B b) - bootstrap_contract - contract1 - Tez.one - in - let account2 = Account.new_account () in - let contract2 = Contract.Implicit account2.pkh in - let counter = Z.succ counter in - let* fund_account2 = - Op.transaction - ~counter - ~gas_limit - (B b) - bootstrap_contract - contract2 - Tez.one - in - let account3 = Account.new_account () in - let contract3 = Contract.Implicit account3.pkh in - let counter = Z.succ counter in - let* fund_account3 = - Op.transaction - ~counter - ~gas_limit - (B b) - bootstrap_contract - contract3 - Tez.one - in - let* create_contract_hash, contract_hash = - Op.contract_origination_hash - (B b) - contract3 - ~fee:Tez.zero - ~script:Op.dummy_script - in - let* operation = - Op.batch_operations - ~source:bootstrap_contract - (B b) - [fund_account1; fund_account2; fund_account3; create_contract_hash] - in - let+ block = Block.bake ~operation b in - { - block; - account1; - contract1; - account2; - contract2; - account3; - contract3; - contract_hash; - tx_rollup; - sc_rollup; - } - -(* Same as [init_context] but [contract1] delegate to [contract2] *) -let init_delegated_implicit () = - let open Lwt_result_syntax in - let* infos = init_context () in - let* del_opt = - Context.Contract.delegate_opt (B infos.block) infos.contract1 - in - let* _ = - Assert.is_none - ~loc:__LOC__ - ~pp:(fun fmt _ -> Format.fprintf fmt "should not be delegated") - del_opt - in - let* operation = - Op.delegation - ~force_reveal:true - (B infos.block) - infos.contract2 - (Some (Context.Contract.pkh infos.contract2)) - in - let* block = Block.bake infos.block ~operation in - let* operation = - Op.delegation - ~force_reveal:true - (B block) - infos.contract1 - (Some infos.account2.pkh) - in - let* block = Block.bake block ~operation in - let* del_opt_new = Context.Contract.delegate_opt (B block) infos.contract1 in - let* del = Assert.get_some ~loc:__LOC__ del_opt_new in - let+ _ = Assert.equal_pkh ~loc:__LOC__ del infos.account2.pkh in - {infos with block} - -(* Same as [init_context] but [contract1] self delegate. *) -let init_self_delegated_implicit () = - let open Lwt_result_syntax in - let* infos = init_context () in - let* del_opt = - Context.Contract.delegate_opt (B infos.block) infos.contract1 - in - let* _ = - Assert.is_none - ~loc:__LOC__ - ~pp:(fun fmt _ -> Format.fprintf fmt "should not be delegated") - del_opt - in - let* operation = - Op.delegation - ~force_reveal:true - (B infos.block) - infos.contract1 - (Some infos.account1.pkh) - in - let* block = Block.bake infos.block ~operation in - let* del_opt_new = Context.Contract.delegate_opt (B block) infos.contract1 in - let* del = Assert.get_some ~loc:__LOC__ del_opt_new in - let+ _ = Assert.equal_pkh ~loc:__LOC__ del infos.account1.pkh in - {infos with block} - -(* Local helpers for generating all kind of manager operations. *) - -(* Create a fresh account used for empty implicit account tests. *) -let mk_fresh_contract () = Contract.Implicit Account.(new_account ()).pkh - -let get_pkh source = Context.Contract.pkh source - -let get_pk infos source = - let open Lwt_result_syntax in - let+ account = Context.Contract.manager infos source in - account.pk - -let mk_transaction ?counter ?fee ?gas_limit ?storage_limit ?force_reveal ~source - (infos : infos) = - Op.transaction - ?force_reveal - ?counter - ?fee - ?gas_limit - ?storage_limit - (B infos.block) - source - infos.contract2 - Tez.one - -let mk_delegation ?counter ?fee ?gas_limit ?storage_limit ?force_reveal ~source - (infos : infos) = - Op.delegation - ?force_reveal - ?fee - ?gas_limit - ?counter - ?storage_limit - (B infos.block) - source - (Some infos.account2.pkh) - -let mk_undelegation ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ~source (infos : infos) = - Op.delegation - ?force_reveal - ?fee - ?gas_limit - ?counter - ?storage_limit - (B infos.block) - source - None - -let mk_self_delegation ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ~source (infos : infos) = - Op.delegation - ?force_reveal - ?fee - ?gas_limit - ?counter - ?storage_limit - (B infos.block) - source - (Some (get_pkh source)) - -let mk_origination ?counter ?fee ?gas_limit ?storage_limit ?force_reveal ~source - (infos : infos) = - let open Lwt_result_syntax in - let+ op, _ = - Op.contract_origination - ?force_reveal - ?counter - ?fee - ?gas_limit - ?storage_limit - ~script:Op.dummy_script - (B infos.block) - source - in - op - -let mk_register_global_constant ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = - Op.register_global_constant - ?force_reveal - ?counter - ?fee - ?gas_limit - ?storage_limit - (B infos.block) - ~source - ~value:(Script_repr.lazy_expr (Expr.from_string "Pair 1 2")) - -let mk_set_deposits_limit ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ~source (infos : infos) = - Op.set_deposits_limit - ?force_reveal - ?fee - ?gas_limit - ?storage_limit - ?counter - (B infos.block) - source - None - -let mk_increase_paid_storage ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = - Op.increase_paid_storage - ?force_reveal - ?counter - ?fee - ?gas_limit - ?storage_limit - (B infos.block) - ~source - ~destination:infos.contract_hash - Z.one - -let mk_reveal ?counter ?fee ?gas_limit ?storage_limit ?force_reveal:_ ~source - (infos : infos) = - let open Lwt_result_syntax in - let* pk = get_pk (B infos.block) source in - Op.revelation ?fee ?gas_limit ?counter ?storage_limit (B infos.block) pk - -let mk_tx_rollup_origination ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = - let open Lwt_result_syntax in - let+ op, _rollup = - Op.tx_rollup_origination - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - in - op - -let mk_tx_rollup_submit_batch ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = - Op.tx_rollup_submit_batch - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.tx_rollup - "batch" - -let mk_tx_rollup_commit ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ~source (infos : infos) = - let commitement : Tx_rollup_commitment.Full.t = - { - level = Tx_rollup_level.root; - messages = []; - predecessor = None; - inbox_merkle_root = Tx_rollup_inbox.Merkle.merklize_list []; - } - in - Op.tx_rollup_commit - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.tx_rollup - commitement - -let mk_tx_rollup_return_bond ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = - Op.tx_rollup_return_bond - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.tx_rollup - -let mk_tx_rollup_finalize ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ~source (infos : infos) = - Op.tx_rollup_finalize - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.tx_rollup - -let mk_tx_rollup_remove_commitment ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = - Op.tx_rollup_remove_commitment - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.tx_rollup - -let mk_tx_rollup_reject ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ~source (infos : infos) = - let message, _ = Tx_rollup_message.make_batch "" in - let message_hash = Tx_rollup_message_hash.hash_uncarbonated message in - let message_path = - match Tx_rollup_inbox.Merkle.compute_path [message_hash] 0 with - | Ok message_path -> message_path - | _ -> raise (Invalid_argument "Single_message_inbox.message_path") - in - let proof : Tx_rollup_l2_proof.t = - { - version = 1; - before = `Value Tx_rollup_message_result.empty_l2_context_hash; - after = `Value Context_hash.zero; - state = Seq.empty; - } - in - let previous_message_result : Tx_rollup_message_result.t = - { - context_hash = Tx_rollup_message_result.empty_l2_context_hash; - withdraw_list_hash = Tx_rollup_withdraw_list_hash.empty; - } - in - Op.tx_rollup_reject - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.tx_rollup - Tx_rollup_level.root - message - ~message_position:0 - ~message_path - ~message_result_hash:Tx_rollup_message_result_hash.zero - ~message_result_path:Tx_rollup_commitment.Merkle.dummy_path - ~proof - ~previous_message_result - ~previous_message_result_path:Tx_rollup_commitment.Merkle.dummy_path - -let mk_transfer_ticket ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ~source (infos : infos) = - Op.transfer_ticket - ?fee - ?force_reveal - ?counter - ?gas_limit - ?storage_limit - (B infos.block) - ~source - ~contents:(Script.lazy_expr (Expr.from_string "1")) - ~ty:(Script.lazy_expr (Expr.from_string "nat")) - ~ticketer:infos.contract3 - Z.zero - ~destination:infos.contract2 - Entrypoint.default - -let mk_tx_rollup_dispacth_ticket ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = - let reveal = - Tx_rollup_reveal. - { - contents = Script.lazy_expr (Expr.from_string "1"); - ty = Script.lazy_expr (Expr.from_string "nat"); - ticketer = infos.contract2; - amount = Tx_rollup_l2_qty.of_int64_exn 10L; - claimer = infos.account3.pkh; - } - in - Op.tx_rollup_dispatch_tickets - ?fee - ?force_reveal - ?counter - ?gas_limit - ?storage_limit - (B infos.block) - ~source - ~message_index:0 - ~message_result_path:Tx_rollup_commitment.Merkle.dummy_path - infos.tx_rollup - Tx_rollup_level.root - Context_hash.zero - [reveal] - -let mk_sc_rollup_origination ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = - let open Lwt_result_syntax in - let+ op, _ = - Op.sc_rollup_origination - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - Sc_rollup.Kind.Example_arith - "" - (Script.lazy_expr (Expr.from_string "1")) - in - op - -let sc_dummy_commitment = - let number_of_ticks = - match Sc_rollup.Number_of_ticks.of_int32 3000l with - | None -> assert false - | Some x -> x - in - Sc_rollup.Commitment. - { - predecessor = Sc_rollup.Commitment.Hash.zero; - inbox_level = Raw_level.of_int32_exn Int32.zero; - number_of_ticks; - compressed_state = Sc_rollup.State_hash.zero; - } - -let mk_sc_rollup_publish ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ~source (infos : infos) = - Op.sc_rollup_publish - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.sc_rollup - sc_dummy_commitment - -let mk_sc_rollup_cement ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ~source (infos : infos) = - Op.sc_rollup_cement - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.sc_rollup - (Sc_rollup.Commitment.hash sc_dummy_commitment) - -let mk_sc_rollup_refute ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ~source (infos : infos) = - let refutation : Sc_rollup.Game.refutation = - {choice = Sc_rollup.Tick.initial; step = Dissection []} - in - Op.sc_rollup_refute - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.sc_rollup - infos.account2.pkh - (Some refutation) - -let mk_sc_rollup_add_messages ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = - Op.sc_rollup_add_messages - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.sc_rollup - [] - -let mk_sc_rollup_timeout ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ~source (infos : infos) = - Op.sc_rollup_timeout - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.sc_rollup - (Sc_rollup.Game.Index.make infos.account2.pkh infos.account3.pkh) - -let mk_sc_rollup_execute_outbox_message ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = - Op.sc_rollup_execute_outbox_message - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.sc_rollup - (Sc_rollup.Commitment.hash sc_dummy_commitment) - ~output_proof:"" - -let mk_sc_rollup_return_bond ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = - Op.sc_rollup_recover_bond - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.sc_rollup - -let mk_dal_publish_slot_header ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = - let open Lwt_result_syntax in - let level = 0 in - let index = 0 in - let header = 0 in - let json_slot = - Data_encoding.Json.from_string - (Format.asprintf - {|{"level":%d,"index":%d,"header":%d}|} - level - index - header) - in - let* json_slot = - match json_slot with Error s -> failwith "%s" s | Ok slot -> return slot - in - let slot = Data_encoding.Json.destruct Dal.Slot.encoding json_slot in - Op.dal_publish_slot_header - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - slot - -(* Helpers for generation of generic check tests by manager operation. *) -(* This type should be extended for each new manager_operation kind - added in the protocol. *) -type manager_operation_kind = - | K_Transaction - | K_Origination - | K_Register_global_constant - | K_Delegation - | K_Undelegation - | K_Self_delegation - | K_Set_deposits_limit - | K_Increase_paid_storage - | K_Reveal - | K_Tx_rollup_origination - | K_Tx_rollup_submit_batch - | K_Tx_rollup_commit - | K_Tx_rollup_return_bond - | K_Tx_rollup_finalize - | K_Tx_rollup_remove_commitment - | K_Tx_rollup_dispatch_tickets - | K_Transfer_ticket - | K_Tx_rollup_reject - | K_Sc_rollup_origination - | K_Sc_rollup_publish - | K_Sc_rollup_cement - | K_Sc_rollup_add_messages - | K_Sc_rollup_refute - | K_Sc_rollup_timeout - | K_Sc_rollup_execute_outbox_message - | K_Sc_rollup_recover_bond - | K_Dal_publish_slot_header - -let select_op = function - | K_Transaction -> mk_transaction - | K_Origination -> mk_origination - | K_Register_global_constant -> mk_register_global_constant - | K_Delegation -> mk_delegation - | K_Undelegation -> mk_undelegation - | K_Self_delegation -> mk_self_delegation - | K_Set_deposits_limit -> mk_set_deposits_limit - | K_Increase_paid_storage -> mk_increase_paid_storage - | K_Reveal -> mk_reveal - | K_Tx_rollup_origination -> mk_tx_rollup_origination - | K_Tx_rollup_submit_batch -> mk_tx_rollup_submit_batch - | K_Tx_rollup_commit -> mk_tx_rollup_commit - | K_Tx_rollup_return_bond -> mk_tx_rollup_return_bond - | K_Tx_rollup_finalize -> mk_tx_rollup_finalize - | K_Tx_rollup_remove_commitment -> mk_tx_rollup_remove_commitment - | K_Tx_rollup_reject -> mk_tx_rollup_reject - | K_Transfer_ticket -> mk_transfer_ticket - | K_Tx_rollup_dispatch_tickets -> mk_tx_rollup_dispacth_ticket - | K_Sc_rollup_origination -> mk_sc_rollup_origination - | K_Sc_rollup_publish -> mk_sc_rollup_publish - | K_Sc_rollup_cement -> mk_sc_rollup_cement - | K_Sc_rollup_refute -> mk_sc_rollup_refute - | K_Sc_rollup_add_messages -> mk_sc_rollup_add_messages - | K_Sc_rollup_timeout -> mk_sc_rollup_timeout - | K_Sc_rollup_execute_outbox_message -> mk_sc_rollup_execute_outbox_message - | K_Sc_rollup_recover_bond -> mk_sc_rollup_return_bond - | K_Dal_publish_slot_header -> mk_dal_publish_slot_header - -let string_of_kind = function - | K_Transaction -> "Transaction" - | K_Delegation -> "Delegation" - | K_Undelegation -> "Undelegation" - | K_Self_delegation -> "Self-delegation" - | K_Set_deposits_limit -> "Set deposits limit" - | K_Origination -> "Origination" - | K_Register_global_constant -> "Register global constant" - | K_Increase_paid_storage -> "Increase paid storage" - | K_Reveal -> "Revelation" - | K_Tx_rollup_origination -> "Tx_rollup_origination" - | K_Tx_rollup_submit_batch -> "Tx_rollup_submit_batch" - | K_Tx_rollup_commit -> "Tx_rollup_commit" - | K_Tx_rollup_return_bond -> "Tx_rollup_return_bond" - | K_Tx_rollup_finalize -> "Tx_rollup_finalize" - | K_Tx_rollup_remove_commitment -> "Tx_rollup_remove_commitment" - | K_Tx_rollup_dispatch_tickets -> "Tx_rollup_dispatch_tickets" - | K_Tx_rollup_reject -> "Tx_rollup_reject" - | K_Transfer_ticket -> "Transfer_ticket" - | K_Sc_rollup_origination -> "Sc_rollup_origination" - | K_Sc_rollup_publish -> "Sc_rollup_publish" - | K_Sc_rollup_cement -> "Sc_rollup_cement" - | K_Sc_rollup_timeout -> "Sc_rollup_timeout" - | K_Sc_rollup_refute -> "Sc_rollup_refute" - | K_Sc_rollup_add_messages -> "Sc_rollup_add_messages" - | K_Sc_rollup_execute_outbox_message -> "Sc_rollup_execute_outbox_message" - | K_Sc_rollup_recover_bond -> "Sc_rollup_return_bond" - | K_Dal_publish_slot_header -> "Dal_publish_slot_header" - -let create_Tztest ?hd_msg test tests_msg operations = - let hd_msg k = - let sk = string_of_kind k in - match hd_msg with - | None -> sk - | Some hd -> Format.sprintf "Batch: %s, %s" hd sk - in - List.map - (fun kind -> - Tztest.tztest - (Format.sprintf "%s with %s" (hd_msg kind) tests_msg) - `Quick - (fun () -> test kind ())) - operations - -let rec create_Tztest_batches test tests_msg operations = - let hdmsg k = Format.sprintf "%s" (string_of_kind k) in - let aux hd_msg test operations = - create_Tztest ~hd_msg test tests_msg operations - in - match operations with - | [] -> [] - | kop :: kops as ops -> - aux (hdmsg kop) (test kop) ops @ create_Tztest_batches test tests_msg kops - -(* Diagnostic helpers. *) -(* The purpose of diagnostic helpers is to state the correct observation - according to the precheck result of a test. *) - -(* For a manager operation a [probes] contains the values required for observing - its precheck success. Its source, fees (sum for a batch), gas_limit - (sum of gas_limit of the batch), and the increment of the counters aka 1 for - a single operation, n for a batch of n manager operations. *) -type probes = { - source : Signature.Public_key_hash.t; - fee : Tez.tez; - gas_limit : Gas.Arith.integral; - nb_counter : Z.t; -} - -let rec contents_infos : - type kind. kind Kind.manager contents_list -> probes tzresult Lwt.t = - fun op -> - let open Lwt_result_syntax in - match op with - | Single (Manager_operation {source; fee; gas_limit; _}) -> - return {source; fee; gas_limit; nb_counter = Z.one} - | Cons (Manager_operation manop, manops) -> - let* probes = contents_infos manops in - let*? fee = manop.fee +? probes.fee in - let gas_limit = Gas.Arith.add probes.gas_limit manop.gas_limit in - let nb_counter = Z.succ probes.nb_counter in - let _ = Assert.equal_pkh ~loc:__LOC__ manop.source probes.source in - return {fee; source = probes.source; gas_limit; nb_counter} - -(* Computes a [probes] from a list of manager contents. *) -let manager_content_infos op = - let (Operation_data {contents; _}) = op.protocol_data in - match contents with - | Single (Manager_operation _) as op -> contents_infos op - | Cons (Manager_operation _, _) as op -> contents_infos op - | _ -> assert false - -(* [observe] asserts the success of precheck only. - Given on one side, a [contract], its initial balance [b_in], its initial - counter [c_in] and potentially the initial gas [g_in] before its prechecking; - and, on the other side, its [probes] and the context after its precheck [i]; - if precheck succeeds then we observe in [i] that: - - [contract] balance decreases by [probes.fee] when [only_precheck] marks that only the precheck - succeeds - - [contract] balance decreases at least by [probes.fee] when ![only_precheck] marks - that the application has succeeded, - - its counter [c_in] increases by [probes.nb_counter], and - - the available gas in the block in [i] decreases by [g_in].*) -let observe ~only_precheck contract b_in c_in g_in probes i = - let open Lwt_result_syntax in - let* b_out = Context.Contract.balance (I i) contract in - let g_out = Gas.block_level (Incremental.alpha_ctxt i) in - let* c_out = Context.Contract.counter (I i) contract in - let*? b_expected = b_in -? probes.fee in - let b_cmp = - Assert.equal - ~loc:__LOC__ - (if only_precheck then Tez.( = ) else Tez.( <= )) - "Balance update" - Tez.pp - in - let* _ = b_cmp b_out b_expected in - let c_expected = Z.add c_in probes.nb_counter in - let _ = - Assert.equal - Z.equal - ~loc:__LOC__ - "Counter incrementation" - Z.pp_print - c_out - c_expected - in - let g_expected = Gas.Arith.sub g_in (Gas.Arith.fp probes.gas_limit) in - Assert.equal - ~loc:__LOC__ - Gas.Arith.equal - "Gas consumption" - Gas.Arith.pp - g_out - g_expected - -let precheck_with_diagnostic ~only_precheck (infos : infos) op = - let open Lwt_result_syntax in - let* i = Incremental.begin_construction infos.block in - let* prbs = manager_content_infos op in - let contract = Contract.Implicit prbs.source in - let* b_in = Context.Contract.balance (I i) contract in - let* c_in = Context.Contract.counter (I i) contract in - let g_in = Gas.block_level (Incremental.alpha_ctxt i) in - let* i = Incremental.precheck_operation i op in - let* _ = Incremental.finalize_block i in - observe ~only_precheck contract b_in c_in g_in prbs i - -(* If only the precheck of an operation succeed; e.g. the rest - of the application failed: - - the fees must be paid, - - the block gas consumption should be decreased, and - - the counter of operation should be incremented - as defined by [observe] with [only_precheck]. *) -let only_precheck_diagnostic (infos : infos) op = - precheck_with_diagnostic ~only_precheck:true infos op - -(* If an manager operation application succeed, the precheck - effects must be observed: - - the fees must be paid, - - the block gas consumption should be decreased, and - - the counter of operation should be incremented - as defined by [observe] with ![only_precheck]. *) -let precheck_diagnostic (infos : infos) op = - precheck_with_diagnostic ~only_precheck:false infos op - -(* [precheck_ko_diagnostic] wraps the [expect_failure] when [op] precheck - failed. It is used in test that expects precheck [op] to fail. *) -let precheck_ko_diagnostic ?(mempool_mode = false) (infos : infos) op - expect_failure = - let open Lwt_result_syntax in - let* i = Incremental.begin_construction infos.block ~mempool_mode in - let* _ = Incremental.add_operation ~expect_failure i op in - return_unit - -(* List of operation kind that must run on generic tests. This list - should be extended for each new manager_operation kind. *) -let subjects = - [ - K_Transaction; - K_Origination; - K_Register_global_constant; - K_Delegation; - K_Undelegation; - K_Self_delegation; - K_Set_deposits_limit; - K_Increase_paid_storage; - K_Reveal; - K_Tx_rollup_origination; - K_Tx_rollup_submit_batch; - K_Tx_rollup_commit; - K_Tx_rollup_return_bond; - K_Tx_rollup_finalize; - K_Tx_rollup_remove_commitment; - K_Tx_rollup_dispatch_tickets; - K_Transfer_ticket; - K_Tx_rollup_reject; - K_Sc_rollup_origination; - K_Sc_rollup_publish; - K_Sc_rollup_cement; - K_Sc_rollup_add_messages; - K_Sc_rollup_refute; - K_Sc_rollup_timeout; - K_Sc_rollup_execute_outbox_message; - K_Sc_rollup_recover_bond; - K_Dal_publish_slot_header; - ] - -let is_consumer = function - | K_Set_deposits_limit | K_Increase_paid_storage | K_Reveal - | K_Self_delegation | K_Delegation | K_Undelegation | K_Tx_rollup_origination - | K_Tx_rollup_submit_batch | K_Tx_rollup_finalize | K_Tx_rollup_commit - | K_Tx_rollup_return_bond | K_Tx_rollup_remove_commitment | K_Tx_rollup_reject - | K_Sc_rollup_add_messages | K_Sc_rollup_origination | K_Sc_rollup_refute - | K_Sc_rollup_timeout | K_Sc_rollup_cement | K_Sc_rollup_publish - | K_Sc_rollup_execute_outbox_message | K_Sc_rollup_recover_bond - | K_Dal_publish_slot_header -> - false - | K_Transaction | K_Origination | K_Register_global_constant - | K_Tx_rollup_dispatch_tickets | K_Transfer_ticket -> - true - -let gas_consumer_in_precheck_subjects, not_gas_consumer_in_precheck_subjects = - List.partition is_consumer subjects - -let revealed_subjects = - List.filter (function K_Reveal -> false | _ -> true) subjects diff --git a/src/proto_alpha/lib_protocol/test/integration/precheck/test_manager_operation_precheck.ml b/src/proto_alpha/lib_protocol/test/integration/precheck/test_manager_operation_precheck.ml deleted file mode 100644 index 79831ff4c6082933472274884967fcabfde6bcb4..0000000000000000000000000000000000000000 --- a/src/proto_alpha/lib_protocol/test/integration/precheck/test_manager_operation_precheck.ml +++ /dev/null @@ -1,570 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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: Protocol (precheck manager) - Invocation: dune exec \ - src/proto_alpha/lib_protocol/test/integration/precheck/main.exe \ - -- test "^Single$" - Subject: Precheck manager operation. -*) - -open Protocol -open Alpha_context -open Manager_operation_helpers - -(* The goal of this test is to ensure that [select_op] generate the - wanted kind of manager operation - - Note: if a new manager operation kind is added in the protocol, - [Manager_operation_helpers.manager_operation_kind] should be - extended. You will also have to extend - [Manager_operation_helpers.select_op] with a new `mk` for this new - operation. Finally the list [Manager_operation_helpers.subjects] - should also be extended to run the precheck test on the new manager - operation kind. *) -let ensure_kind infos kind = - let open Lwt_result_syntax in - let* op = select_op kind infos ~force_reveal:false ~source:infos.contract1 in - let (Operation_data {contents; _}) = op.protocol_data in - match contents with - | Single (Manager_operation {operation; _}) -> ( - match (operation, kind) with - | Transaction _, K_Transaction - | Reveal _, K_Reveal - | Origination _, K_Origination - | Delegation _, K_Delegation - | Delegation _, K_Undelegation - | Delegation _, K_Self_delegation - | Register_global_constant _, K_Register_global_constant - | Set_deposits_limit _, K_Set_deposits_limit - | Increase_paid_storage _, K_Increase_paid_storage - | Tx_rollup_origination, K_Tx_rollup_origination - | Tx_rollup_submit_batch _, K_Tx_rollup_submit_batch - | Tx_rollup_commit _, K_Tx_rollup_commit - | Tx_rollup_return_bond _, K_Tx_rollup_return_bond - | Tx_rollup_finalize_commitment _, K_Tx_rollup_finalize - | Tx_rollup_remove_commitment _, K_Tx_rollup_remove_commitment - | Tx_rollup_rejection _, K_Tx_rollup_reject - | Tx_rollup_dispatch_tickets _, K_Tx_rollup_dispatch_tickets - | Transfer_ticket _, K_Transfer_ticket - | Sc_rollup_originate _, K_Sc_rollup_origination - | Sc_rollup_add_messages _, K_Sc_rollup_add_messages - | Sc_rollup_cement _, K_Sc_rollup_cement - | Sc_rollup_publish _, K_Sc_rollup_publish - | Sc_rollup_refute _, K_Sc_rollup_refute - | Sc_rollup_timeout _, K_Sc_rollup_timeout - | Sc_rollup_execute_outbox_message _, K_Sc_rollup_execute_outbox_message - | Sc_rollup_recover_bond _, K_Sc_rollup_recover_bond - | Dal_publish_slot_header _, K_Dal_publish_slot_header -> - return_unit - | ( ( Transaction _ | Origination _ | Register_global_constant _ - | Delegation _ | Set_deposits_limit _ | Increase_paid_storage _ - | Reveal _ | Tx_rollup_origination | Tx_rollup_submit_batch _ - | Tx_rollup_commit _ | Tx_rollup_return_bond _ - | Tx_rollup_finalize_commitment _ | Tx_rollup_remove_commitment _ - | Tx_rollup_dispatch_tickets _ | Transfer_ticket _ - | Tx_rollup_rejection _ | Sc_rollup_originate _ | Sc_rollup_publish _ - | Sc_rollup_cement _ | Sc_rollup_add_messages _ | Sc_rollup_refute _ - | Sc_rollup_timeout _ | Sc_rollup_execute_outbox_message _ - | Sc_rollup_recover_bond _ | Dal_publish_slot_header _ - | Sc_rollup_dal_slot_subscribe _ ), - _ ) -> - assert false) - | Single _ -> assert false - | Cons _ -> assert false - -let ensure_manager_operation_coverage () = - let open Lwt_result_syntax in - let* infos = init_context () in - List.iter_es (fun kind -> ensure_kind infos kind) subjects - -let test_ensure_manager_operation_coverage () = - Tztest.tztest - (Format.sprintf "Ensure manager_operation coverage") - `Quick - (fun () -> ensure_manager_operation_coverage ()) - -(* Negative tests assert the case where precheck must fail. *) - -(* Precheck fails if the gas limit is too low. - - This test asserts that the precheck of a manager's operation - with a too low gas limit fails at precheck with an - [Gas_quota_exceeded_init_deserialize] error. - This test applies on manager operations that do not - consume gas in their specific part of precheck. *) -let low_gas_limit_diagnostic (infos : infos) op = - let expect_failure errs = - match errs with - | [ - Environment.Ecoproto_error - Validate_operation.Manager.Gas_quota_exceeded_init_deserialize; - Environment.Ecoproto_error Raw_context.Operation_quota_exceeded; - ] -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - precheck_ko_diagnostic infos op expect_failure - -let test_low_gas_limit kind () = - let open Lwt_result_syntax in - let* infos = init_context () in - let gas_limit = Op.Low in - let* op = - select_op ~gas_limit ~force_reveal:true ~source:infos.contract1 kind infos - in - low_gas_limit_diagnostic infos op - -let generate_low_gas_limit () = - create_Tztest - test_low_gas_limit - "Gas_limit too low." - gas_consumer_in_precheck_subjects - -(* Precheck fails if the gas limit is too high. - - This test asserts that the precheck of a manager operation with - a gas limit too high fails at precheck with an [Gas_limit_too_high] - error. It applies on every kind of manager operation. *) -let high_gas_limit_diagnostic (infos : infos) op = - let expect_failure errs = - match errs with - | [Environment.Ecoproto_error Gas.Gas_limit_too_high] -> return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - precheck_ko_diagnostic infos op expect_failure - -let test_high_gas_limit kind () = - let open Lwt_result_syntax in - let* infos = init_context () in - let gas_limit = Op.Custom_gas (Gas.Arith.integral_of_int_exn 10_000_000) in - let* op = - select_op ~gas_limit ~force_reveal:true ~source:infos.contract1 kind infos - in - high_gas_limit_diagnostic infos op - -let generate_high_gas_limit () = - create_Tztest test_high_gas_limit "Gas_limit too high." subjects - -(* Precheck fails if the storage limit is too high. - - This test asserts that a manager operation with a storage limit - too high fails at precheck with [Storage_limit_too_high] error. - It applies to every kind of manager operation. *) -let high_storage_limit_diagnostic (infos : infos) op = - let expect_failure errs = - match errs with - | [Environment.Ecoproto_error Fees_storage.Storage_limit_too_high] -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - precheck_ko_diagnostic infos op expect_failure - -let test_high_storage_limit kind () = - let open Lwt_result_syntax in - let* infos = init_context () in - let storage_limit = Z.of_int max_int in - let* op = - select_op - ~storage_limit - ~force_reveal:true - ~source:infos.contract1 - kind - infos - in - high_storage_limit_diagnostic infos op - -let generate_high_storage_limit () = - create_Tztest test_high_gas_limit "Storage_limit too high." subjects - -(* Precheck fails if the counter is in the future. - - This test asserts that a manager operation with a counter in the - future -- aka greater than the successor of the manager's counter - stored in the current context -- fails with [Counter_in_the_future] error. - It applies to every kind of manager operation. *) -let high_counter_diagnostic (infos : infos) op = - let expect_failure errs = - match errs with - | [Environment.Ecoproto_error (Contract_storage.Counter_in_the_future _)] -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - precheck_ko_diagnostic infos op expect_failure - -let test_high_counter kind () = - let open Lwt_result_syntax in - let* infos = init_context () in - let counter = Z.of_int max_int in - let* op = - select_op ~counter ~force_reveal:true ~source:infos.contract1 kind infos - in - high_counter_diagnostic infos op - -let generate_high_counter () = - create_Tztest test_high_counter "Counter too high." subjects - -(* Precheck fails if the counter is in the past. - - This test asserts that a manager operation with a counter in the past -- aka - smaller than the successor of the manager's counter stored in the current - context -- fails with [Counter_in_the_past] error. - It applies to every kind of manager operation. *) -let low_counter_diagnostic (infos : infos) op = - let expect_failure errs = - match errs with - | [Environment.Ecoproto_error (Contract_storage.Counter_in_the_past _)] -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - precheck_ko_diagnostic infos op expect_failure - -let test_low_counter kind () = - let open Lwt_result_syntax in - let* infos = init_context () in - let* current_counter = - Context.Contract.counter (B infos.block) infos.contract1 - in - let counter = Z.sub current_counter Z.one in - let* op = - select_op ~counter ~force_reveal:true ~source:infos.contract1 kind infos - in - low_counter_diagnostic infos op - -let generate_low_counter () = - create_Tztest test_low_counter "Counter too low." subjects - -(* Precheck fails if the source is not allocated. - - This test asserts that a manager operation which manager's contract - is not allocated fails with [Empty_implicit_contract] error. - It applies on every kind of manager operation. *) -let not_allocated_diagnostic (infos : infos) op = - let expect_failure errs = - match errs with - | [Environment.Ecoproto_error (Contract_storage.Empty_implicit_contract _)] - -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - precheck_ko_diagnostic infos op expect_failure - -let test_not_allocated kind () = - let open Lwt_result_syntax in - let* infos = init_context () in - let* op = - select_op ~force_reveal:false ~source:(mk_fresh_contract ()) kind infos - in - not_allocated_diagnostic infos op - -let generate_not_allocated () = - create_Tztest test_not_allocated "not allocated source." subjects - -(* Precheck fails if the source is unrevealed. - - This test asserts that a manager operation with an unrevealed source's - contract fails at precheck with [Unrevealed_manager_key]. - It applies on every kind of manager operation except [Revelation]. *) -let unrevealed_key_diagnostic (infos : infos) op = - let expect_failure errs = - match errs with - | [ - Environment.Ecoproto_error - (Contract_manager_storage.Unrevealed_manager_key _); - ] -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - precheck_ko_diagnostic infos op expect_failure - -let test_unrevealed_key kind () = - let open Lwt_result_syntax in - let* infos = init_context () in - let* op = select_op ~force_reveal:false ~source:infos.contract1 kind infos in - unrevealed_key_diagnostic infos op - -let generate_unrevealed_key () = - create_Tztest - test_unrevealed_key - "unrevealed source (find_manager_public_key)." - revealed_subjects - -(* Precheck fails if the source's balance is not enough to pay the fees. - - This test asserts that precheck of a manager operation fails if the - source's balance is lesser than the manager operation's fee. - It applies on every kind of manager operation. *) -let high_fee_diagnostic (infos : infos) op = - let expect_failure errs = - match errs with - | [ - Environment.Ecoproto_error (Contract_storage.Balance_too_low _); - Environment.Ecoproto_error (Tez_repr.Subtraction_underflow _); - ] -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - precheck_ko_diagnostic infos op expect_failure - -let test_high_fee kind () = - let open Lwt_result_syntax in - let* infos = init_context () in - let*? fee = Tez.(one +? one) |> Environment.wrap_tzresult in - let* op = - select_op ~fee ~force_reveal:true ~source:infos.contract1 kind infos - in - high_fee_diagnostic infos op - -let generate_tests_high_fee () = - create_Tztest test_high_fee "not enough for fee payment." subjects - -(* Precheck fails if the fee payment empties the balance of a - delegated implicit contract. - - This test asserts that in case that: - - the source is a delegated implicit contract, and - - the fee is the exact balance of source. - then, precheck fails with [Empty_implicit_delegated_contract] error. - It applies to every kind of manager operation except [Revelation].*) -let emptying_delegated_implicit_diagnostic (infos : infos) op = - let expect_failure errs = - match errs with - | [ - Environment.Ecoproto_error - (Contract_storage.Empty_implicit_delegated_contract _); - ] -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - precheck_ko_diagnostic infos op expect_failure - -let test_emptying_delegated_implicit kind () = - let open Lwt_result_syntax in - let* infos = init_delegated_implicit () in - let* fee = Context.Contract.balance (B infos.block) infos.contract1 in - let* op = - select_op ~fee ~force_reveal:false ~source:infos.contract1 kind infos - in - emptying_delegated_implicit_diagnostic infos op - -let generate_tests_emptying_delegated_implicit () = - create_Tztest - test_emptying_delegated_implicit - "just enough funds to empty a delegated source." - revealed_subjects - -(* Precheck fails if there is not enough available gas in the block. - - This test asserts that precheck fails with: - - [Gas_limit_too_high;Block_quota_exceeded] in mempool mode, - | [Block_quota_exceeded] in other mode - with gas limit exceeds the available gas in the block. - It applies to every kind of manager operation. *) -let exceeding_block_gas_diagnostic ~mempool_mode (infos : infos) op = - let expect_failure errs = - match errs with - | [Environment.Ecoproto_error Gas.Block_quota_exceeded] - when not mempool_mode -> - return_unit - | [ - Environment.Ecoproto_error Gas.Gas_limit_too_high; - Environment.Ecoproto_error Gas.Block_quota_exceeded; - ] - when mempool_mode -> - (* In mempool_mode, batch that exceed [operation_gas_limit] needs - to be refused. [Gas.Block_quota_exceeded] only return a - temporary error. [Gas.Gas_limit_too_high], which is a - permanent error, is added to the error trace to ensure that - the batch is refused. *) - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - precheck_ko_diagnostic infos op expect_failure ~mempool_mode - -let test_exceeding_block_gas ~mempool_mode kind () = - let open Lwt_result_syntax in - let* infos = init_context ~hard_gas_limit_per_block:gb_limit () in - let gas_limit = - Op.Custom_gas (Gas.Arith.add gb_limit Gas.Arith.(integral_of_int_exn 1)) - in - let* operation = - select_op ~force_reveal:true ~source:infos.contract1 ~gas_limit kind infos - in - exceeding_block_gas_diagnostic ~mempool_mode infos operation - -let generate_tests_exceeding_block_gas () = - create_Tztest - (test_exceeding_block_gas ~mempool_mode:false) - "too much gas consumption." - subjects - -let generate_tests_exceeding_block_gas_mp_mode () = - create_Tztest - (test_exceeding_block_gas ~mempool_mode:true) - "too much gas consumption in mempool mode." - subjects - -(* Positive tests. - - Tests that precheck succeeds when: - - it empties the balance of a self_delegated implicit source, - - it empties the balance of an undelegated implicit source, and - - in case: - - the counter is the successor of the one stored in the context, - - the fee is lesser than the balance, - - the storage limit is lesser than the maximum authorized storage, - - the gas limit is: - - lesser than the available gas in the block, - - less than the maximum gas consumable by an operation, and - - greater than the minimum gas consumable by an operation. - Notice that the first two only precheck succeeds while in the last case, - the full application also succeeds. - In the first 2 case, we observe in the output context that: - - the counter is the successor of the one stored in the initial context, - - the balance decreased by fee, - - the available gas in the block decreased by gas limit. - In the last case, we observe in the output context that: - - the counter is the successor of the one stored in the initial context, - - the balance is at least decreased by fee, - - the available gas in the block decreased by gas limit. *) - -(* Fee payment that emptying a self_delegated implicit. *) -let test_emptying_self_delegated_implicit kind () = - let open Lwt_result_syntax in - let* infos = init_self_delegated_implicit () in - let* fee = Context.Contract.balance (B infos.block) infos.contract1 in - let* op = - select_op ~fee ~force_reveal:false ~source:infos.contract1 kind infos - in - only_precheck_diagnostic infos op - -let generate_tests_emptying_self_delegated_implicit () = - create_Tztest - test_emptying_self_delegated_implicit - "passes precheck and empties a self-delegated source." - subjects - -(* Minimum gas cost to pass the precheck: - - cost_of_manager_operation for the generic part - - 100 (empiric) for the specific part (script decoding or hash costs) *) -let empiric_minimal_gas_cost_for_precheck = - Gas.Arith.integral_of_int_exn - (Michelson_v1_gas.Internal_for_tests.int_cost_of_manager_operation + 100) - -let test_emptying_undelegated_implicit kind () = - let open Lwt_result_syntax in - let* infos = init_context () in - let gas_limit = Op.Custom_gas empiric_minimal_gas_cost_for_precheck in - let* fee = Context.Contract.balance (B infos.block) infos.contract1 in - let* op = - select_op - ~fee - ~gas_limit - ~force_reveal:true - ~source:infos.contract1 - kind - infos - in - only_precheck_diagnostic infos op - -let generate_tests_emptying_undelegated_implicit () = - create_Tztest - test_emptying_undelegated_implicit - "passes precheck and empties an undelegated source." - subjects - -(* Fee payment.*) -let test_precheck kind () = - let open Lwt_result_syntax in - let* infos = init_context () in - let* counter = Context.Contract.counter (B infos.block) infos.contract1 in - let source = infos.contract1 in - let* operation = select_op ~counter ~force_reveal:true ~source kind infos in - precheck_diagnostic infos operation - -let generate_tests_precheck () = - create_Tztest test_precheck "passes precheck." subjects - -let sanity_tests = - test_ensure_manager_operation_coverage () :: generate_tests_precheck () - -let gas_tests = - generate_low_gas_limit () @ generate_high_gas_limit () - @ generate_tests_exceeding_block_gas () - @ generate_tests_exceeding_block_gas_mp_mode () - -let storage_tests = generate_high_storage_limit () - -let fee_tests = - generate_tests_high_fee () - @ generate_tests_emptying_delegated_implicit () - @ generate_tests_emptying_self_delegated_implicit () - @ generate_tests_emptying_undelegated_implicit () - -let contract_tests = - generate_high_counter () @ generate_low_counter () @ generate_not_allocated () - @ generate_unrevealed_key () diff --git a/src/proto_alpha/lib_protocol/test/integration/precheck/dune b/src/proto_alpha/lib_protocol/test/integration/validate/dune similarity index 76% rename from src/proto_alpha/lib_protocol/test/integration/precheck/dune rename to src/proto_alpha/lib_protocol/test/integration/validate/dune index ebb763391fb83ea01b8ce18e3910983a8a91989b..fe89647675a887147e163b4f6c0c254d5db0bf04 100644 --- a/src/proto_alpha/lib_protocol/test/integration/precheck/dune +++ b/src/proto_alpha/lib_protocol/test/integration/validate/dune @@ -1,12 +1,13 @@ ; This file was automatically generated, do not edit. ; Edit file manifest/main.ml instead. -(executable - (name main) +(executables + (names main test_1m_restriction) (libraries alcotest-lwt tezos-base tezos-protocol-alpha + qcheck-alcotest tezos-client-alpha tezos-alpha-test-helpers tezos-base-test-helpers) @@ -23,3 +24,8 @@ (alias runtest) (package tezos-protocol-alpha-tests) (action (run %{dep:./main.exe}))) + +(rule + (alias runtest) + (package tezos-protocol-alpha-tests) + (action (run %{dep:./test_1m_restriction.exe}))) diff --git a/src/proto_alpha/lib_protocol/test/integration/validate/generators.ml b/src/proto_alpha/lib_protocol/test/integration/validate/generators.ml new file mode 100644 index 0000000000000000000000000000000000000000..dd40f8c10039719726fa31e63a3c2592ca785ec0 --- /dev/null +++ b/src/proto_alpha/lib_protocol/test/integration/validate/generators.ml @@ -0,0 +1,263 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +open Protocol +open Alpha_context +open Manager_operation_helpers + +let lwt_run f = + match Lwt_main.run f with + | Error err -> + QCheck.Test.fail_reportf "@.Lwt_main.run error: %a@." pp_print_trace err + | Ok v -> v + +(** {2 Datatypes} *) + +(** Constraints on generated values. + + {ul + {li [Free] states that nothing has to be generated} + + {li [Pure n] generate n} + + {li [Less {n;origin}] (resp Greater) states the expected + constraints for the generated values that must be lesser (resp + greater) than [n] and shrink toward [origin] in case of error} + + {li [Range {min;max;origin}] states the expected constraints for + the generated values that must be between [min] and [max] and + shrink toward [origin] in case of error.}} *) +type cstrs = + | Free + | Pure of int + | Less of {n : int; origin : int} + | Greater of {n : int; origin : int} + | Range of {min : int; max : int; origin : int} + +(** Gas frequency. *) +type gas_freq = { + low : int; + max : int; + high : int; + zero : int; + custom : int * cstrs; +} + +(** Operation constraints. *) +type operation_cstrs = { + counter : cstrs; + fee : cstrs; + gas_limit : gas_freq; + storage_limit : cstrs; + force_reveal : bool option; + amount : cstrs; +} + +(** Context constraints. *) +type ctxt_cstrs = { + hard_gas_limit_per_block : cstrs; + src_cstrs : cstrs; + dest_cstrs : cstrs; + del_cstrs : cstrs; + tx_cstrs : cstrs; + sc_cstrs : cstrs; +} +(** {2 Default values} *) + +(** Default constraint. *) +let default_cstrs = Free + +(** Default gas frequency. *) +let default_gas_freq = + {low = 0; max = 0; high = 1; zero = 0; custom = (0, Free)} + +(** Default constraints for operation. *) +let default_operation_cstrs = + { + counter = default_cstrs; + fee = default_cstrs; + gas_limit = default_gas_freq; + storage_limit = default_cstrs; + force_reveal = None; + amount = default_cstrs; + } + +(** Default constraints for context. *) +let default_ctxt_cstrs = + { + hard_gas_limit_per_block = default_cstrs; + src_cstrs = default_cstrs; + dest_cstrs = default_cstrs; + del_cstrs = default_cstrs; + tx_cstrs = default_cstrs; + sc_cstrs = default_cstrs; + } + +(** {2 Generators} *) + +(** Generator of positive integers. *) +let gen_pos : cstrs -> int option QCheck2.Gen.t = + fun c -> + let open QCheck2.Gen in + match c with + | Free -> pure None + | Pure n -> pure (Some n) + | Less {n; origin} -> + let+ v = int_range ~origin 0 n in + Some v + | Greater {n; origin} -> + let+ v = int_range ~origin n max_int in + Some v + | Range {min; max; origin} -> + let+ v = int_range ~origin min max in + Some v + +(** Generator for Z.t that is used for counter and gas limit. *) +let gen_z : cstrs -> Z.t option QCheck2.Gen.t = + fun cstrs -> + let open QCheck2.Gen in + let+ v = gen_pos cstrs in + Option.map Z.of_int v + +(** Generator for Tez.t. *) +let gen_tez : cstrs -> Tez.t option QCheck2.Gen.t = + fun cstrs -> + let open QCheck2.Gen in + let+ amount = gen_pos cstrs in + match amount with + | Some amount -> + let amount = Int64.of_int amount in + Tez.of_mutez amount + | None -> None + +(** Generator for gas integral. *) +let gen_gas_integral : cstrs -> Gas.Arith.integral option QCheck2.Gen.t = + fun cstrs -> + let open QCheck2.Gen in + let+ v = gen_pos cstrs in + Option.map Gas.Arith.integral_of_int_exn v + +(** Generator for Op.gas_limit. *) +let gen_gas_limit : gas_freq -> Op.gas_limit option QCheck2.Gen.t = + fun gas_freq -> + let open QCheck2.Gen in + frequency + [ + (gas_freq.low, return (Some Op.Low)); + (gas_freq.max, return (Some Op.Max)); + (gas_freq.high, return (Some Op.High)); + (gas_freq.zero, return (Some Op.Zero)); + (let freq, cstrs = gas_freq.custom in + ( freq, + let+ gas = gen_gas_integral cstrs in + match gas with None -> None | Some g -> Some (Op.Custom_gas g) )); + ] + +(** Generator for manager_operation_kind. *) +let gen_kind : + manager_operation_kind list -> manager_operation_kind QCheck2.Gen.t = + fun subjects -> QCheck2.Gen.oneofl subjects + +(** Generator for mode. *) +let gen_mode : mode QCheck2.Gen.t = + QCheck2.Gen.oneofl [Construction; Mempool; Application] + +(** Generator for operation requirements. *) +let gen_operation_req : + operation_cstrs -> + manager_operation_kind list -> + operation_req QCheck2.Gen.t = + fun {counter; fee; gas_limit; storage_limit; force_reveal; amount} subjects -> + let open QCheck2.Gen in + let* kind = gen_kind subjects in + let* counter = gen_z counter in + let* fee = gen_tez fee in + let* gas_limit = gen_gas_limit gas_limit in + let* storage_limit = gen_z storage_limit in + let+ amount = gen_tez amount in + {kind; counter; fee; gas_limit; storage_limit; force_reveal; amount} + +(** Generator for a pair of operations with the same source and + sequential counters.*) +let gen_2_operation_req : + operation_cstrs -> + manager_operation_kind list -> + (operation_req * operation_req) QCheck2.Gen.t = + fun op_cstrs subjects -> + let open QCheck2.Gen in + let* op1 = + gen_operation_req {op_cstrs with force_reveal = Some true} subjects + in + let counter = match op1.counter with Some x -> Z.to_int x | None -> 1 in + let op_cstr = + { + {op_cstrs with counter = Pure (counter + 2)} with + force_reveal = Some false; + } + in + let+ op2 = gen_operation_req op_cstr subjects in + (op1, op2) + +(** Generator for context requirement. *) +let gen_ctxt_req : ctxt_cstrs -> ctxt_req QCheck2.Gen.t = + fun { + hard_gas_limit_per_block; + src_cstrs; + dest_cstrs; + del_cstrs; + tx_cstrs; + sc_cstrs; + } -> + let open QCheck2.Gen in + let* hard_gas_limit_per_block = gen_gas_integral hard_gas_limit_per_block in + let* fund_src = gen_tez src_cstrs in + let* fund_dest = gen_tez dest_cstrs in + let* fund_del = gen_tez del_cstrs in + let* fund_tx = gen_tez tx_cstrs in + let+ fund_sc = gen_tez sc_cstrs in + { + hard_gas_limit_per_block; + fund_src; + fund_dest; + fund_del; + fund_tx; + fund_sc; + flags = all_enabled; + } + +(** {2 Wrappers} *) + +let wrap ~name ?print ?count ?check ~(gen : 'a QCheck2.Gen.t) + (f : 'a -> bool tzresult Lwt.t) = + Lib_test.Qcheck2_helpers.qcheck_make_result + ~name + ?print + ?count + ?check + ~pp_error:pp_print_trace + ~gen + (fun a -> Lwt_main.run (f a)) + +let wrap_mode infos op mode = validate_diagnostic ~mode infos op diff --git a/src/proto_alpha/lib_protocol/test/integration/precheck/main.ml b/src/proto_alpha/lib_protocol/test/integration/validate/main.ml similarity index 71% rename from src/proto_alpha/lib_protocol/test/integration/precheck/main.ml rename to src/proto_alpha/lib_protocol/test/integration/validate/main.ml index 9e58c8ee0a29d40a59b7ffd8ee1f32ee950b930d..5613c918c335d8287e8c3d41f401b3ec3d021094 100644 --- a/src/proto_alpha/lib_protocol/test/integration/precheck/main.ml +++ b/src/proto_alpha/lib_protocol/test/integration/validate/main.ml @@ -26,22 +26,27 @@ (** Testing ------- Component: Protocol - Invocation: dune runtest src/proto_alpha/lib_protocol/test/integration/precheck - Subject: Integration > Precheck + Invocation: dune runtest src/proto_alpha/lib_protocol/test/integration/validate + Subject: Integration > Validate *) let () = Alcotest_lwt.run - "protocol > integration > precheck" + "protocol > integration > validate" [ - ("sanity checks", Test_manager_operation_precheck.sanity_tests); - ("Single: gas checks", Test_manager_operation_precheck.gas_tests); - ("Single: storage checks", Test_manager_operation_precheck.storage_tests); - ("Single: fees checks", Test_manager_operation_precheck.fee_tests); - ("Single: contract checks", Test_manager_operation_precheck.contract_tests); + ("sanity checks", Test_manager_operation_validation.sanity_tests); + ("Single: gas checks", Test_manager_operation_validation.gas_tests); + ("Single: storage checks", Test_manager_operation_validation.storage_tests); + ("Single: fees checks", Test_manager_operation_validation.fee_tests); + ( "Single: contract checks", + Test_manager_operation_validation.contract_tests ); ( "Batched: contract checks", - Test_batched_manager_operation_precheck.contract_tests ); - ("Batched: gas checks", Test_batched_manager_operation_precheck.gas_tests); - ("Batched: fees checks", Test_batched_manager_operation_precheck.fee_tests); + Test_batched_manager_operation_validation.contract_tests ); + ( "Batched: gas checks", + Test_batched_manager_operation_validation.gas_tests ); + ( "Batched: fees checks", + Test_batched_manager_operation_validation.fee_tests ); + ( "Flags: feature flag checks", + Test_manager_operation_validation.flags_tests ); ] |> Lwt_main.run diff --git a/src/proto_alpha/lib_protocol/test/integration/validate/manager_operation_helpers.ml b/src/proto_alpha/lib_protocol/test/integration/validate/manager_operation_helpers.ml new file mode 100644 index 0000000000000000000000000000000000000000..2f5f15ffc87478a5358bb68c2bba5ea830f413d8 --- /dev/null +++ b/src/proto_alpha/lib_protocol/test/integration/validate/manager_operation_helpers.ml @@ -0,0 +1,1393 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +open Protocol +open Alpha_context +open Test_tez + +(** {2 Constants} *) + +(** Hard gas limit *) + +let gb_limit = Gas.Arith.(integral_of_int_exn 100_000) + +let half_gb_limit = Gas.Arith.(integral_of_int_exn 50_000) + +(** {2 Datatypes} *) + +(** Context abstraction in a test. *) +type ctxt = { + block : Block.t; + originated_contract : Contract_hash.t; + tx_rollup : Tx_rollup.t option; + sc_rollup : Sc_rollup.t option; +} + +(** Accounts manipulated in the tests. By convention, each field name + specifies the role of the account in a test. It is the case in most + of the tests. In operations smart contructors, it happens that in + impossible case, [source] is used as a dummy value. In some test that + requires a second source, [del] will be used as the second source. *) +type accounts = { + source : Account.t; + dest : Account.t option; + del : Account.t option; + tx : Account.t option; + sc : Account.t option; +} + +(** Infos describes the information of the setting for a test: the + context and used accounts. *) +type infos = {ctxt : ctxt; accounts : accounts} + +(** This type should be extended for each new manager_operation kind + added in the protocol. See + [test_manager_operation_validation.ensure_kind] for more + information on how we ensure that this type is extended for each + new manager_operation kind. *) +type manager_operation_kind = + | K_Transaction + | K_Origination + | K_Register_global_constant + | K_Delegation + | K_Undelegation + | K_Self_delegation + | K_Set_deposits_limit + | K_Increase_paid_storage + | K_Reveal + | K_Tx_rollup_origination + | K_Tx_rollup_submit_batch + | K_Tx_rollup_commit + | K_Tx_rollup_return_bond + | K_Tx_rollup_finalize + | K_Tx_rollup_remove_commitment + | K_Tx_rollup_dispatch_tickets + | K_Transfer_ticket + | K_Tx_rollup_reject + | K_Sc_rollup_origination + | K_Sc_rollup_publish + | K_Sc_rollup_cement + | K_Sc_rollup_add_messages + | K_Sc_rollup_refute + | K_Sc_rollup_timeout + | K_Sc_rollup_execute_outbox_message + | K_Sc_rollup_recover_bond + | K_Dal_publish_slot_header + +(** The requirements for a tested manager operation. *) +type operation_req = { + kind : manager_operation_kind; + counter : counter option; + fee : Tez.t option; + gas_limit : Op.gas_limit option; + storage_limit : counter option; + force_reveal : bool option; + amount : Tez.t option; +} + +(** Feature flags requirements for a context setting for a test. *) +type feature_flags = {dal : bool; scoru : bool; toru : bool} + +(** The requirements for a context setting for a test. *) +type ctxt_req = { + hard_gas_limit_per_block : Gas.Arith.integral option; + fund_src : Tez.t option; + fund_dest : Tez.t option; + fund_del : Tez.t option; + fund_tx : Tez.t option; + fund_sc : Tez.t option; + flags : feature_flags; +} + +(** Validation mode. + + FIXME: https://gitlab.com/tezos/tezos/-/issues/3365 + This type should be replaced by the one defined + in validation, type mode in `validate_operation`, when it would + include the distinction between Contruction and Application. *) +type mode = Construction | Mempool | Application + +(** {2 Default values} *) +let all_enabled = {dal = true; scoru = true; toru = true} + +let disabled_dal = {all_enabled with dal = false} + +let disabled_scoru = {all_enabled with scoru = false} + +let disabled_toru = {all_enabled with toru = false} + +let ctxt_req_default_to_flag flags = + { + hard_gas_limit_per_block = None; + fund_src = Some Tez.one; + fund_dest = Some Tez.one; + fund_del = Some Tez.one; + fund_tx = Some Tez.one; + fund_sc = Some Tez.one; + flags; + } + +let ctxt_req_default = ctxt_req_default_to_flag all_enabled + +let operation_req_default kind = + { + kind; + counter = None; + fee = None; + gas_limit = None; + storage_limit = None; + force_reveal = None; + amount = None; + } + +(** {2 String_of data} *) +let kind_to_string = function + | K_Transaction -> "Transaction" + | K_Delegation -> "Delegation" + | K_Undelegation -> "Undelegation" + | K_Self_delegation -> "Self-delegation" + | K_Set_deposits_limit -> "Set deposits limit" + | K_Origination -> "Origination" + | K_Register_global_constant -> "Register global constant" + | K_Increase_paid_storage -> "Increase paid storage" + | K_Reveal -> "Revelation" + | K_Tx_rollup_origination -> "Tx_rollup_origination" + | K_Tx_rollup_submit_batch -> "Tx_rollup_submit_batch" + | K_Tx_rollup_commit -> "Tx_rollup_commit" + | K_Tx_rollup_return_bond -> "Tx_rollup_return_bond" + | K_Tx_rollup_finalize -> "Tx_rollup_finalize" + | K_Tx_rollup_remove_commitment -> "Tx_rollup_remove_commitment" + | K_Tx_rollup_dispatch_tickets -> "Tx_rollup_dispatch_tickets" + | K_Tx_rollup_reject -> "Tx_rollup_reject" + | K_Transfer_ticket -> "Transfer_ticket" + | K_Sc_rollup_origination -> "Sc_rollup_origination" + | K_Sc_rollup_publish -> "Sc_rollup_publish" + | K_Sc_rollup_cement -> "Sc_rollup_cement" + | K_Sc_rollup_timeout -> "Sc_rollup_timeout" + | K_Sc_rollup_refute -> "Sc_rollup_refute" + | K_Sc_rollup_add_messages -> "Sc_rollup_add_messages" + | K_Sc_rollup_execute_outbox_message -> "Sc_rollup_execute_outbox_message" + | K_Sc_rollup_recover_bond -> "Sc_rollup_recover_bond" + | K_Dal_publish_slot_header -> "Dal_publish_slot_header" + +(** {2 Pretty-printers} *) +let pp_opt pp v = + let open Format in + pp_print_option ~none:(fun fmt () -> fprintf fmt "None") pp v + +let pp_operation_req pp + {kind; counter; fee; gas_limit; storage_limit; force_reveal; amount} = + Format.fprintf + pp + "@[Operation_req:@,\ + kind: %s@,\ + counter: %a@,\ + fee: %a@,\ + gas_limit: %a@,\ + storage_limit: %a@,\ + force_reveal: %a@,\ + amount: %a@,\ + @]" + (kind_to_string kind) + (pp_opt Z.pp_print) + counter + (pp_opt Tez.pp) + fee + (pp_opt Op.pp_gas_limit) + gas_limit + (pp_opt Z.pp_print) + storage_limit + (pp_opt (fun fmt -> Format.fprintf fmt "%b")) + force_reveal + (pp_opt Tez.pp) + amount + +let pp_2_operation_req pp (op_req1, op_req2) = + Format.fprintf + pp + "[ %a,@ and %a,@ @]" + pp_operation_req + op_req1 + pp_operation_req + op_req2 + +let pp_ctxt_req pp + { + hard_gas_limit_per_block; + fund_src; + fund_dest; + fund_del; + fund_tx; + fund_sc; + flags; + } = + Format.fprintf + pp + "@[Ctxt_req:@,\ + hard_gas_limit_per_block:%a@,\ + fund_src: %a tz@,\ + fund_dest: %a tz@,\ + fund_del: %a tz@,\ + fund_tx: %a tz@,\ + fund_sc: %a tz@,\ + dal_flag: %a@,\ + scoru_flag: %a@,\ + toru_flag: %a@,\ + @]" + (pp_opt Gas.Arith.pp_integral) + hard_gas_limit_per_block + (pp_opt Tez.pp) + fund_src + (pp_opt Tez.pp) + fund_dest + (pp_opt Tez.pp) + fund_del + (pp_opt Tez.pp) + fund_tx + (pp_opt Tez.pp) + fund_sc + Format.pp_print_bool + flags.dal + Format.pp_print_bool + flags.scoru + Format.pp_print_bool + flags.toru + +let pp_mode pp = function + | Construction -> Format.fprintf pp "Construction" + | Mempool -> Format.fprintf pp "Mempool" + | Application -> Format.fprintf pp "Block" + +(** {2 Short-cuts} *) +let contract_of (account : Account.t) = Contract.Implicit account.pkh + +(** Make a [mempool_mode], aka a boolean, as used in incremental from + a [mode]. *) +let mempool_mode_of = function Mempool -> true | _ -> false + +let get_pk infos source = + let open Lwt_result_syntax in + let+ account = Context.Contract.manager infos source in + account.pk + +(** Operation for specific context. *) +let self_delegate block pkh = + let open Lwt_result_syntax in + let contract = Contract.Implicit pkh in + let* operation = + Op.delegation ~force_reveal:true (B block) contract (Some pkh) + in + let* block = Block.bake block ~operation in + let* del_opt_new = Context.Contract.delegate_opt (B block) contract in + let* del = Assert.get_some ~loc:__LOC__ del_opt_new in + let+ _ = Assert.equal_pkh ~loc:__LOC__ del pkh in + block + +let delegation block delegator delegate = + let open Lwt_result_syntax in + let delegate_pkh = delegate.Account.pkh in + let contract_delegator = contract_of delegator in + let contract_delegate = contract_of delegate in + let* operation = + Op.delegation + ~force_reveal:true + (B block) + contract_delegate + (Some delegate_pkh) + in + let* block = Block.bake block ~operation in + let* operation = + Op.delegation + ~force_reveal:true + (B block) + contract_delegator + (Some delegate_pkh) + in + let* block = Block.bake block ~operation in + let* del_opt_new = + Context.Contract.delegate_opt (B block) contract_delegator + in + let* del = Assert.get_some ~loc:__LOC__ del_opt_new in + let+ _ = Assert.equal_pkh ~loc:__LOC__ del delegate_pkh in + block + +let originate_tx_rollup block rollup_account = + let open Lwt_result_syntax in + let rollup_contract = contract_of rollup_account in + let* rollup_origination, tx_rollup = + Op.tx_rollup_origination ~force_reveal:true (B block) rollup_contract + in + let+ block = Block.bake ~operation:rollup_origination block in + (block, tx_rollup) + +let originate_sc_rollup block rollup_account = + let open Lwt_result_syntax in + let rollup_contract = contract_of rollup_account in + let* rollup_origination, sc_rollup = + Op.sc_rollup_origination + ~force_reveal:true + (B block) + rollup_contract + Sc_rollup.Kind.Example_arith + "" + (Script.lazy_expr (Expr.from_string "1")) + in + let+ block = Block.bake ~operation:rollup_origination block in + (block, sc_rollup) + +(** {2 Setting's context construction} *) + +let fund_account block bootstrap account fund = + let open Lwt_result_syntax in + let* counter = Context.Contract.counter (B block) bootstrap in + let* fund = + match fund with + | None -> return Tez.one + | Some fund -> + let* source_balance = Context.Contract.balance (B block) bootstrap in + if Tez.(fund > source_balance) then + Lwt.return (Environment.wrap_tzresult Tez.(source_balance -? one)) + else return fund + in + let* operation = + Op.transaction + ~counter + ~gas_limit:Op.High + (B block) + bootstrap + (Contract.Implicit account) + fund + in + let*! b = Block.bake ~operation block in + match b with Error _ -> failwith "Funding account error" | Ok b -> return b + +(** The generic setting for a test is built up according to a context + requirement. It provides a context and accounts where the accounts + have been created and funded according to the context + requirements.*) +let init_ctxt : ctxt_req -> infos tzresult Lwt.t = + fun { + hard_gas_limit_per_block; + fund_src; + fund_dest; + fund_del; + fund_tx; + fund_sc; + flags; + } -> + let open Lwt_result_syntax in + let create_and_fund ?originate_rollup block bootstrap fund = + match fund with + | None -> return (block, None, None) + | Some _ -> + let account = Account.new_account () in + let* block = fund_account block bootstrap account.pkh fund in + let+ block, rollup = + match originate_rollup with + | None -> return (block, None) + | Some f -> + let+ block, rollup = f block account in + (block, Some rollup) + in + (block, Some account, rollup) + in + let* block, bootstraps = + Context.init_n + 6 + ~consensus_threshold:0 + ?hard_gas_limit_per_block + ~tx_rollup_enable:flags.toru + ~tx_rollup_sunset_level:Int32.max_int + ~sc_rollup_enable:flags.scoru + ~dal_enable:flags.dal + () + in + let get_bootstrap bootstraps n = Stdlib.List.nth bootstraps n in + let source = Account.new_account () in + let* block = + fund_account block (get_bootstrap bootstraps 0) source.pkh fund_src + in + let* block, dest, _ = + create_and_fund block (get_bootstrap bootstraps 1) fund_dest + in + let* block, del, _ = + create_and_fund block (get_bootstrap bootstraps 2) fund_del + in + let* block, tx, tx_rollup = + if flags.toru then + create_and_fund + ~originate_rollup:(fun infos account -> + originate_tx_rollup infos account) + block + (get_bootstrap bootstraps 3) + fund_tx + else return (block, None, None) + in + let* block, sc, sc_rollup = + if flags.scoru then + create_and_fund + ~originate_rollup:(fun infos account -> + originate_sc_rollup infos account) + block + (get_bootstrap bootstraps 4) + fund_sc + else return (block, None, None) + in + let* create_contract_hash, originated_contract = + Op.contract_origination_hash + (B block) + (get_bootstrap bootstraps 5) + ~fee:Tez.zero + ~script:Op.dummy_script + in + let+ block = Block.bake ~operation:create_contract_hash block in + let ctxt = {block; originated_contract; tx_rollup; sc_rollup} in + {ctxt; accounts = {source; dest; del; tx; sc}} + +(** In addition of building up a context according to a context + requirement, source is self-delegated. + + see [init_ctxt] description. *) +let ctxt_with_self_delegation : ctxt_req -> infos tzresult Lwt.t = + fun ctxt_req -> + let open Lwt_result_syntax in + let* infos = init_ctxt ctxt_req in + let+ block = self_delegate infos.ctxt.block infos.accounts.source.pkh in + let ctxt = {infos.ctxt with block} in + {infos with ctxt} + +(** In addition of building up a context accordning to a context + requirement, source delegates to del. + + See [init_ctxt] description. *) +let ctxt_with_delegation : ctxt_req -> infos tzresult Lwt.t = + fun ctxt_req -> + let open Lwt_result_syntax in + let* infos = init_ctxt ctxt_req in + let* delegate = + match infos.accounts.del with + | None -> failwith "Delegate account should be funded" + | Some a -> return a + in + let+ block = delegation infos.ctxt.block infos.accounts.source delegate in + let ctxt = {infos.ctxt with block} in + {infos with ctxt} + +let default_init_ctxt () = init_ctxt ctxt_req_default + +let default_init_with_flags flags = init_ctxt (ctxt_req_default_to_flag flags) + +let default_ctxt_with_self_delegation () = + ctxt_with_self_delegation ctxt_req_default + +let default_ctxt_with_delegation () = ctxt_with_delegation ctxt_req_default + +(** {2 Smart constructors} *) + +(** Smart constructors to forge manager operations according to + operation requirements in a test setting. *) + +let mk_transaction (oinfos : operation_req) (infos : infos) = + Op.transaction + ?force_reveal:oinfos.force_reveal + ?counter:oinfos.counter + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?storage_limit:oinfos.storage_limit + (B infos.ctxt.block) + (contract_of infos.accounts.source) + (contract_of + (match infos.accounts.dest with + | None -> infos.accounts.source + | Some dest -> dest)) + (match oinfos.amount with None -> Tez.zero | Some amount -> amount) + +let mk_delegation (oinfos : operation_req) (infos : infos) = + Op.delegation + ?force_reveal:oinfos.force_reveal + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + (B infos.ctxt.block) + (contract_of infos.accounts.source) + (Some + (match infos.accounts.del with + | None -> infos.accounts.source.pkh + | Some delegate -> delegate.pkh)) + +let mk_undelegation (oinfos : operation_req) (infos : infos) = + Op.delegation + ?force_reveal:oinfos.force_reveal + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + (B infos.ctxt.block) + (contract_of infos.accounts.source) + None + +let mk_self_delegation (oinfos : operation_req) (infos : infos) = + Op.delegation + ?force_reveal:oinfos.force_reveal + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + (B infos.ctxt.block) + (contract_of infos.accounts.source) + (Some infos.accounts.source.pkh) + +let mk_origination (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let+ op, _ = + Op.contract_origination + ?force_reveal:oinfos.force_reveal + ?counter:oinfos.counter + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?storage_limit:oinfos.storage_limit + ~script:Op.dummy_script + (B infos.ctxt.block) + (contract_of infos.accounts.source) + in + op + +let mk_register_global_constant (oinfos : operation_req) (infos : infos) = + Op.register_global_constant + ?force_reveal:oinfos.force_reveal + ?counter:oinfos.counter + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?storage_limit:oinfos.storage_limit + (B infos.ctxt.block) + ~source:(contract_of infos.accounts.source) + ~value:(Script_repr.lazy_expr (Expr.from_string "Pair 1 2")) + +let mk_set_deposits_limit (oinfos : operation_req) (infos : infos) = + Op.set_deposits_limit + ?force_reveal:oinfos.force_reveal + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?storage_limit:oinfos.storage_limit + ?counter:oinfos.counter + (B infos.ctxt.block) + (contract_of infos.accounts.source) + None + +let mk_increase_paid_storage (oinfos : operation_req) (infos : infos) = + Op.increase_paid_storage + ?force_reveal:oinfos.force_reveal + ?counter:oinfos.counter + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?storage_limit:oinfos.storage_limit + (B infos.ctxt.block) + ~source:(contract_of infos.accounts.source) + ~destination:infos.ctxt.originated_contract + Z.one + +let mk_reveal (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* pk = get_pk (B infos.ctxt.block) (contract_of infos.accounts.source) in + Op.revelation + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + (B infos.ctxt.block) + pk + +let mk_tx_rollup_origination (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let+ op, _rollup = + Op.tx_rollup_origination + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + ?force_reveal:oinfos.force_reveal + (B infos.ctxt.block) + (contract_of infos.accounts.source) + in + op + +let tx_rollup_of = function + | Some tx_rollup -> return tx_rollup + | None -> failwith "Tx_rollup not created in this context" + +let sc_rollup_of = function + | Some sc_rollup -> return sc_rollup + | None -> failwith "Sc_rollup not created in this context" + +let mk_tx_rollup_submit_batch (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* tx_rollup = tx_rollup_of infos.ctxt.tx_rollup in + + Op.tx_rollup_submit_batch + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + ?force_reveal:oinfos.force_reveal + (B infos.ctxt.block) + (contract_of infos.accounts.source) + tx_rollup + "batch" + +let mk_tx_rollup_commit (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* tx_rollup = tx_rollup_of infos.ctxt.tx_rollup in + let commitement : Tx_rollup_commitment.Full.t = + { + level = Tx_rollup_level.root; + messages = []; + predecessor = None; + inbox_merkle_root = Tx_rollup_inbox.Merkle.merklize_list []; + } + in + Op.tx_rollup_commit + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + ?force_reveal:oinfos.force_reveal + (B infos.ctxt.block) + (contract_of infos.accounts.source) + tx_rollup + commitement + +let mk_tx_rollup_return_bond (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* tx_rollup = tx_rollup_of infos.ctxt.tx_rollup in + Op.tx_rollup_return_bond + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + ?force_reveal:oinfos.force_reveal + (B infos.ctxt.block) + (contract_of infos.accounts.source) + tx_rollup + +let mk_tx_rollup_finalize (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* tx_rollup = tx_rollup_of infos.ctxt.tx_rollup in + Op.tx_rollup_finalize + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + ?force_reveal:oinfos.force_reveal + (B infos.ctxt.block) + (contract_of infos.accounts.source) + tx_rollup + +let mk_tx_rollup_remove_commitment (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* tx_rollup = tx_rollup_of infos.ctxt.tx_rollup in + Op.tx_rollup_remove_commitment + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + ?force_reveal:oinfos.force_reveal + (B infos.ctxt.block) + (contract_of infos.accounts.source) + tx_rollup + +let mk_tx_rollup_reject (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* tx_rollup = tx_rollup_of infos.ctxt.tx_rollup in + let message, _ = Tx_rollup_message.make_batch "" in + let message_hash = Tx_rollup_message_hash.hash_uncarbonated message in + let message_path = + match Tx_rollup_inbox.Merkle.compute_path [message_hash] 0 with + | Ok message_path -> message_path + | _ -> raise (Invalid_argument "Single_message_inbox.message_path") + in + let proof : Tx_rollup_l2_proof.t = + { + version = 1; + before = `Value Tx_rollup_message_result.empty_l2_context_hash; + after = `Value Context_hash.zero; + state = Seq.empty; + } + in + let previous_message_result : Tx_rollup_message_result.t = + { + context_hash = Tx_rollup_message_result.empty_l2_context_hash; + withdraw_list_hash = Tx_rollup_withdraw_list_hash.empty; + } + in + Op.tx_rollup_reject + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + ?force_reveal:oinfos.force_reveal + (B infos.ctxt.block) + (contract_of infos.accounts.source) + tx_rollup + Tx_rollup_level.root + message + ~message_position:0 + ~message_path + ~message_result_hash:Tx_rollup_message_result_hash.zero + ~message_result_path:Tx_rollup_commitment.Merkle.dummy_path + ~proof + ~previous_message_result + ~previous_message_result_path:Tx_rollup_commitment.Merkle.dummy_path + +let mk_transfer_ticket (oinfos : operation_req) (infos : infos) = + Op.transfer_ticket + ?fee:oinfos.fee + ?force_reveal:oinfos.force_reveal + ?counter:oinfos.counter + ?gas_limit:oinfos.gas_limit + ?storage_limit:oinfos.storage_limit + (B infos.ctxt.block) + ~source:(contract_of infos.accounts.source) + ~contents:(Script.lazy_expr (Expr.from_string "1")) + ~ty:(Script.lazy_expr (Expr.from_string "nat")) + ~ticketer: + (contract_of + (match infos.accounts.tx with + | None -> infos.accounts.source + | Some tx -> tx)) + Z.zero + ~destination: + (contract_of + (match infos.accounts.dest with + | None -> infos.accounts.source + | Some dest -> dest)) + Entrypoint.default + +let mk_tx_rollup_dispacth_ticket (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* tx_rollup = tx_rollup_of infos.ctxt.tx_rollup in + let reveal = + Tx_rollup_reveal. + { + contents = Script.lazy_expr (Expr.from_string "1"); + ty = Script.lazy_expr (Expr.from_string "nat"); + ticketer = + contract_of + (match infos.accounts.dest with + | None -> infos.accounts.source + | Some dest -> dest); + amount = Tx_rollup_l2_qty.of_int64_exn 10L; + claimer = + (match infos.accounts.dest with + | None -> infos.accounts.source.pkh + | Some dest -> dest.pkh); + } + in + Op.tx_rollup_dispatch_tickets + ?fee:oinfos.fee + ?force_reveal:oinfos.force_reveal + ?counter:oinfos.counter + ?gas_limit:oinfos.gas_limit + ?storage_limit:oinfos.storage_limit + (B infos.ctxt.block) + ~source:(contract_of infos.accounts.source) + ~message_index:0 + ~message_result_path:Tx_rollup_commitment.Merkle.dummy_path + tx_rollup + Tx_rollup_level.root + Context_hash.zero + [reveal] + +let mk_sc_rollup_origination (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let+ op, _ = + Op.sc_rollup_origination + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + ?force_reveal:oinfos.force_reveal + (B infos.ctxt.block) + (contract_of infos.accounts.source) + Sc_rollup.Kind.Example_arith + "" + (Script.lazy_expr (Expr.from_string "1")) + in + op + +let sc_dummy_commitment = + let number_of_ticks = + match Sc_rollup.Number_of_ticks.of_int32 3000l with + | None -> assert false + | Some x -> x + in + Sc_rollup.Commitment. + { + predecessor = Sc_rollup.Commitment.Hash.zero; + inbox_level = Raw_level.of_int32_exn Int32.zero; + number_of_ticks; + compressed_state = Sc_rollup.State_hash.zero; + } + +let mk_sc_rollup_publish (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* sc_rollup = sc_rollup_of infos.ctxt.sc_rollup in + Op.sc_rollup_publish + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + ?force_reveal:oinfos.force_reveal + (B infos.ctxt.block) + (contract_of infos.accounts.source) + sc_rollup + sc_dummy_commitment + +let mk_sc_rollup_cement (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* sc_rollup = sc_rollup_of infos.ctxt.sc_rollup in + Op.sc_rollup_cement + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + ?force_reveal:oinfos.force_reveal + (B infos.ctxt.block) + (contract_of infos.accounts.source) + sc_rollup + (Sc_rollup.Commitment.hash sc_dummy_commitment) + +let mk_sc_rollup_refute (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* sc_rollup = sc_rollup_of infos.ctxt.sc_rollup in + let refutation : Sc_rollup.Game.refutation = + {choice = Sc_rollup.Tick.initial; step = Dissection []} + in + Op.sc_rollup_refute + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + ?force_reveal:oinfos.force_reveal + (B infos.ctxt.block) + (contract_of infos.accounts.source) + sc_rollup + (match infos.accounts.dest with + | None -> infos.accounts.source.pkh + | Some dest -> dest.pkh) + (Some refutation) + +let mk_sc_rollup_add_messages (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* sc_rollup = sc_rollup_of infos.ctxt.sc_rollup in + Op.sc_rollup_add_messages + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + ?force_reveal:oinfos.force_reveal + (B infos.ctxt.block) + (contract_of infos.accounts.source) + sc_rollup + [""] + +let mk_sc_rollup_timeout (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* sc_rollup = sc_rollup_of infos.ctxt.sc_rollup in + Op.sc_rollup_timeout + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + ?force_reveal:oinfos.force_reveal + (B infos.ctxt.block) + (contract_of infos.accounts.source) + sc_rollup + (Sc_rollup.Game.Index.make + infos.accounts.source.pkh + (match infos.accounts.dest with + | None -> infos.accounts.source.pkh + | Some dest -> dest.pkh)) + +let mk_sc_rollup_execute_outbox_message (oinfos : operation_req) (infos : infos) + = + let open Lwt_result_syntax in + let* sc_rollup = sc_rollup_of infos.ctxt.sc_rollup in + Op.sc_rollup_execute_outbox_message + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + ?force_reveal:oinfos.force_reveal + (B infos.ctxt.block) + (contract_of infos.accounts.source) + sc_rollup + (Sc_rollup.Commitment.hash sc_dummy_commitment) + ~output_proof:"" + +let mk_sc_rollup_return_bond (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* sc_rollup = sc_rollup_of infos.ctxt.sc_rollup in + Op.sc_rollup_recover_bond + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + ?force_reveal:oinfos.force_reveal + (B infos.ctxt.block) + (contract_of infos.accounts.source) + sc_rollup + +let mk_dal_publish_slot_header (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let level = 0 in + let index = 0 in + let header = 0 in + let json_slot = + Data_encoding.Json.from_string + (Format.asprintf + {|{"level":%d,"index":%d,"header":%d}|} + level + index + header) + in + let* json_slot = + match json_slot with Error s -> failwith "%s" s | Ok slot -> return slot + in + let slot = Data_encoding.Json.destruct Dal.Slot.encoding json_slot in + Op.dal_publish_slot_header + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + ?force_reveal:oinfos.force_reveal + (B infos.ctxt.block) + (contract_of infos.accounts.source) + slot + +(** {2 Helpers for generation of generic check tests by manager operation} *) + +(** Generic forge for any kind of manager operation according to + operation requirements in a specific test setting. *) +let select_op (op_req : operation_req) (infos : infos) = + let mk_op = + match op_req.kind with + | K_Transaction -> mk_transaction + | K_Origination -> mk_origination + | K_Register_global_constant -> mk_register_global_constant + | K_Delegation -> mk_delegation + | K_Undelegation -> mk_undelegation + | K_Self_delegation -> mk_self_delegation + | K_Set_deposits_limit -> mk_set_deposits_limit + | K_Increase_paid_storage -> mk_increase_paid_storage + | K_Reveal -> mk_reveal + | K_Tx_rollup_origination -> mk_tx_rollup_origination + | K_Tx_rollup_submit_batch -> mk_tx_rollup_submit_batch + | K_Tx_rollup_commit -> mk_tx_rollup_commit + | K_Tx_rollup_return_bond -> mk_tx_rollup_return_bond + | K_Tx_rollup_finalize -> mk_tx_rollup_finalize + | K_Tx_rollup_remove_commitment -> mk_tx_rollup_remove_commitment + | K_Tx_rollup_reject -> mk_tx_rollup_reject + | K_Transfer_ticket -> mk_transfer_ticket + | K_Tx_rollup_dispatch_tickets -> mk_tx_rollup_dispacth_ticket + | K_Sc_rollup_origination -> mk_sc_rollup_origination + | K_Sc_rollup_publish -> mk_sc_rollup_publish + | K_Sc_rollup_cement -> mk_sc_rollup_cement + | K_Sc_rollup_refute -> mk_sc_rollup_refute + | K_Sc_rollup_add_messages -> mk_sc_rollup_add_messages + | K_Sc_rollup_timeout -> mk_sc_rollup_timeout + | K_Sc_rollup_execute_outbox_message -> mk_sc_rollup_execute_outbox_message + | K_Sc_rollup_recover_bond -> mk_sc_rollup_return_bond + | K_Dal_publish_slot_header -> mk_dal_publish_slot_header + in + mk_op op_req infos + +let create_Tztest ?hd_msg test tests_msg operations = + let tl_msg k = + let sk = kind_to_string k in + match hd_msg with None -> sk | Some hd -> Format.sprintf "%s, %s" hd sk + in + List.map + (fun kind -> + Tztest.tztest + (Format.sprintf "%s [%s]" tests_msg (tl_msg kind)) + `Quick + (fun () -> test kind ())) + operations + +let rec create_Tztest_batches test tests_msg operations = + let hdmsg k = Format.sprintf "%s" (kind_to_string k) in + let aux hd_msg test operations = + create_Tztest ~hd_msg test tests_msg operations + in + match operations with + | [] -> [] + | kop :: kops as ops -> + aux (hdmsg kop) (test kop) ops @ create_Tztest_batches test tests_msg kops + +(** {2 Diagnostic helpers.} *) + +(** The purpose of diagnostic helpers is to state the correct + observation according to the validate result of a test. *) + +(** For a manager operation a [probes] contains the values required + for observing its validate success. Its source, fees (sum for a + batch), gas_limit (sum of gas_limit of the batch), and the + increment of the counters aka 1 for a single operation, n for a + batch of n manager operations. *) +type probes = { + source : Signature.Public_key_hash.t; + fee : Tez.tez; + gas_limit : Gas.Arith.integral; + nb_counter : Z.t; +} + +let rec contents_infos : + type kind. kind Kind.manager contents_list -> probes tzresult Lwt.t = + fun op -> + let open Lwt_result_syntax in + match op with + | Single (Manager_operation {source; fee; gas_limit; _}) -> + return {source; fee; gas_limit; nb_counter = Z.one} + | Cons (Manager_operation manop, manops) -> + let* probes = contents_infos manops in + let*? fee = manop.fee +? probes.fee in + let gas_limit = Gas.Arith.add probes.gas_limit manop.gas_limit in + let nb_counter = Z.succ probes.nb_counter in + let _ = Assert.equal_pkh ~loc:__LOC__ manop.source probes.source in + return {fee; source = probes.source; gas_limit; nb_counter} + +(** Computes a [probes] from a list of manager contents. *) +let manager_content_infos op = + let (Operation_data {contents; _}) = op.protocol_data in + match contents with + | Single (Manager_operation _) as op -> contents_infos op + | Cons (Manager_operation _, _) as op -> contents_infos op + | _ -> failwith "Should only handle manager operation" + +(** We need a way to get the available gas in a context of type + block. *) +let available_gas = function + | Context.I inc -> Some (Gas.block_level (Incremental.alpha_ctxt inc)) + | B _ -> None + +(** Computes the witness value in a state. The witness values are the + the initial balance of source, its initial counter and the + available gas in the state. The available gas is computed only + when the context is an incremental one. *) +let witness ctxt source = + let open Lwt_result_syntax in + let* b_in = Context.Contract.balance ctxt source in + let+ c_in = Context.Contract.counter ctxt source in + let g_in = available_gas ctxt in + (b_in, c_in, g_in) + +(** According to the witness in pre-state and the probes, computes the + expected outputs. In any mode the expected witness: + - the balance of source should be the one in the pre-state minus + the fee of probes, + - the counter of source should be the one in the pre-state plus + the number of counter in probes. + + Concerning the expected available gas in the block: - In + [Application] mode, it cannot be computed, so we do not expect any, + - In [Mempool] mode, it is the remaining gas after removing the gas + of probes gas from an empty block, - In the [Construction] mode, it + is the remaining gas after removing the gas of probes from the + available gas in the pre-state.*) +let expected_witness witness probes ~mode ctxt = + let open Lwt_result_syntax in + let b_in, c_in, g_in = witness in + let*? b_expected = b_in -? probes.fee in + let c_expected = Z.add c_in probes.nb_counter in + let+ g_expected = + match (g_in, mode) with + | Some g_in, Construction -> + return_some (Gas.Arith.sub g_in (Gas.Arith.fp probes.gas_limit)) + | _, Mempool -> + Context.get_constants ctxt >>=? fun c -> + return_some + (Gas.Arith.sub + (Gas.Arith.fp c.parametric.hard_gas_limit_per_block) + (Gas.Arith.fp probes.gas_limit)) + | None, Application -> return_none + | Some _, Application -> + failwith "In application mode witness should not care about gas level" + | None, Construction -> + failwith "In Construction mode the witness should return a gas level" + in + (b_expected, c_expected, g_expected) + +(** The validity of a test in positve case, observes that validation + of a manager operation implies the fee payment. This observation + differs according to the validation calling [mode] (see type mode + for more details). Given the values of witness in the pre-state, + the probes of the operation probes and the values of witness in the + post-state, if the validation succeeds then we observe in the + post-state: + + The balance of source decreases by the fee of probes when + [only_validate] marks that only the validate succeeds. + + The balance of source decreases at least by fee of probes when + [not only_validate] marks that the application has succeeded, + + Its counter in the pre-state increases by the number of counter of + probes. + + The remaining gas in the pre-state decreases by the gas of probes, + in [Construction] and [Mempool] mode. + + In [Mempool] mode, the remaining gas in the pre-state is always + the available gas in an empty block. + + In the [Application] mode, we do not perform any check on the + available gas. *) +let observe ~only_validate ~mode ctxt_pre ctxt_post op = + let open Lwt_result_syntax in + let* probes = manager_content_infos op in + let contract = Contract.Implicit probes.source in + let* witness_in = witness ctxt_pre contract in + let* b_out, c_out, g_out = witness ctxt_post contract in + let* b_expected, c_expected, g_expected = + expected_witness witness_in probes ~mode ctxt_post + in + let b_cmp = + Assert.equal + ~loc:__LOC__ + (if only_validate then Tez.( = ) else Tez.( <= )) + (if only_validate then "Balance update (=)" else "Balance update (<=)") + Tez.pp + in + let* _ = b_cmp b_out b_expected in + let _ = + Assert.equal + Z.equal + ~loc:__LOC__ + "Counter incrementation" + Z.pp_print + c_out + c_expected + in + let g_msg = + match mode with + | Application -> "Gas consumption (application)" + | Mempool -> "Gas consumption (mempool)" + | Construction -> "Gas consumption (construction)" + in + match g_expected with + | None -> Assert.is_none ~loc:__LOC__ ~pp:Gas.Arith.pp g_out + | Some g_expected -> + let* g_out = Assert.get_some ~loc:__LOC__ g_out in + Assert.equal + ~loc:__LOC__ + Gas.Arith.equal + g_msg + Gas.Arith.pp + g_out + g_expected + +let observe_list ~only_validate ~mode ctxt_pre ctxt_post ops = + List.iter + (fun op -> + let _ = observe ~only_validate ~mode ctxt_pre ctxt_post op in + ()) + ops + +let validate_operations inc_in ops = + let open Lwt_result_syntax in + List.fold_left_es + (fun inc op -> + let* inc_out = Incremental.validate_operation inc op in + return inc_out) + inc_in + ops + +(** In [Construction] and [Mempool] mode, the pre-state provide an + incremental, whereas in the [Application] mode, it is the block in + the setting context of the test. *) +let pre_state_of_mode ~mode infos = + let open Lwt_result_syntax in + match mode with + | Construction | Mempool -> + let+ inc = Incremental.begin_construction infos.ctxt.block in + Context.I inc + | Application -> return (Context.B infos.ctxt.block) + +(** In [Construction] and [Mempool] mode, the post-state is + incrementally built upon a pre-state, whereas in the [Application] + mode it is obtained by baking. *) +let post_state_of_mode ~mode ctxt ops infos = + let open Lwt_result_syntax in + match (mode, ctxt) with + | (Construction | Mempool), Context.I inc_pre -> + let* inc_post = validate_operations inc_pre ops in + let+ block = Incremental.finalize_block inc_post in + (Context.I inc_post, {infos with ctxt = {infos.ctxt with block}}) + | Application, Context.B b -> + let+ block = Block.bake ~baking_mode:Application ~operations:ops b in + (Context.B block, {infos with ctxt = {infos.ctxt with block}}) + | Application, Context.I _ -> + failwith "In Application mode, context should not be an Incremental" + | (Construction | Mempool), Context.B _ -> + failwith "In (Partial) Contruction mode, context should not be a Block" + +(** A positive test builds a pre-state from a mode, and a setting + context, then it computes a post-state from the mode, the setting + context and the operations. Finally, it observes the result + according to the only_validate status for each operation. + + See [observe] for more details on the observational validation. *) +let validate_with_diagnostic ~only_validate ~mode (infos : infos) ops = + let open Lwt_result_syntax in + let* ctxt_pre = pre_state_of_mode ~mode infos in + let* ctxt_post, infos = post_state_of_mode ~mode ctxt_pre ops infos in + let _ = observe_list ~only_validate ~mode ctxt_pre ctxt_post ops in + return infos + +(** If only the operation validation succeeds; e.g. the rest of the + application failed then [only_validate] must be set for the + observation validation. + + Default mode is [Construction]. See [observe] for more details. *) +let only_validate_diagnostic ?(mode = Construction) (infos : infos) ops = + validate_with_diagnostic ~only_validate:true ~mode infos ops + +(** If the whole operation application succeeds; e.g. the fee + payment and the full application succeed then [not only_validate] + must be set. + + Default mode is [Construction]. *) +let validate_diagnostic ?(mode = Construction) (infos : infos) ops = + validate_with_diagnostic ~only_validate:false ~mode infos ops + +let add_operations ~expect_failure inc_in ops = + let open Lwt_result_syntax in + let* last, ops = + match List.rev ops with + | op :: rev_ops -> return (op, List.rev rev_ops) + | [] -> failwith "Empty list of operations given to add_operations" + in + let* inc = + List.fold_left_es + (fun inc op -> + let* inc = Incremental.validate_operation inc op in + return inc) + inc_in + ops + in + Incremental.validate_operation inc last ~expect_failure + +(** [validate_ko_diagnostic] wraps the [expect_failure] when [op] + validate failed. It is used in test that expects validate of the + last operation of a list of operations to fail. *) +let validate_ko_diagnostic ?(mode = Construction) (infos : infos) ops + expect_failure = + let open Lwt_result_syntax in + match mode with + | Construction | Mempool -> + let* i = + Incremental.begin_construction + infos.ctxt.block + ~mempool_mode:(mempool_mode_of mode) + in + let* _ = add_operations ~expect_failure i ops in + return_unit + | Application -> ( + let*! res = + Block.bake ~baking_mode:Application ~operations:ops infos.ctxt.block + in + match res with + | Error tr -> expect_failure tr + | _ -> failwith "Block application was expected to fail") + +(** List of operation kinds that must run on generic tests. This list + should be extended for each new manager_operation kind. *) +let subjects = + [ + K_Transaction; + K_Origination; + K_Register_global_constant; + K_Delegation; + K_Undelegation; + K_Self_delegation; + K_Set_deposits_limit; + K_Increase_paid_storage; + K_Reveal; + K_Tx_rollup_origination; + K_Tx_rollup_submit_batch; + K_Tx_rollup_commit; + K_Tx_rollup_return_bond; + K_Tx_rollup_finalize; + K_Tx_rollup_remove_commitment; + K_Tx_rollup_dispatch_tickets; + K_Transfer_ticket; + K_Tx_rollup_reject; + K_Sc_rollup_origination; + K_Sc_rollup_publish; + K_Sc_rollup_cement; + K_Sc_rollup_add_messages; + K_Sc_rollup_refute; + K_Sc_rollup_timeout; + K_Sc_rollup_execute_outbox_message; + K_Sc_rollup_recover_bond; + K_Dal_publish_slot_header; + ] + +let is_consumer = function + | K_Set_deposits_limit | K_Increase_paid_storage | K_Reveal + | K_Self_delegation | K_Delegation | K_Undelegation | K_Tx_rollup_origination + | K_Tx_rollup_submit_batch | K_Tx_rollup_finalize | K_Tx_rollup_commit + | K_Tx_rollup_return_bond | K_Tx_rollup_remove_commitment | K_Tx_rollup_reject + | K_Sc_rollup_add_messages | K_Sc_rollup_origination | K_Sc_rollup_refute + | K_Sc_rollup_timeout | K_Sc_rollup_cement | K_Sc_rollup_publish + | K_Sc_rollup_execute_outbox_message | K_Sc_rollup_recover_bond + | K_Dal_publish_slot_header -> + false + | K_Transaction | K_Origination | K_Register_global_constant + | K_Tx_rollup_dispatch_tickets | K_Transfer_ticket -> + true + +let gas_consumer_in_validate_subjects, not_gas_consumer_in_validate_subjects = + List.partition is_consumer subjects + +let revealed_subjects = + List.filter (function K_Reveal -> false | _ -> true) subjects + +let is_disabled flags = function + | K_Transaction | K_Origination | K_Register_global_constant | K_Delegation + | K_Undelegation | K_Self_delegation | K_Set_deposits_limit + | K_Increase_paid_storage | K_Reveal -> + false + | K_Tx_rollup_origination | K_Tx_rollup_submit_batch | K_Tx_rollup_commit + | K_Tx_rollup_return_bond | K_Tx_rollup_finalize + | K_Tx_rollup_remove_commitment | K_Tx_rollup_dispatch_tickets + | K_Transfer_ticket | K_Tx_rollup_reject -> + flags.toru = false + | K_Sc_rollup_origination | K_Sc_rollup_publish | K_Sc_rollup_cement + | K_Sc_rollup_add_messages | K_Sc_rollup_refute | K_Sc_rollup_timeout + | K_Sc_rollup_execute_outbox_message | K_Sc_rollup_recover_bond -> + flags.scoru = false + | K_Dal_publish_slot_header -> flags.dal = false diff --git a/src/proto_alpha/lib_protocol/test/integration/validate/test_1m_restriction.ml b/src/proto_alpha/lib_protocol/test/integration/validate/test_1m_restriction.ml new file mode 100644 index 0000000000000000000000000000000000000000..18c261fb070dd9052d1f9d5b437178b11db53a00 --- /dev/null +++ b/src/proto_alpha/lib_protocol/test/integration/validate/test_1m_restriction.ml @@ -0,0 +1,242 @@ +(*****************************************************************************) +(* *) +(* 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: Protocol (validate manager) + Invocation: dune exec \ + src/proto_alpha/lib_protocol/test/integration/validate/test_1m_restriction.exe + Subject: 1M restriction in validation of manager operation. +*) + +open Protocol +open Manager_operation_helpers +open Generators + +(** Local default values for the tests. *) +let ctxt_cstrs_default = + { + default_ctxt_cstrs with + src_cstrs = Greater {n = 15000; origin = 15000}; + dest_cstrs = Pure 15000; + del_cstrs = Pure 15000; + tx_cstrs = Pure 15000; + sc_cstrs = Pure 15000; + } + +let op_cstrs_default b = + { + default_operation_cstrs with + fee = Range {min = 0; max = 1_000; origin = 1_000}; + force_reveal = Some b; + amount = Range {min = 0; max = 10_000; origin = 10_000}; + } + +let print_one_op (ctxt_req, op_req, mode) = + Format.asprintf + "@[Generator printer:@,%a@,%a@,%a@]" + pp_ctxt_req + ctxt_req + pp_operation_req + op_req + pp_mode + mode + +let print_two_ops (ctxt_req, op_req, op_req', mode) = + Format.asprintf + "@[Generator printer:@,%a@,%a@,%a@,%a@]" + pp_ctxt_req + ctxt_req + pp_operation_req + op_req + pp_operation_req + op_req' + pp_mode + mode + +let print_ops_pair (ctxt_req, op_req, mode) = + Format.asprintf + "@[Generator printer:@,%a@,%a@,%a@]" + pp_ctxt_req + ctxt_req + pp_2_operation_req + op_req + pp_mode + mode + +(** The application of a valid operation succeeds, at least, to perform + the fee payment. *) +let positive_validated_op = + let gen = + QCheck2.Gen.triple + (Generators.gen_ctxt_req ctxt_cstrs_default) + (Generators.gen_operation_req (op_cstrs_default true) subjects) + Generators.gen_mode + in + wrap + ~count:1000 + ~print:print_one_op + ~name:"Positive validated op" + ~gen + (fun (ctxt_req, operation_req, mode) -> + let open Lwt_result_syntax in + let* infos = init_ctxt ctxt_req in + let* op = select_op operation_req infos in + let* _infos = wrap_mode infos [op] mode in + return_true) + +(** Under 1M restriction, neither a block nor a prevalidator's valid + pool should contain two operations with the same manager. It + raises a Manager_restriction error. *) +let negative_validated_two_ops_of_same_manager = + let gen = + QCheck2.Gen.quad + (Generators.gen_ctxt_req ctxt_cstrs_default) + (Generators.gen_operation_req (op_cstrs_default true) subjects) + (Generators.gen_operation_req (op_cstrs_default false) revealed_subjects) + Generators.gen_mode + in + let expect_failure = function + | [ + Environment.Ecoproto_error + (Validate_operation.Manager.Manager_restriction _); + ] -> + return_unit + | err -> + failwith + "Error trace:@,\ + \ %a does not match the \ + [Validate_operation.Manager.Manager_restriction] error" + Error_monad.pp_print_trace + err + in + wrap + ~count:1000 + ~print:print_two_ops + ~name:"Negative -- 1M" + ~gen + (fun (ctxt_req, operation_req, operation_req2, mode) -> + let open Lwt_result_syntax in + let* infos = init_ctxt ctxt_req in + let* op1 = select_op operation_req infos in + let* op2 = select_op operation_req2 infos in + let* _ = validate_ko_diagnostic ~mode infos [op1; op2] expect_failure in + return_true) + +(** Under 1M restriction, a batch of two operations cannot be replaced + by two single operations. *) +let negative_batch_of_two_is_not_two_single = + let gen = + QCheck2.Gen.triple + (Generators.gen_ctxt_req ctxt_cstrs_default) + (Generators.gen_2_operation_req + (op_cstrs_default false) + revealed_subjects) + Generators.gen_mode + in + let expect_failure _ = return_unit in + wrap + ~count:1000 + ~print:print_ops_pair + ~name:"Batch is not sequence of Single" + ~gen + (fun (ctxt_req, operation_req, mode) -> + let open Lwt_result_syntax in + let* infos = init_ctxt ctxt_req in + let* op1 = select_op (fst operation_req) infos in + let* op2 = select_op (snd operation_req) infos in + let source = contract_of infos.accounts.source in + let* batch = + Op.batch_operations ~source (B infos.ctxt.block) [op1; op2] + in + let* _ = validate_diagnostic ~mode infos [batch] in + let* _ = validate_ko_diagnostic ~mode infos [op1; op2] expect_failure in + return_true) + +(** The applications of two covalid operations in a certain context + succeed, at least, to perform the fee payment of both, in whatever + application order. *) +let valid_context_free = + let gen = + QCheck2.Gen.quad + (Generators.gen_ctxt_req ctxt_cstrs_default) + (Generators.gen_operation_req (op_cstrs_default true) revealed_subjects) + (Generators.gen_operation_req (op_cstrs_default true) revealed_subjects) + Generators.gen_mode + in + wrap + ~count:1000 + ~print:print_two_ops + ~name:"Under 1M, co-valid ops commute" + ~gen + (fun (ctxt_req, operation_req, operation_req', mode) -> + let open Lwt_result_syntax in + let* infos = init_ctxt ctxt_req in + let* op1 = select_op operation_req infos in + let infos2 = + { + infos with + accounts = + { + infos.accounts with + source = + (match infos.accounts.del with + | None -> assert false + | Some s -> s); + }; + } + in + let* op2 = select_op operation_req' infos2 in + let* _ = validate_diagnostic ~mode infos [op1; op2] in + let* _ = validate_diagnostic ~mode infos [op2; op1] in + return_true) + +open Lib_test.Qcheck2_helpers + +let positive_tests = qcheck_wrap [positive_validated_op] + +let two_op_from_same_manager_tests = + qcheck_wrap [negative_validated_two_ops_of_same_manager] + +let batch_is_not_singles_tests = + qcheck_wrap [negative_batch_of_two_is_not_two_single] + +let conflict_free_tests = qcheck_wrap [valid_context_free] + +let qcheck_tests = ("Positive tests", positive_tests) + +let qcheck_tests2 = + ("Only one manager op per manager", two_op_from_same_manager_tests) + +let qcheck_tests3 = + ("A batch differs from a sequence", batch_is_not_singles_tests) + +let qcheck_tests4 = + ("Fee payment of two covalid operations commute", conflict_free_tests) + +let () = + Alcotest.run + "1M QCheck" + [qcheck_tests; qcheck_tests2; qcheck_tests3; qcheck_tests4] diff --git a/src/proto_alpha/lib_protocol/test/integration/precheck/test_batched_manager_operation_precheck.ml b/src/proto_alpha/lib_protocol/test/integration/validate/test_batched_manager_operation_validation.ml similarity index 61% rename from src/proto_alpha/lib_protocol/test/integration/precheck/test_batched_manager_operation_precheck.ml rename to src/proto_alpha/lib_protocol/test/integration/validate/test_batched_manager_operation_validation.ml index 28bcc3c6fb299a816383446b6a6b54d11a765a5b..f53573b9eb1f139ea7e8d2982565eb2a8331e1f8 100644 --- a/src/proto_alpha/lib_protocol/test/integration/precheck/test_batched_manager_operation_precheck.ml +++ b/src/proto_alpha/lib_protocol/test/integration/validate/test_batched_manager_operation_validation.ml @@ -25,20 +25,20 @@ (** Testing ------- - Component: Protocol (precheck manager) + Component: Protocol (validate manager) Invocation: dune exec \ - src/proto_alpha/lib_protocol/test/integration/precheck/main.exe \ + src/proto_alpha/lib_protocol/test/integration/validate/main.exe \ -- test "^Batched" - Subject: Precheck manager operation. + Subject: Validation of batched manager operation. *) open Protocol open Alpha_context open Manager_operation_helpers -(* Tests on operation batches. *) +(** {2 Tests on operation batches} *) -(* Revelation should not occur elsewhere than in first position +(** Revelation should not occur elsewhere than in first position in a batch.*) let batch_reveal_in_the_middle_diagnostic (infos : infos) op = let expect_failure errs = @@ -54,40 +54,62 @@ let batch_reveal_in_the_middle_diagnostic (infos : infos) op = Error_monad.pp_print_trace err in - precheck_ko_diagnostic infos op expect_failure + validate_ko_diagnostic infos op expect_failure let test_batch_reveal_in_the_middle kind1 kind2 () = let open Lwt_result_syntax in - let* infos = init_context () in - let* counter = Context.Contract.counter (B infos.block) infos.contract1 in - let counter = counter in - let fee = Tez.one_mutez in + let* infos = default_init_ctxt () in + let* counter = + Context.Contract.counter + (B infos.ctxt.block) + (contract_of infos.accounts.source) + in let counter = Z.succ counter in let* operation1 = - select_op ~counter ~force_reveal:false ~source:infos.contract1 kind1 infos + select_op + { + (operation_req_default kind1) with + force_reveal = Some false; + counter = Some counter; + } + infos in let counter = Z.succ counter in - let* reveal = mk_reveal ~fee ~counter ~source:infos.contract1 infos in + let* reveal = + mk_reveal + { + (operation_req_default K_Reveal) with + fee = Some Tez.one_mutez; + counter = Some counter; + } + infos + in let counter = Z.succ counter in let* operation2 = - select_op ~counter ~force_reveal:false ~source:infos.contract1 kind2 infos + select_op + { + (operation_req_default kind2) with + force_reveal = Some false; + counter = Some counter; + } + infos in let* batch = Op.batch_operations ~recompute_counters:false - ~source:infos.contract1 - (Context.B infos.block) + ~source:(contract_of infos.accounts.source) + (Context.B infos.ctxt.block) [operation1; reveal; operation2] in - batch_reveal_in_the_middle_diagnostic infos batch + batch_reveal_in_the_middle_diagnostic infos [batch] let generate_batches_reveal_in_the_middle () = create_Tztest_batches test_batch_reveal_in_the_middle - "reveal should occur only at the beginning of a batch." + "Reveal should only occur at the beginning of a batch." revealed_subjects -(* A batch of manager operation contains at most one Revelation.*) +(** A batch of manager operation contains at most one Revelation.*) let batch_two_reveals_diagnostic (infos : infos) op = let expected_failure errs = match errs with @@ -102,30 +124,54 @@ let batch_two_reveals_diagnostic (infos : infos) op = Error_monad.pp_print_trace err in - precheck_ko_diagnostic infos op expected_failure + validate_ko_diagnostic infos op expected_failure let test_batch_two_reveals kind () = let open Lwt_result_syntax in - let* infos = init_context () in - let* counter = Context.Contract.counter (B infos.block) infos.contract1 in - let counter = counter in - let fee = Tez.one_mutez in + let* infos = default_init_ctxt () in + let* counter = + Context.Contract.counter + (B infos.ctxt.block) + (contract_of infos.accounts.source) + in let counter = Z.succ counter in - let* reveal = mk_reveal ~fee ~counter ~source:infos.contract1 infos in + let* reveal = + mk_reveal + { + (operation_req_default K_Reveal) with + fee = Some Tez.one_mutez; + counter = Some counter; + } + infos + in let counter = Z.succ counter in - let* reveal1 = mk_reveal ~fee ~counter ~source:infos.contract1 infos in + let* reveal1 = + mk_reveal + { + (operation_req_default K_Reveal) with + fee = Some Tez.one_mutez; + counter = Some counter; + } + infos + in let counter = Z.succ counter in let* operation = - select_op ~counter ~force_reveal:false ~source:infos.contract1 kind infos + select_op + { + (operation_req_default kind) with + force_reveal = Some false; + counter = Some counter; + } + infos in let* batch = Op.batch_operations ~recompute_counters:false - ~source:infos.contract1 - (Context.B infos.block) + ~source:(contract_of infos.accounts.source) + (Context.B infos.ctxt.block) [reveal; reveal1; operation] in - batch_two_reveals_diagnostic infos batch + batch_two_reveals_diagnostic infos [batch] let generate_tests_batches_two_reveals () = create_Tztest @@ -133,7 +179,7 @@ let generate_tests_batches_two_reveals () = "Only one revelation per batch." revealed_subjects -(* Every manager operation in a batch concerns the same source.*) +(** Every manager operation in a batch concerns the same source.*) let batch_two_sources_diagnostic (infos : infos) op = let expect_failure errs = match errs with @@ -147,27 +193,42 @@ let batch_two_sources_diagnostic (infos : infos) op = Error_monad.pp_print_trace err in - precheck_ko_diagnostic infos op expect_failure + validate_ko_diagnostic infos op expect_failure let test_batch_two_sources kind1 kind2 () = let open Lwt_result_syntax in - let* infos = init_context () in - let* counter = Context.Contract.counter (B infos.block) infos.contract1 in + let* infos = default_init_ctxt () in + let source = contract_of infos.accounts.source in + let* counter = Context.Contract.counter (B infos.ctxt.block) source in let counter = Z.succ counter in let* operation1 = - select_op ~counter ~force_reveal:true ~source:infos.contract1 kind1 infos + select_op + { + (operation_req_default kind1) with + force_reveal = Some true; + counter = Some counter; + } + infos + in + let infos = + let source2 = + match infos.accounts.del with None -> assert false | Some s -> s + in + {infos with accounts = {infos.accounts with source = source2}} in let* operation2 = - select_op ~force_reveal:false ~source:infos.contract2 kind2 infos + select_op + {(operation_req_default kind2) with force_reveal = Some false} + infos in let* batch = Op.batch_operations ~recompute_counters:false - ~source:infos.contract1 - (Context.B infos.block) + ~source + (Context.B infos.ctxt.block) [operation1; operation2] in - batch_two_sources_diagnostic infos batch + batch_two_sources_diagnostic infos [batch] let generate_batches_two_sources () = create_Tztest_batches @@ -175,21 +236,29 @@ let generate_batches_two_sources () = "Only one source per batch." revealed_subjects -(* Counters in a batch should be a sequence from the successor of +(** Counters in a batch should be a sequence from the successor of the stored counter associated to source in the initial context. *) let test_batch_inconsistent_counters kind1 kind2 () = let open Lwt_result_syntax in - let* infos = init_context () in - let* counter = Context.Contract.counter (B infos.block) infos.contract1 in - let fee = Tez.one_mutez in - let* reveal = mk_reveal ~fee ~counter ~source:infos.contract1 infos in + let* infos = default_init_ctxt () in + let source = contract_of infos.accounts.source in + let* counter = Context.Contract.counter (B infos.ctxt.block) source in + let fee = Some Tez.one_mutez in + let op_infos = operation_req_default K_Reveal in + let op_infos = {{op_infos with fee} with counter = Some counter} in + let* reveal = mk_reveal op_infos infos in let counter0 = counter in let counter = Z.succ counter in let counter2 = Z.succ counter in let counter3 = Z.succ counter2 in - let source = infos.contract1 in let operation counter kind = - select_op ~counter ~force_reveal:false ~source kind infos + select_op + { + (operation_req_default kind) with + counter = Some counter; + force_reveal = Some false; + } + infos in let op_counter = operation counter in let op_counter0 = operation counter0 in @@ -201,7 +270,7 @@ let test_batch_inconsistent_counters kind1 kind2 () = Op.batch_operations ~recompute_counters:false ~source - (Context.B infos.block) + (Context.B infos.ctxt.block) [reveal; op1; op2] in let* op1 = op_counter2 kind1 in @@ -210,7 +279,7 @@ let test_batch_inconsistent_counters kind1 kind2 () = Op.batch_operations ~recompute_counters:false ~source - (Context.B infos.block) + (Context.B infos.ctxt.block) [reveal; op1; op2] in let* op1 = op_counter kind1 in @@ -219,7 +288,7 @@ let test_batch_inconsistent_counters kind1 kind2 () = Op.batch_operations ~recompute_counters:false ~source - (Context.B infos.block) + (Context.B infos.ctxt.block) [reveal; op1; op2] in let* op1 = op_counter2 kind1 in @@ -228,7 +297,7 @@ let test_batch_inconsistent_counters kind1 kind2 () = Op.batch_operations ~recompute_counters:false ~source - (Context.B infos.block) + (Context.B infos.ctxt.block) [reveal; op1; op2] in let* op1 = op_counter0 kind1 in @@ -237,7 +306,7 @@ let test_batch_inconsistent_counters kind1 kind2 () = Op.batch_operations ~recompute_counters:false ~source - (Context.B infos.block) + (Context.B infos.ctxt.block) [reveal; op1; op2] in let expect_failure errs = @@ -252,7 +321,7 @@ let test_batch_inconsistent_counters kind1 kind2 () = Error_monad.pp_print_trace err in - let* i = Incremental.begin_construction infos.block in + let* i = Incremental.begin_construction infos.ctxt.block in let* _ = Incremental.add_operation ~expect_failure i batch_same in let* _ = Incremental.add_operation ~expect_failure i batch_in_the_future in let* _ = Incremental.add_operation ~expect_failure i batch_missing_one in @@ -266,23 +335,41 @@ let generate_batches_inconsistent_counters () = "Counters in a batch should be a sequence." revealed_subjects -(* A batch that consumes all the balance for fees can only face the total +(** A batch that consumes all the balance for fees can only face the total consumption at the end of the batch. *) let test_batch_emptying_balance_in_the_middle kind1 kind2 () = let open Lwt_result_syntax in - let* infos = init_context () in - let* counter = Context.Contract.counter (B infos.block) infos.contract1 in - let* init_bal = Context.Contract.balance (B infos.block) infos.contract1 in + let* infos = default_init_ctxt () in + let source = contract_of infos.accounts.source in + let* counter = Context.Contract.counter (B infos.ctxt.block) source in + let* init_bal = Context.Contract.balance (B infos.ctxt.block) source in let counter = counter in - let source = infos.contract1 in - let* reveal = mk_reveal ~counter ~source infos in + let* reveal = + mk_reveal + {(operation_req_default K_Reveal) with counter = Some counter} + infos + in let counter = Z.succ counter in let operation fee = - select_op ~fee ~counter ~force_reveal:false ~source kind1 infos + select_op + { + (operation_req_default kind1) with + force_reveal = Some false; + counter = Some counter; + fee = Some fee; + } + infos in let counter = Z.succ counter in let operation2 fee = - select_op ~fee ~counter ~force_reveal:false ~source kind2 infos + select_op + { + (operation_req_default kind2) with + force_reveal = Some false; + counter = Some counter; + fee = Some fee; + } + infos in let* op_case1 = operation init_bal in let* op2_case1 = operation2 Tez.zero in @@ -290,10 +377,10 @@ let test_batch_emptying_balance_in_the_middle kind1 kind2 () = Op.batch_operations ~recompute_counters:false ~source - (Context.B infos.block) + (Context.B infos.ctxt.block) [reveal; op_case1; op2_case1] in - let* i = Incremental.begin_construction infos.block in + let* i = Incremental.begin_construction infos.ctxt.block in let expect_failure errs = match errs with | [Environment.Ecoproto_error (Contract_storage.Empty_implicit_contract _)] @@ -314,36 +401,44 @@ let generate_batches_emptying_balance_in_the_middle () = "Fee payment emptying balance should occurs at the end of the batch." revealed_subjects -(* A batch of manager operation must not exceed the initial available gas in the block. *) +(** A batch of manager operation must not exceed the initial available gas in the block. *) let test_batch_exceeding_block_gas ~mempool_mode kind1 kind2 () = let open Lwt_result_syntax in - let* infos = init_context ~hard_gas_limit_per_block:gb_limit () in - let* counter = Context.Contract.counter (B infos.block) infos.contract1 in + let ctxt_req = + {ctxt_req_default with hard_gas_limit_per_block = Some gb_limit} + in + let* infos = init_ctxt ctxt_req in + let source = contract_of infos.accounts.source in + let* counter = Context.Contract.counter (B infos.ctxt.block) source in let g_limit = Gas.Arith.add gb_limit Gas.Arith.(integral_of_int_exn 1) in let half_limit = Gas.Arith.add half_gb_limit Gas.Arith.(integral_of_int_exn 1) in - let counter = counter in - let source = infos.contract1 in - let* reveal = mk_reveal ~counter ~source infos in + let* reveal = + mk_reveal + {(operation_req_default K_Reveal) with counter = Some counter} + infos + in let counter = Z.succ counter in let operation gas_limit = select_op - ~gas_limit:(Custom_gas gas_limit) - ~counter - ~force_reveal:false - ~source - kind1 + { + (operation_req_default kind1) with + force_reveal = Some false; + counter = Some counter; + gas_limit = Some (Custom_gas gas_limit); + } infos in let counter = Z.succ counter in let operation2 gas_limit = select_op - ~gas_limit:(Custom_gas gas_limit) - ~counter - ~force_reveal:false - ~source - kind2 + { + (operation_req_default kind2) with + force_reveal = Some false; + counter = Some counter; + gas_limit = Some (Custom_gas gas_limit); + } infos in let* op_case1 = operation g_limit in @@ -356,24 +451,24 @@ let test_batch_exceeding_block_gas ~mempool_mode kind1 kind2 () = Op.batch_operations ~recompute_counters:false ~source - (Context.B infos.block) + (Context.B infos.ctxt.block) [reveal; op_case1; op2_case1] in let* case3 = Op.batch_operations ~recompute_counters:false ~source - (Context.B infos.block) + (Context.B infos.ctxt.block) [reveal; op_case3; op2_case3] in let* case2 = Op.batch_operations ~recompute_counters:false ~source - (Context.B infos.block) + (Context.B infos.ctxt.block) [reveal; op_case2; op2_case2] in - let* i = Incremental.begin_construction infos.block ~mempool_mode in + let* i = Incremental.begin_construction infos.ctxt.block ~mempool_mode in let expect_failure errs = match errs with | [Environment.Ecoproto_error Gas.Block_quota_exceeded] @@ -408,24 +503,41 @@ let generate_batches_exceeding_block_gas_mp_mode () = "Too much gas consumption in mempool mode." revealed_subjects -(* A batch that consumes all the balance for fees only at the end of - the batch passes precheck.*) +(** A batch that consumes all the balance for fees only at the end of + the batch passes validate.*) let test_batch_balance_just_enough kind1 kind2 () = let open Lwt_result_syntax in - let* infos = init_context () in - let* counter = Context.Contract.counter (B infos.block) infos.contract1 in - let* init_bal = Context.Contract.balance (B infos.block) infos.contract1 in + let* infos = default_init_ctxt () in + let source = contract_of infos.accounts.source in + let* counter = Context.Contract.counter (B infos.ctxt.block) source in + let* init_bal = Context.Contract.balance (B infos.ctxt.block) source in let*? half_init_bal = Environment.wrap_tzresult @@ Tez.(init_bal /? 2L) in - let counter = counter in - let source = infos.contract1 in - let* reveal = mk_reveal ~counter ~source infos in + let* reveal = + mk_reveal + {(operation_req_default K_Reveal) with counter = Some counter} + infos + in let counter = Z.succ counter in let operation fee = - select_op ~fee ~counter ~force_reveal:false ~source kind1 infos + select_op + { + (operation_req_default kind1) with + force_reveal = Some false; + counter = Some counter; + fee = Some fee; + } + infos in let counter = Z.succ counter in let operation2 fee = - select_op ~fee ~counter ~force_reveal:false ~source kind2 infos + select_op + { + (operation_req_default kind2) with + force_reveal = Some false; + counter = Some counter; + fee = Some fee; + } + infos in let* op_case2 = operation Tez.zero in let* op2_case2 = operation2 init_bal in @@ -435,47 +547,63 @@ let test_batch_balance_just_enough kind1 kind2 () = Op.batch_operations ~recompute_counters:false ~source - (Context.B infos.block) + (Context.B infos.ctxt.block) [reveal; op_case3; op2_case3] in let* case2 = Op.batch_operations ~recompute_counters:false ~source - (Context.B infos.block) + (Context.B infos.ctxt.block) [reveal; op_case2; op2_case2] in - let* _ = precheck_diagnostic infos case2 in - precheck_diagnostic infos case3 + let* _ = validate_diagnostic infos [case2] in + let* _ = validate_diagnostic infos [case3] in + return_unit let generate_batches_balance_just_enough () = create_Tztest_batches test_batch_balance_just_enough - "(Positive test) Fee payment emptying balance in a batch." + "Fee payment emptying balance in a batch." revealed_subjects -(* Simple reveal followed by a transaction. *) +(** Simple reveal followed by a transaction. *) let test_batch_reveal_transaction_ok () = let open Lwt_result_syntax in - let* infos = init_context () in - let* counter = Context.Contract.counter (B infos.block) infos.contract1 in + let* infos = default_init_ctxt () in + let source = contract_of infos.accounts.source in + let* counter = Context.Contract.counter (B infos.ctxt.block) source in let counter = counter in let fee = Tez.one_mutez in - let source = infos.contract1 in - let* reveal = mk_reveal ~fee ~counter ~source infos in + let* reveal = + mk_reveal + { + (operation_req_default K_Reveal) with + fee = Some fee; + counter = Some counter; + } + infos + in let counter = Z.succ counter in let* transaction = - mk_transaction ~counter ~force_reveal:false ~source infos + mk_transaction + { + (operation_req_default K_Reveal) with + counter = Some counter; + force_reveal = Some false; + } + infos in let* batch = Op.batch_operations ~recompute_counters:false ~source - (Context.B infos.block) + (Context.B infos.ctxt.block) [reveal; transaction] in - let* _i = Incremental.begin_construction infos.block in - precheck_diagnostic infos batch + let* _i = Incremental.begin_construction infos.ctxt.block in + let* _ = validate_diagnostic infos [batch] in + return_unit let contract_tests = generate_batches_reveal_in_the_middle () @@ -484,7 +612,7 @@ let contract_tests = @ generate_batches_inconsistent_counters () @ [ Tztest.tztest - "Prechecked a batch with a reveal and a transaction." + "Validate a batch with a reveal and a transaction." `Quick test_batch_reveal_transaction_ok; ] diff --git a/src/proto_alpha/lib_protocol/test/integration/validate/test_manager_operation_validation.ml b/src/proto_alpha/lib_protocol/test/integration/validate/test_manager_operation_validation.ml new file mode 100644 index 0000000000000000000000000000000000000000..83108d0de5d66d2fe6e8f333209461f5558b7b94 --- /dev/null +++ b/src/proto_alpha/lib_protocol/test/integration/validate/test_manager_operation_validation.ml @@ -0,0 +1,780 @@ +(*****************************************************************************) +(* *) +(* 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: Protocol (validate manager) + Invocation: dune exec \ + src/proto_alpha/lib_protocol/test/integration/validate/main.exe \ + -- test "^Single" + Subject: Validation of manager operation. +*) + +open Protocol +open Alpha_context +open Manager_operation_helpers + +(** The goal of this test is to ensure that [select_op] generate the + wanted kind of manager operation + + Note: if a new manager operation kind is added in the protocol, + [Manager_operation_helpers.manager_operation_kind] should be + extended. You will also have to extend + [Manager_operation_helpers.select_op] with a new `mk` for this new + operation. Finally the list [Manager_operation_helpers.subjects] + should also be extended to run the validate test on the new manager + operation kind. *) +let ensure_kind infos kind = + let open Lwt_result_syntax in + let* op = + select_op + {(operation_req_default kind) with force_reveal = Some false} + infos + in + let (Operation_data {contents; _}) = op.protocol_data in + match contents with + | Single (Manager_operation {operation; _}) -> ( + match (operation, kind) with + | Transaction _, K_Transaction + | Reveal _, K_Reveal + | Origination _, K_Origination + | Delegation _, K_Delegation + | Delegation _, K_Undelegation + | Delegation _, K_Self_delegation + | Register_global_constant _, K_Register_global_constant + | Set_deposits_limit _, K_Set_deposits_limit + | Increase_paid_storage _, K_Increase_paid_storage + | Tx_rollup_origination, K_Tx_rollup_origination + | Tx_rollup_submit_batch _, K_Tx_rollup_submit_batch + | Tx_rollup_commit _, K_Tx_rollup_commit + | Tx_rollup_return_bond _, K_Tx_rollup_return_bond + | Tx_rollup_finalize_commitment _, K_Tx_rollup_finalize + | Tx_rollup_remove_commitment _, K_Tx_rollup_remove_commitment + | Tx_rollup_rejection _, K_Tx_rollup_reject + | Tx_rollup_dispatch_tickets _, K_Tx_rollup_dispatch_tickets + | Transfer_ticket _, K_Transfer_ticket + | Sc_rollup_originate _, K_Sc_rollup_origination + | Sc_rollup_add_messages _, K_Sc_rollup_add_messages + | Sc_rollup_cement _, K_Sc_rollup_cement + | Sc_rollup_publish _, K_Sc_rollup_publish + | Sc_rollup_refute _, K_Sc_rollup_refute + | Sc_rollup_timeout _, K_Sc_rollup_timeout + | Sc_rollup_execute_outbox_message _, K_Sc_rollup_execute_outbox_message + | Sc_rollup_recover_bond _, K_Sc_rollup_recover_bond + | Dal_publish_slot_header _, K_Dal_publish_slot_header -> + return_unit + | ( ( Transaction _ | Origination _ | Register_global_constant _ + | Delegation _ | Set_deposits_limit _ | Increase_paid_storage _ + | Reveal _ | Tx_rollup_origination | Tx_rollup_submit_batch _ + | Tx_rollup_commit _ | Tx_rollup_return_bond _ + | Tx_rollup_finalize_commitment _ | Tx_rollup_remove_commitment _ + | Tx_rollup_dispatch_tickets _ | Transfer_ticket _ + | Tx_rollup_rejection _ | Sc_rollup_originate _ | Sc_rollup_publish _ + | Sc_rollup_cement _ | Sc_rollup_add_messages _ | Sc_rollup_refute _ + | Sc_rollup_timeout _ | Sc_rollup_execute_outbox_message _ + | Sc_rollup_recover_bond _ | Dal_publish_slot_header _ + | Sc_rollup_dal_slot_subscribe _ ), + _ ) -> + assert false) + | Single _ -> assert false + | Cons _ -> assert false + +let ensure_manager_operation_coverage () = + let open Lwt_result_syntax in + let* infos = default_init_ctxt () in + List.iter_es (fun kind -> ensure_kind infos kind) subjects + +let test_ensure_manager_operation_coverage () = + Tztest.tztest + (Format.sprintf "Ensure manager_operation coverage") + `Quick + (fun () -> ensure_manager_operation_coverage ()) + +(** {2 Negative tests assert the case where validate must fail} *) + +(** Validate fails if the gas limit is too low. + + This test asserts that the validation of a manager operation + with a too low gas limit fails at validate with an + [Gas_quota_exceeded_init_deserialize] error. + This test applies on manager operations that do not + consume gas in their specific part of validate. *) +let low_gas_limit_diagnostic (infos : infos) op = + let expect_failure errs = + match errs with + | [ + Environment.Ecoproto_error + Validate_operation.Manager.Gas_quota_exceeded_init_deserialize; + Environment.Ecoproto_error Raw_context.Operation_quota_exceeded; + ] -> + return_unit + | err -> + failwith + "Error trace:@, %a does not match the expected one" + Error_monad.pp_print_trace + err + in + validate_ko_diagnostic infos op expect_failure + +let test_low_gas_limit kind () = + let open Lwt_result_syntax in + let* infos = default_init_ctxt () in + let* op = + select_op + { + (operation_req_default kind) with + gas_limit = Some Op.Low; + force_reveal = Some true; + } + infos + in + low_gas_limit_diagnostic infos [op] + +let generate_low_gas_limit () = + create_Tztest + test_low_gas_limit + "Gas_limit too low." + gas_consumer_in_validate_subjects + +(** Validate fails if the gas limit is too high. + + This test asserts that the validation of a manager operation with + a gas limit too high fails at validate with an [Gas_limit_too_high] + error. It applies on every kind of manager operation. *) +let high_gas_limit_diagnostic (infos : infos) op = + let expect_failure errs = + match errs with + | [Environment.Ecoproto_error Gas.Gas_limit_too_high] -> return_unit + | err -> + failwith + "Error trace:@, %a does not match the expected one" + Error_monad.pp_print_trace + err + in + validate_ko_diagnostic infos op expect_failure + +let test_high_gas_limit kind () = + let open Lwt_result_syntax in + let* infos = default_init_ctxt () in + let* op = + select_op + { + (operation_req_default kind) with + force_reveal = Some true; + gas_limit = + Some (Op.Custom_gas (Gas.Arith.integral_of_int_exn 10_000_000)); + } + infos + in + high_gas_limit_diagnostic infos [op] + +let generate_high_gas_limit () = + create_Tztest test_high_gas_limit "Gas_limit too high." subjects + +(** Validate fails if the storage limit is too high. + + This test asserts that a manager operation with a storage limit + too high fails at validation with [Storage_limit_too_high] error. + It applies to every kind of manager operation. *) +let high_storage_limit_diagnostic (infos : infos) op = + let expect_failure errs = + match errs with + | [Environment.Ecoproto_error Fees_storage.Storage_limit_too_high] -> + return_unit + | err -> + failwith + "Error trace:@, %a does not match the expected one" + Error_monad.pp_print_trace + err + in + validate_ko_diagnostic infos op expect_failure + +let test_high_storage_limit kind () = + let open Lwt_result_syntax in + let* infos = default_init_ctxt () in + let* op = + select_op + { + (operation_req_default kind) with + force_reveal = Some true; + storage_limit = Some (Z.of_int max_int); + } + infos + in + high_storage_limit_diagnostic infos [op] + +let generate_high_storage_limit () = + create_Tztest test_high_gas_limit "Storage_limit too high." subjects + +(** Validate fails if the counter is in the future. + + This test asserts that the validation of + a manager operation with a counter in the + future -- aka greater than the successor of the manager counter + stored in the current context -- fails with [Counter_in_the_future] error. + It applies to every kind of manager operation. *) +let high_counter_diagnostic (infos : infos) op = + let expect_failure errs = + match errs with + | [Environment.Ecoproto_error (Contract_storage.Counter_in_the_future _)] -> + return_unit + | err -> + failwith + "Error trace:@, %a does not match the expected one" + Error_monad.pp_print_trace + err + in + validate_ko_diagnostic infos op expect_failure + +let test_high_counter kind () = + let open Lwt_result_syntax in + let* infos = default_init_ctxt () in + let* op = + select_op + { + (operation_req_default kind) with + force_reveal = Some true; + counter = Some (Z.of_int max_int); + } + infos + in + high_counter_diagnostic infos [op] + +let generate_high_counter () = + create_Tztest test_high_counter "Counter too high." subjects + +(** Validate fails if the counter is in the past. + + This test asserts that the validation of a manager operation with a + counter in the past -- aka smaller than the successor of the + manager counter stored in the current context -- fails with + [Counter_in_the_past] error. It applies to every kind of manager + operation. *) +let low_counter_diagnostic (infos : infos) op = + let expect_failure errs = + match errs with + | [Environment.Ecoproto_error (Contract_storage.Counter_in_the_past _)] -> + return_unit + | err -> + failwith + "Error trace:@, %a does not match the expected one" + Error_monad.pp_print_trace + err + in + validate_ko_diagnostic infos op expect_failure + +let test_low_counter kind () = + let open Lwt_result_syntax in + let* infos = default_init_ctxt () in + let* current_counter = + Context.Contract.counter + (B infos.ctxt.block) + (contract_of infos.accounts.source) + in + let* op = + select_op + { + (operation_req_default kind) with + force_reveal = Some true; + counter = Some (Z.sub current_counter Z.one); + } + infos + in + low_counter_diagnostic infos [op] + +let generate_low_counter () = + create_Tztest test_low_counter "Counter too low." subjects + +(** Validate fails if the source is not allocated. + + This test asserts that the validation of a manager operation which + manager contract is not allocated fails with + [Empty_implicit_contract] error. It applies on every kind of + manager operation. *) +let not_allocated_diagnostic (infos : infos) op = + let expect_failure errs = + match errs with + | [Environment.Ecoproto_error (Contract_storage.Empty_implicit_contract _)] + -> + return_unit + | err -> + failwith + "Error trace:@, %a does not match the expected one" + Error_monad.pp_print_trace + err + in + validate_ko_diagnostic infos op expect_failure + +let test_not_allocated kind () = + let open Lwt_result_syntax in + let* infos = default_init_ctxt () in + let* op = + select_op + {(operation_req_default kind) with force_reveal = Some false} + { + infos with + accounts = {infos.accounts with source = Account.(new_account ())}; + } + in + not_allocated_diagnostic infos [op] + +let generate_not_allocated () = + create_Tztest test_not_allocated "Not allocated source." subjects + +(** Validate fails if the source is unrevealed. + + This test asserts that a manager operation with an unrevealed source + contract fails at validation with [Unrevealed_manager_key]. + It applies on every kind of manager operation except [Revelation]. *) +let unrevealed_key_diagnostic (infos : infos) op = + let expect_failure errs = + match errs with + | [ + Environment.Ecoproto_error + (Contract_manager_storage.Unrevealed_manager_key _); + ] -> + return_unit + | err -> + failwith + "Error trace:@, %a does not match the expected one" + Error_monad.pp_print_trace + err + in + validate_ko_diagnostic infos op expect_failure + +let test_unrevealed_key kind () = + let open Lwt_result_syntax in + let* infos = default_init_ctxt () in + let* op = + select_op + {(operation_req_default kind) with force_reveal = Some false} + infos + in + unrevealed_key_diagnostic infos [op] + +let generate_unrevealed_key () = + create_Tztest + test_unrevealed_key + "Unrevealed source (find_manager_public_key)." + revealed_subjects + +(** Validate fails if the source balance is not enough to pay the fees. + + This test asserts that validation of a manager operation fails if the + source balance is lesser than the manager operation fee. + It applies on every kind of manager operation. *) +let high_fee_diagnostic (infos : infos) op = + let expect_failure errs = + match errs with + | [ + Environment.Ecoproto_error (Contract_storage.Balance_too_low _); + Environment.Ecoproto_error (Tez_repr.Subtraction_underflow _); + ] -> + return_unit + | err -> + failwith + "Error trace:@, %a does not match the expected one" + Error_monad.pp_print_trace + err + in + validate_ko_diagnostic infos op expect_failure + +let test_high_fee kind () = + let open Lwt_result_syntax in + let* infos = default_init_ctxt () in + let*? fee = Tez.(one +? one) |> Environment.wrap_tzresult in + let* op = + select_op + { + (operation_req_default kind) with + force_reveal = Some true; + fee = Some fee; + } + infos + in + high_fee_diagnostic infos [op] + +let generate_tests_high_fee () = + create_Tztest test_high_fee "Balance too low for fee payment." subjects + +(** Validate fails if the fee payment empties the balance of a + delegated implicit contract. + + This test asserts that in case that: + - the source is a delegated implicit contract, and + - the fee is the exact balance of source. + then, validate fails with [Empty_implicit_delegated_contract] error. + It applies to every kind of manager operation except [Revelation].*) +let emptying_delegated_implicit_diagnostic (infos : infos) op = + let expect_failure errs = + match errs with + | [ + Environment.Ecoproto_error + (Contract_storage.Empty_implicit_delegated_contract _); + ] -> + return_unit + | err -> + failwith + "Error trace:@, %a does not match the expected one" + Error_monad.pp_print_trace + err + in + validate_ko_diagnostic infos op expect_failure + +let test_emptying_delegated_implicit kind () = + let open Lwt_result_syntax in + let* infos = default_ctxt_with_delegation () in + let* fee = + Context.Contract.balance + (B infos.ctxt.block) + (contract_of infos.accounts.source) + in + let* op = + select_op + { + (operation_req_default kind) with + force_reveal = Some false; + fee = Some fee; + } + infos + in + emptying_delegated_implicit_diagnostic infos [op] + +let generate_tests_emptying_delegated_implicit () = + create_Tztest + test_emptying_delegated_implicit + "Just enough funds to empty a delegated source." + revealed_subjects + +(** Validate fails if there is not enough available gas in the block. + + This test asserts that validate fails with: + - [Gas_limit_too_high;Block_quota_exceeded] in mempool mode, + - [Block_quota_exceeded] in other mode + with gas limit exceeds the available gas in the block. + It applies to every kind of manager operation. *) +let exceeding_block_gas_diagnostic ~mode (infos : infos) op = + let expect_failure errs = + match (errs, mode) with + | ( [Environment.Ecoproto_error Gas.Block_quota_exceeded], + (Construction | Application) ) -> + return_unit + | ( [ + Environment.Ecoproto_error Gas.Gas_limit_too_high; + Environment.Ecoproto_error Gas.Block_quota_exceeded; + ], + Mempool ) -> + (* In mempool_mode, batch that exceed [operation_gas_limit] needs + to be refused. [Gas.Block_quota_exceeded] only return a + temporary error. [Gas.Gas_limit_too_high], which is a + permanent error, is added to the error trace to ensure that + the batch is refused. *) + return_unit + | err, _ -> + failwith + "Error trace:@, %a does not match the expected one" + Error_monad.pp_print_trace + err + in + validate_ko_diagnostic infos op expect_failure ~mode + +let test_exceeding_block_gas ~mode kind () = + let open Lwt_result_syntax in + let ctxt_req = + {ctxt_req_default with hard_gas_limit_per_block = Some gb_limit} + in + let* infos = init_ctxt ctxt_req in + let* operation = + select_op + { + (operation_req_default kind) with + force_reveal = Some true; + gas_limit = + Some + (Op.Custom_gas + (Gas.Arith.add gb_limit Gas.Arith.(integral_of_int_exn 1))); + } + infos + in + exceeding_block_gas_diagnostic ~mode infos [operation] + +let generate_tests_exceeding_block_gas () = + create_Tztest + (test_exceeding_block_gas ~mode:Construction) + "Too much gas consumption." + subjects + +let generate_tests_exceeding_block_gas_mp_mode () = + create_Tztest + (test_exceeding_block_gas ~mode:Mempool) + "Too much gas consumption in mempool mode." + subjects + +(** {2 Positive tests} *) + +(** Tests that validate succeeds when: + - it empties the balance of a self_delegated implicit source, + - it empties the balance of an undelegated implicit source, and + - in case: + - the counter is the successor of the one stored in the context, + - the fee is lesser than the balance, + - the storage limit is lesser than the maximum authorized storage, + - the gas limit is: + - lesser than the available gas in the block, + - less than the maximum gas consumable by an operation, and + - greater than the minimum gas consumable by an operation. + + Notice that in the first two cases only validate succeeds while + in the last case, the full application also succeeds. + In the first 2 case, we observe in the output context that: + - the counter is the successor of the one stored in the initial context, + - the balance decreased by fee, + - the available gas in the block decreased by gas limit. + In the last case, we observe in the output context that: + - the counter is the successor of the one stored in the initial context, + - the balance is at least decreased by fee, + - the available gas in the block decreased by gas limit. *) + +(** Fee payment that emptying a self_delegated implicit. *) +let test_emptying_self_delegated_implicit kind () = + let open Lwt_result_syntax in + let* infos = default_ctxt_with_self_delegation () in + let* fee = + Context.Contract.balance + (B infos.ctxt.block) + (contract_of infos.accounts.source) + in + let* op = + select_op + { + (operation_req_default kind) with + force_reveal = Some false; + fee = Some fee; + } + infos + in + let* _ = only_validate_diagnostic infos [op] in + return_unit + +let generate_tests_emptying_self_delegated_implicit () = + create_Tztest + test_emptying_self_delegated_implicit + "Validate and empties a self-delegated source." + subjects + +(** Minimum gas cost to pass the validation: + - cost_of_manager_operation for the generic part + - 100 (empiric) for the specific part (script decoding or hash costs) *) +let empiric_minimal_gas_cost_for_validate = + Gas.Arith.integral_of_int_exn + (Michelson_v1_gas.Internal_for_tests.int_cost_of_manager_operation + 100) + +let test_emptying_undelegated_implicit kind () = + let open Lwt_result_syntax in + let* infos = default_init_ctxt () in + let* fee = + Context.Contract.balance + (B infos.ctxt.block) + (contract_of infos.accounts.source) + in + let* op = + select_op + { + (operation_req_default kind) with + force_reveal = Some true; + fee = Some fee; + gas_limit = Some (Op.Custom_gas empiric_minimal_gas_cost_for_validate); + } + infos + in + let* _ = only_validate_diagnostic infos [op] in + return_unit + +let generate_tests_emptying_undelegated_implicit () = + create_Tztest + test_emptying_undelegated_implicit + "Validate and empties an undelegated source." + subjects + +(** No gas consumer with the minimal gas limit for manager operations + passes validate. *) +let test_low_gas_limit_no_consumer kind () = + let open Lwt_result_syntax in + let* infos = default_init_ctxt () in + let* op = + select_op + { + (operation_req_default kind) with + force_reveal = Some true; + gas_limit = Some Op.Low; + } + infos + in + validate_diagnostic infos [op] + +let generate_low_gas_limit_no_consumer () = + create_Tztest + test_low_gas_limit + "passes validate with minimal gas limit for manager operations." + gas_consumer_in_validate_subjects + +(** Fee payment.*) +let test_validate kind () = + let open Lwt_result_syntax in + let* infos = default_init_ctxt () in + let* counter = + Context.Contract.counter + (B infos.ctxt.block) + (contract_of infos.accounts.source) + in + let* op = + select_op + { + (operation_req_default kind) with + force_reveal = Some true; + counter = Some counter; + } + infos + in + let* _ = validate_diagnostic infos [op] in + return_unit + +let generate_tests_validate () = + create_Tztest test_validate "Validate." subjects + +(* Feature flags.*) + +(* Select the error according to the positionned flag. + We assume that only one feature is disabled. *) +let flag_expect_failure flags errs = + match errs with + | [ + Environment.Ecoproto_error + Validate_operation.Manager.Sc_rollup_feature_disabled; + ] + when flags.scoru = false -> + return_unit + | [ + Environment.Ecoproto_error + Validate_operation.Manager.Tx_rollup_feature_disabled; + ] + when flags.toru = false -> + return_unit + | [Environment.Ecoproto_error Dal_errors.Dal_feature_disabled] + when flags.dal = false -> + return_unit + | err -> + failwith + "Error trace:@, %a does not match the expected one" + Error_monad.pp_print_trace + err + +(* Tests that operations depending on feature flags are not valid + when the flag is set as disable. + + See [is_disabled] and the [flags] in `manager_operation_helpers`. + We assume that only one flag is set at false in flag. + + In order to forge Toru, Scoru or Dal operation when the correspondong + feature is disable, we use a [infos_op] with default requirements, + so that we have a Tx_rollup.t and a Sc_rollup.t. *) +let test_feature_flags flags kind () = + let open Lwt_result_syntax in + let* infos_op = default_init_ctxt () in + let* infos = default_init_with_flags flags in + let infos = + { + infos with + ctxt = + { + infos.ctxt with + tx_rollup = infos_op.ctxt.tx_rollup; + sc_rollup = infos_op.ctxt.sc_rollup; + }; + } + in + let* counter = + Context.Contract.counter + (B infos.ctxt.block) + (contract_of infos.accounts.source) + in + let* op = + select_op + { + {(operation_req_default kind) with force_reveal = Some true} with + counter = Some counter; + } + infos + in + let* _ = + if is_disabled flags kind then + validate_ko_diagnostic infos [op] (flag_expect_failure flags) + else + let* _ = validate_diagnostic infos [op] in + return_unit + in + return_unit + +let generate_dal_flag () = + create_Tztest + (test_feature_flags disabled_dal) + "Validate with dal disabled." + subjects + +let generate_scoru_flag () = + create_Tztest + (test_feature_flags disabled_scoru) + "Validate with scoru disabled." + subjects + +let generate_toru_flag () = + create_Tztest + (test_feature_flags disabled_toru) + "Validate with toru disabled." + subjects + +let sanity_tests = + test_ensure_manager_operation_coverage () :: generate_tests_validate () + +let gas_tests = + generate_low_gas_limit () @ generate_high_gas_limit () + @ generate_tests_exceeding_block_gas () + @ generate_tests_exceeding_block_gas_mp_mode () + @ generate_low_gas_limit_no_consumer () + +let storage_tests = generate_high_storage_limit () + +let fee_tests = + generate_tests_high_fee () + @ generate_tests_emptying_delegated_implicit () + @ generate_tests_emptying_self_delegated_implicit () + @ generate_tests_emptying_undelegated_implicit () + +let contract_tests = + generate_high_counter () @ generate_low_counter () @ generate_not_allocated () + @ generate_unrevealed_key () + +let flags_tests = + generate_dal_flag () @ generate_toru_flag () @ generate_scoru_flag () diff --git a/tezt/lib_tezos/RPC.ml b/tezt/lib_tezos/RPC.ml index d6e0d42b047d053713ca4dd0dca81c142992ae98..6f791891e5a52156e6274f340a722a0d9e6c4b94 100644 --- a/tezt/lib_tezos/RPC.ml +++ b/tezt/lib_tezos/RPC.ml @@ -191,8 +191,8 @@ let post_private_injection_operation ?(async = false) data = ~data Fun.id -let post_run_operation ?(chain = "main") ?(block = "head") ?(async = false) data - = +let post_chain_block_helpers_scripts_run_operation ?(chain = "main") + ?(block = "head") ?(async = false) data = make POST ["chains"; chain; "blocks"; block; "helpers"; "scripts"; "run_operation"] diff --git a/tezt/lib_tezos/RPC.mli b/tezt/lib_tezos/RPC.mli index add8900a5eb1def3368cfd0e3295f8b58e44abd9..403b24a357ef39258572b90ab6305b4b598a4dbb 100644 --- a/tezt/lib_tezos/RPC.mli +++ b/tezt/lib_tezos/RPC.mli @@ -222,11 +222,16 @@ val post_injection_operation : ?async:bool -> JSON.u -> JSON.t t (** RPC: [POST /private/injection/operation] *) val post_private_injection_operation : ?async:bool -> JSON.u -> JSON.t t -(** RPC: [POST /chains/[chain]/blocks/[block]/helpers/scripts/run_operation] +(** RPC: [POST /chains//blocks//helpers/scripts/run_operation] + + Tries to validate and apply the operation represented by the given + json, directly on top of the [block]. Only skips signature + checks. If successful, returns the operation together with the + metadata produced by its application. [chain] defaults to ["main"]. [block] defaults to ["head"]. *) -val post_run_operation : +val post_chain_block_helpers_scripts_run_operation : ?chain:string -> ?block:string -> ?async:bool -> JSON.u -> JSON.t t (** RPC: [GET /chains/[chain]/chain_id] diff --git a/tezt/lib_tezos/RPC_legacy.ml b/tezt/lib_tezos/RPC_legacy.ml index 1adb473033d63cfdf7e5c0e9b45a9badc4683665..d5d95001a4a5b63cb04190c398bf76aed13568de 100644 --- a/tezt/lib_tezos/RPC_legacy.ml +++ b/tezt/lib_tezos/RPC_legacy.ml @@ -195,13 +195,6 @@ let post_forge_operations ?endpoint ?hooks ?(chain = "main") ?(block = "head") in Client.rpc ?endpoint ?hooks ~data POST path client -let post_run_operation ?endpoint ?hooks ?(chain = "main") ?(block = "head") - ~data client = - let path = - ["chains"; chain; "blocks"; block; "helpers"; "scripts"; "run_operation"] - in - Client.rpc ?endpoint ?hooks ~data POST path client - let post_simulate_operation ?endpoint ?hooks ?(chain = "main") ?(block = "head") ~data client = let path = diff --git a/tezt/lib_tezos/RPC_legacy.mli b/tezt/lib_tezos/RPC_legacy.mli index b67149b3894bc6336182d602a896070fdadb472b..5222235804901f947488cc0bbd82b395e13fd493 100644 --- a/tezt/lib_tezos/RPC_legacy.mli +++ b/tezt/lib_tezos/RPC_legacy.mli @@ -27,7 +27,7 @@ (** Legacy node RPCs. *) (** THIS MODULE IS DEPRECATED: ITS FUNCTIONS SHOULD BE PORTED TO THE NEW RPC - ENGINE (IN [rpc.ml], USING MODULE [RPC_core]). *) + ENGINE (IN [RPC.ml], USING MODULE [RPC_core]). *) (** In all RPCs, default [chain] is "main" and default [block] is "head~2" to pick the finalized branch for Tenderbake. *) @@ -175,16 +175,6 @@ val post_forge_operations : Client.t -> JSON.t Lwt.t -(** Call RPC /chain/[chain]/blocks/[block]/helpers/scripts/run_operation *) -val post_run_operation : - ?endpoint:Client.endpoint -> - ?hooks:Process.hooks -> - ?chain:string -> - ?block:string -> - data:JSON.u -> - Client.t -> - JSON.t Lwt.t - (** Call RPC /chain/[chain]/blocks/[block]/helpers/scripts/simulate_operation *) val post_simulate_operation : ?endpoint:Client.endpoint -> diff --git a/tezt/lib_tezos/mempool.ml b/tezt/lib_tezos/mempool.ml index 6d31d0cfbfe99dac7c00bb54b477e47f694696fc..6aac99965ce620b95980f2954029b55a66a8370b 100644 --- a/tezt/lib_tezos/mempool.ml +++ b/tezt/lib_tezos/mempool.ml @@ -88,10 +88,23 @@ let symmetric_diff left right = unprocessed = diff left.unprocessed right.unprocessed; } +let of_json mempool_json = + let get_hash op = JSON.(op |-> "hash" |> as_string) in + let get_hashes classification = + List.map get_hash JSON.(mempool_json |-> classification |> as_list) + in + let applied = get_hashes "applied" in + let branch_delayed = get_hashes "branch_delayed" in + let branch_refused = get_hashes "branch_refused" in + let refused = get_hashes "refused" in + let outdated = get_hashes "outdated" in + let unprocessed = get_hashes "unprocessed" in + {applied; branch_delayed; branch_refused; refused; outdated; unprocessed} + let get_mempool ?endpoint ?hooks ?chain ?(applied = true) ?(branch_delayed = true) ?(branch_refused = true) ?(refused = true) ?(outdated = true) client = - let* pending_ops = + let* mempool_json = RPC.get_mempool_pending_operations ?endpoint ?hooks @@ -104,15 +117,14 @@ let get_mempool ?endpoint ?hooks ?chain ?(applied = true) ~outdated client in - let get_hash op = JSON.(op |-> "hash" |> as_string) in - let get_hashes classification = - List.map get_hash JSON.(pending_ops |-> classification |> as_list) - in - let applied = get_hashes "applied" in - let branch_delayed = get_hashes "branch_delayed" in - let branch_refused = get_hashes "branch_refused" in - let refused = get_hashes "refused" in - let outdated = get_hashes "outdated" in - let unprocessed = get_hashes "unprocessed" in - return + return (of_json mempool_json) + +let check_mempool ?(applied = []) ?(branch_delayed = []) ?(branch_refused = []) + ?(refused = []) ?(outdated = []) ?(unprocessed = []) mempool = + let expected_mempool = {applied; branch_delayed; branch_refused; refused; outdated; unprocessed} + in + Check.( + (expected_mempool = mempool) + classified_typ + ~error_msg:"Expected mempool %L, got %R") diff --git a/tezt/lib_tezos/mempool.mli b/tezt/lib_tezos/mempool.mli index d0e8cdc139e88c4e452409de9e6c02e72e1d97a2..0c8c5d2e8d828859f8bb8e55de431c511849322a 100644 --- a/tezt/lib_tezos/mempool.mli +++ b/tezt/lib_tezos/mempool.mli @@ -45,6 +45,10 @@ val empty : t (** Symetric difference (union(a, b) - intersection(a, b)) *) val symmetric_diff : t -> t -> t +(** Build a value of type {!t} from a json returned by + {!RPC.get_mempool_pending_operations}. *) +val of_json : JSON.t -> t + (** Call [RPC.get_mempool_pending_operations] and wrap the result in a value of type [Mempool.t] *) val get_mempool : @@ -58,3 +62,17 @@ val get_mempool : ?outdated:bool -> Client.t -> t Lwt.t + +(** Check that each field of [t] contains the same elements as the + argument of the same name. Ordening does not matter. Omitted + arguments default to the empty list. This is useful when we expect a + sparse mempool. *) +val check_mempool : + ?applied:string list -> + ?branch_delayed:string list -> + ?branch_refused:string list -> + ?refused:string list -> + ?outdated:string list -> + ?unprocessed:string list -> + t -> + unit diff --git a/tezt/lib_tezos/operation_core.ml b/tezt/lib_tezos/operation_core.ml index 7cbabe6d679904d363c0cc51efe76c71e19dcce9..00b3695ce35f9fb7fa8ee000ca08083e1fcf44e7 100644 --- a/tezt/lib_tezos/operation_core.ml +++ b/tezt/lib_tezos/operation_core.ml @@ -149,6 +149,28 @@ let inject_operations ?(request = `Inject) ?(force = false) ?error t client : let* () = Process.check_error ~msg process in Lwt_list.map_s (fun op -> hash op client) t +let make_run_operation_input ?chain_id t client = + let* chain_id = + match chain_id with + | Some chain_id -> return chain_id + | None -> RPC.(Client.call client (get_chain_chain_id ())) + in + (* The [run_operation] RPC does not check the signature. *) + let signature = Tezos_crypto.Signature.zero in + return + (`O + [ + ( "operation", + `O + [ + ("branch", `String t.branch); + ("contents", t.contents); + ( "signature", + `String (Tezos_crypto.Signature.to_b58check signature) ); + ] ); + ("chain_id", `String chain_id); + ]) + module Consensus = struct type t = Slot_availability of {endorsement : bool array} @@ -191,11 +213,14 @@ end module Manager = struct type payload = + | Reveal of Account.key | Transfer of {amount : int; dest : Account.key} | Dal_publish_slot_header of {level : int; index : int; header : int} | Sc_rollup_dal_slot_subscribe of {rollup : string; slot_index : int} | Delegation of {delegate : Account.key} + let reveal account = Reveal account + let transfer ?(dest = Constant.bootstrap2) ?(amount = 1_000_000) () = Transfer {amount; dest} @@ -233,6 +258,8 @@ module Manager = struct return (1 + JSON.as_int json) let json_payload_binding = function + | Reveal account -> + [("kind", `String "reveal"); ("public_key", `String account.public_key)] | Transfer {amount; dest} -> [ ("kind", `String "transaction"); @@ -308,8 +335,8 @@ module Manager = struct let gas_limit = Option.value gas_limit ~default:1_040 in let storage_limit = Option.value storage_limit ~default:257 in {source; counter; fee; gas_limit; storage_limit; payload} - | Dal_publish_slot_header _ | Delegation _ | Sc_rollup_dal_slot_subscribe _ - -> + | Reveal _ | Dal_publish_slot_header _ | Delegation _ + | Sc_rollup_dal_slot_subscribe _ -> let fee = Option.value fee ~default:1_000 in let gas_limit = Option.value gas_limit ~default:1_040 in let storage_limit = Option.value storage_limit ~default:0 in diff --git a/tezt/lib_tezos/operation_core.mli b/tezt/lib_tezos/operation_core.mli index d24c82b5b25448e899f7c3f24b84fba7c2be78c3..fff4c7fafb4f298d1b2f308c6136de063e44aa27 100644 --- a/tezt/lib_tezos/operation_core.mli +++ b/tezt/lib_tezos/operation_core.mli @@ -134,6 +134,24 @@ val inject_operations : Client.t -> [`OpHash of string] list Lwt.t +(** Craft a json representing the full operation, in a format that is + compatible with the [run_operation] RPC + ({!RPC.post_chain_block_helpers_scripts_run_operation}). + + This json contains many more fields than the one produced by the + {!json} function above. + + The operation is signed with {!Tezos_crypto.Signature.zero}, + because the [run_operation] RPC skips signature checks anyway. + + @param chain_id Allows to manually provide the [chain_id]. If + omitted, the [chain_id] is retrieved via RPC using the provided + [client]. + + @param client The {!Client.t} argument is used to retrieve the + [chain_id] when it is not provided. *) +val make_run_operation_input : ?chain_id:string -> t -> Client.t -> JSON.u Lwt.t + module Consensus : sig (** A representation of a consensus operation. *) type t @@ -175,6 +193,12 @@ module Manager : sig common to all manager operations. See {!type:t}. *) type payload + (** Build a public key revelation. + + The [Account.key] argument has no default value because it will + typically be a fresh account. *) + val reveal : Account.key -> payload + (** [transfer ?(dest=Constant.bootstrap2) ~amount:1_000_000 ()] builds a transfer operation. Note that the amount is expressed in mutez. *) diff --git a/tezt/tests/main.ml b/tezt/tests/main.ml index 6e39f32a0babe8fb9f28d2eaa6d61b4f03439f8e..3ac2b72a3f419f495ac0a3baf6530c3146369f90 100644 --- a/tezt/tests/main.ml +++ b/tezt/tests/main.ml @@ -104,7 +104,6 @@ let register_protocol_agnostic_tests () = Monitor_operations.register ~protocols:[Alpha] ; Node_event_level.register ~protocols:[Alpha] ; Normalize.register ~protocols:[Alpha] ; - Op_validation.register ~protocols ; Precheck.register ~protocols ; Prevalidator.register ~protocols ; Protocol_limits.register ~protocols:[Alpha] ; @@ -115,6 +114,7 @@ let register_protocol_agnostic_tests () = Replace_by_fees.register ~protocols ; Rpc_config_logging.register ~protocols:[Alpha] ; RPC_test.register protocols ; + Run_operation_RPC.register ~protocols ; Runtime_script_failure.register ~protocols ; Signer_test.register ~protocols:[Alpha] ; Stresstest_command.register ~protocols:[Alpha] ; @@ -141,6 +141,7 @@ let register_K_plus_tests () = Events.register ~protocols:[Alpha] ; Ghostnet_dictator_migration.register ~protocols:[Alpha] ; Increase_paid_storage.register ~protocols ; + Operation_validation.register ~protocols ; Sc_rollup.register ~protocols:[Alpha] ; Test_contract_bls12_381.register ~protocols:[Alpha] ; Testnet_dictator.register ~protocols:[Alpha] ; diff --git a/tezt/tests/op_validation.ml b/tezt/tests/op_validation.ml deleted file mode 100644 index e53125b6246a7ceb068855f887189f5c4ce357f4..0000000000000000000000000000000000000000 --- a/tezt/tests/op_validation.ml +++ /dev/null @@ -1,116 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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: Validation components - Invocation: dune exec tezt/tests/main.exe -- --file "op_validation.ml" - Subject: Checks the validation of operations -*) - -let check_run_operation_illformed_batch ~supports check_answer = - Protocol.register_test - ~__FILE__ - ~supports - ~title:"Run_operation ill-formed batch" - ~tags:["rpc"; "run_operation"; "batch"] - @@ fun protocol -> - Log.info "Initialize a node and a client." ; - let* node, client = - Client.init_with_protocol - ~nodes_args:[Synchronisation_threshold 0] - ~protocol - `Client - () - in - - Log.info - "Do a transfer from %s and bake to increment its counter." - Constant.bootstrap2.alias ; - let* _ = - Client.transfer - ~amount:Tez.one - ~giver:Constant.bootstrap2.alias - ~receiver:Constant.bootstrap3.alias - client - in - let* _ = Client.bake_for_and_wait ~protocol ~node client in - - Log.info "Create a first operation." ; - let source1 = Constant.bootstrap1 in - let dest = Constant.bootstrap3 in - let op1 = Operation.Manager.(make ~source:source1 @@ transfer ~dest ()) in - let* op1_json = Operation.Manager.json client op1 in - - Log.info - "Create a second operation with a different source and an incremented \ - counter." ; - let source2 = Constant.bootstrap2 in - let* counter = Operation.get_next_counter ~source:source2 client in - let op2 = - Operation.Manager.(make ~source:source2 ~counter @@ transfer ~dest ()) - in - let* op2_json = Operation.Manager.json client op2 in - - Log.info "Craft a batch in JSON that contains both operations." ; - let* branch = Operation.get_injection_branch client in - let signature = Tezos_crypto.Signature.zero in - let* chain_id = RPC.Client.call client @@ RPC.get_chain_chain_id () in - let batch = - Format.asprintf - {|{ "operation": - {"branch": "%s", - "contents": [%s,%s], - "signature": "%a" }, - "chain_id": %s }|} - branch - (Ezjsonm.value_to_string op1_json) - (Ezjsonm.value_to_string op2_json) - Tezos_crypto.Signature.pp - signature - (JSON.encode_u (`String chain_id)) - in - - Log.info "Call the [run_operation] RPC with this JSON batch." ; - let*? p = - RPC.Client.spawn client - @@ RPC.post_run_operation (Ezjsonm.from_string batch) - in - check_answer p - -(** This test checks that the [run_operation] RPC used to allow - batches of manager operations containing different sources in - protocol versions before 14, but rejects them from 14 on. *) -let check_run_operation_illformed_batch ~protocols = - check_run_operation_illformed_batch - ~supports:(Protocol.Until_protocol 13) - (Process.check ~expect_failure:false) - protocols ; - check_run_operation_illformed_batch - ~supports:(Protocol.From_protocol 14) - (Process.check ~expect_failure:true) - protocols - -let register ~protocols = check_run_operation_illformed_batch ~protocols diff --git a/tezt/tests/operation_validation.ml b/tezt/tests/operation_validation.ml new file mode 100644 index 0000000000000000000000000000000000000000..df517667562490b686f196a9c72db22aff828290 --- /dev/null +++ b/tezt/tests/operation_validation.ml @@ -0,0 +1,89 @@ +(*****************************************************************************) +(* *) +(* 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: Validation components + Invocation: dune exec tezt/tests/main.exe -- --file "op_validation.ml" + Subject: Checks the validation of operations +*) + +(** This test checks that from `Kathmandu`, the 1M restriction is + checked with and without the precheck manager operation enable in + the plugin's node. *) +let check_validate_1m_restriction_node = + Protocol.register_test + ~__FILE__ + ~supports:(Protocol.From_protocol 14) + ~title:"Check 1M restriction with and without precheck in the plugin" + ~tags:["1m"; "manager"; "plugin"; "restriction"] + @@ fun protocol -> + let inject_two_manager_operations_and_check_error ~disable_operations_precheck + error = + Log.info + "Initialize a client %s operation precheck in the plugin." + (if disable_operations_precheck then "without" else "with") ; + let* _node, client = + Client.init_with_protocol + ~nodes_args: + ((if disable_operations_precheck then + [Node.Disable_operations_precheck] + else []) + @ [Synchronisation_threshold 0]) + ~protocol + `Client + () + in + + Log.info "Inject a first transfer." ; + let op1 = + Operation.Manager.make (Operation.Manager.transfer ~amount:1 ()) + in + let* (`OpHash _s) = Operation.Manager.inject [op1] client in + + Log.info + "Inject a second transfer with the same manager and check that the \ + injection fails with the following message:\n\ + %s" + (show_rex error) ; + let op2 = + Operation.Manager.make (Operation.Manager.transfer ~amount:2 ()) + in + let* (`OpHash _) = + Operation.Manager.inject ~error ~request:`Inject [op2] client + in + unit + in + + let* () = + inject_two_manager_operations_and_check_error + ~disable_operations_precheck:false + (rex "Only one manager operation per manager per block allowed") + in + inject_two_manager_operations_and_check_error + ~disable_operations_precheck:true + (rex "Manager.*already has the operation.*in the current block.") + +let register ~protocols = check_validate_1m_restriction_node protocols diff --git a/tezt/tests/prevalidator.ml b/tezt/tests/prevalidator.ml index 3f9776cb0d47ae0027cb2db66536a1ee5b610d5e..dac727b62a45da72bc03e4346867ae34756d36cd 100644 --- a/tezt/tests/prevalidator.ml +++ b/tezt/tests/prevalidator.ml @@ -35,8 +35,6 @@ Some refactorisation is needed. All new tests should be in the Revamped module (which will be erased once we have rewrote all the Legacy tests. *) -module Mempool = Tezt_tezos.Mempool - module Revamped = struct let log_step counter msg = let color = Log.Color.(bold ++ FG.blue) in @@ -112,26 +110,23 @@ module Revamped = struct let* _ = RPC.mempool_request_operations client in mempool_notify_waiter - let check_mempool ?(applied = []) ?(branch_delayed = []) - ?(branch_refused = []) ?(refused = []) ?(outdated = []) - ?(unprocessed = []) client = + (* Call the [/chains/[chain]/mempool/pending_operations] RPC and + check that in the returned mempool, each field [applied], + [branch_delayed], etc. contains exactly the operation hashes + listed in the argument of the same name. Omitted arguments + default to the empty list. *) + let check_mempool ?applied ?branch_delayed ?branch_refused ?refused ?outdated + ?unprocessed client = let* mempool = Mempool.get_mempool client in - let expected_mempool = - Mempool. - { - applied; - branch_delayed; - branch_refused; - refused; - outdated; - unprocessed; - } - in - Check.( - (expected_mempool = mempool) - Mempool.classified_typ - ~error_msg:"Expected mempool %L, got %R") ; - unit + return + (Mempool.check_mempool + ?applied + ?branch_delayed + ?branch_refused + ?refused + ?outdated + ?unprocessed + mempool) (** {2 Tests } *) @@ -1984,13 +1979,58 @@ module Revamped = struct inject_operations ~force:true [List.nth ops 0; List.nth ops 4] client) in let injected_ops2 = List.map (fun (`OpHash op) -> op) injected_ops2 in - let* () = - check_mempool - ~applied:((List.nth injected_ops2 1 :: injected_ops) @ mempool.applied) - ~branch_refused:[List.nth injected_ops2 0] - client + check_mempool + ~applied:((List.nth injected_ops2 1 :: injected_ops) @ mempool.applied) + ~branch_refused:[List.nth injected_ops2 0] + client + + (** This test injects a well-formed batch of manager operations and + checks that it is [applied] in the mempool. *) + let test_inject_manager_batch = + Protocol.register_test + ~__FILE__ + ~title:"Inject manager batch" + ~tags:["mempool"; "manager"; "batch"; "injection"; "applied"] + @@ fun protocol -> + log_step 1 "Initialize a node and a client." ; + let* _node, client = + Client.init_with_protocol + ~nodes_args:[Synchronisation_threshold 0] + ~protocol + `Client + () + in + + let n_transactions = 3 in + log_step 2 "Inject a well-formed batch of %d transactions." n_transactions ; + let* (`OpHash oph) = + let payload = Operation.Manager.transfer ~dest:Constant.bootstrap2 () in + let source = Constant.bootstrap1 in + let* counter = Operation.Manager.get_next_counter ~source client in + let batch = + Operation.Manager.make_batch + ~source + ~counter + (List.init n_transactions (fun _ -> payload)) + in + Operation.Manager.inject batch client in + log_step 3 "Check that the batch is correctly [applied] in the mempool." ; + let* mempool_json = RPC.get_mempool_pending_operations client in + let mempool = Mempool.of_json mempool_json in + Mempool.check_mempool ~applied:[oph] mempool ; + Log.info + "The mempool contains exactly one [applied] operation with the correct \ + hash." ; + let batch_payloads = + JSON.(mempool_json |-> "applied" |=> 0 |-> "contents" |> as_list) + in + Check.( + (List.compare_length_with batch_payloads n_transactions = 0) + int + ~error_msg:"The [applied] batch has a wrong number of manager payloads.") ; + Log.info "The [applied] batch as the correct number of manager payloads." ; unit end @@ -2167,170 +2207,9 @@ let forge_and_inject_operation ~branch ~fee ~gas_limit ~source ~destination let signature = Operation.sign_manager_op_hex ~signer op_str_hex in inject_operation ~client op_str_hex signature -let forge_and_inject_n_operations ~branch ~fee ~gas_limit ~source ~destination - ~counter ~signer ~client ~node n = - let rec loop ((oph_list, counter) as acc) = function - | 0 -> return acc - | n -> - let transfer_1 = wait_for_injection node in - let* oph = - forge_and_inject_operation - ~branch - ~fee - ~gas_limit - ~source - ~destination - ~counter - ~signer - ~client - in - let* () = transfer_1 in - let oph_list = oph :: oph_list in - loop (oph_list, counter + 1) (pred n) - in - loop ([], counter + 1) n - -(** Bakes with an empty mempool to force synchronisation between nodes. *) -let bake_empty_block ?endpoint ~protocol client = - let mempool = Client.empty_mempool_file () in - Client.bake_for_and_wait ~protocol ?endpoint ~mempool client - -(** [bake_empty_mempool_and_wait_for_flush client node] bakes for [client] - with an empty mempool, then waits for a [flush] event on [node] (which - will usually be the node corresponding to [client], but could be any - node with a connection path to it). *) -let _bake_empty_block_and_wait_for_flush ?(log = false) ~protocol client node = - let waiter = wait_for_flush node in - let* () = bake_empty_block ~protocol client in - if log then - Log.info "Baked for %s with an empty mempool." (Client.name client) ; - waiter - (* TODO: add a test than ensure that we cannot have more than 1000 branch delayed/branch refused/refused *) -let forge_run_and_inject_n_batched_operation n ~branch ~fee ~gas_limit ~source - ~destination ~counter ~signer ~client = - let ops_json = - String.concat ", " - @@ List.map - (fun counter -> - operation_json ~fee ~gas_limit ~source ~destination ~counter) - (range (counter + 1) (counter + n)) - in - let op_json_branch = operation_json_branch ~branch ops_json in - let* op_hex = - RPC.post_forge_operations ~data:(Ezjsonm.from_string op_json_branch) client - in - let op_str_hex = JSON.as_string op_hex in - let signature = - Operation.sign_manager_op_bytes ~signer (Hex.to_bytes (`Hex op_str_hex)) - in - let* _run = - let* chain_id = RPC.Client.call client @@ RPC.get_chain_chain_id () in - let op_runnable = - (* Please don't do that. Build [JSON.u] values and use [JSON.encode_u]. *) - Format.asprintf - {|{ "operation": - {"branch": "%s", - "contents": [ %s ], - "signature": "%a" }, - "chain_id": %s }|} - branch - ops_json - Tezos_crypto.Signature.pp - signature - (JSON.encode_u (`String chain_id)) - in - RPC.Client.call client - @@ RPC.post_run_operation (Ezjsonm.from_string op_runnable) - in - let (`Hex signature) = Tezos_crypto.Signature.to_hex signature in - let signed_op = op_str_hex ^ signature in - RPC.Client.call client @@ RPC.post_injection_operation (`String signed_op) - -let check_batch_operations_are_in_applied_mempool ops oph n = - let open JSON in - let ops_list = as_list (ops |-> "applied") in - let res = - List.exists - (fun e -> - let contents = as_list (e |-> "contents") in - let h = as_string (e |-> "hash") in - List.compare_length_with contents n = 0 && h = as_string oph) - ops_list - in - if not res then - Test.fail - "Batch Operation %s was not found in the mempool or it does not contain \ - %d operations" - (JSON.encode oph) - n - -(** This test tries to run manually forged operations before injecting them - - Scenario: - - + Node 1 activates a protocol - - + Retrieve the counter and the branch for bootstrap1 - - + Forge, run and inject operations in the node - - + Check that the batch is correctly injected - *) -let run_batched_operation = - Protocol.register_test - ~__FILE__ - ~title:"Run batched operations before injecting them" - ~tags:["forge"; "mempool"; "batch"; "run_operation"] - @@ fun protocol -> - (* Step 1 *) - (* A Node is started and we activate the protocol and wait for the node to be synced *) - let* node_1 = Node.init [Synchronisation_threshold 0] in - let* client_1 = Client.init ~endpoint:(Node node_1) () in - let* () = Client.activate_protocol ~protocol client_1 in - Log.info "Activated protocol." ; - let* _ = Node.wait_for_level node_1 1 in - Log.info "Node is at level %d." 1 ; - (* Step 2 *) - (* Get the counter and the current branch *) - let*! counter = - RPC.Contracts.get_counter - ~contract_id:Constant.bootstrap1.public_key_hash - client_1 - in - let counter = JSON.as_int counter in - let* branch = RPC.get_branch client_1 in - let branch = JSON.as_string branch in - (* Step 3 *) - (* Forge operations, run and inject them *) - let number_of_transactions = 3 in - let* oph = - forge_run_and_inject_n_batched_operation - number_of_transactions - ~branch - ~fee:1000 (* Minimal fees to successfully apply the transfer *) - ~gas_limit:1040 (* Minimal gas to successfully apply the transfer *) - ~source:Constant.bootstrap2.public_key_hash - ~destination:Constant.bootstrap1.public_key_hash - ~counter - ~signer:Constant.bootstrap2 - ~client:client_1 - in - Log.info "Operations forged, signed, run and injected" ; - (* Step 4 *) - (* Check that the batch is correctly injected *) - let* mempool_after_batch = RPC.get_mempool_pending_operations client_1 in - check_batch_operations_are_in_applied_mempool - mempool_after_batch - oph - number_of_transactions ; - Log.info - "%d operations are applied as a batch in the mempool" - number_of_transactions ; - unit - let check_if_op_is_in_mempool client ~classification oph = let* ops = RPC.get_mempool_pending_operations ~version:"1" client in let open JSON in @@ -4156,7 +4035,7 @@ let register ~protocols = Revamped.precheck_with_empty_balance [Protocol.Ithaca] (* FIXME: handle the case for Alpha. *) ; Revamped.inject_operations protocols ; - run_batched_operation protocols ; + Revamped.test_inject_manager_batch protocols ; propagation_future_endorsement protocols ; forge_pre_filtered_operation protocols ; refetch_failed_operation protocols ; diff --git a/tezt/tests/reject_malformed_micheline.ml b/tezt/tests/reject_malformed_micheline.ml index 0a4c7596deb6fcaf7f0f4701408a59adb62615af..b1e10669df5481798c9319127ee966ce1974f29b 100644 --- a/tezt/tests/reject_malformed_micheline.ml +++ b/tezt/tests/reject_malformed_micheline.ml @@ -64,26 +64,26 @@ let make_data s = to an RPC endpoint. *) let reject_malformed_micheline = - Protocol.register_test ~__FILE__ ~title:"Reject malformed micheline" ~tags:[] + Protocol.register_test + ~__FILE__ + ~title:"Reject malformed micheline" + ~tags: + [ + "micheline"; + "empty_implicit_contract"; + "malformed_annotation"; + "run_operation"; + ] @@ fun protocol -> let* node, _client = Client.init_with_protocol `Client ~protocol () in let send_operation data = - (* This RPC path is used because it doesn't require valid signatures. *) - let rpc_path = - sf - "http://localhost:%d/chains/main/blocks/head/helpers/scripts/run_operation" - @@ Node.rpc_port node + (* The [run_operation] RPC is used because it doesn't require + valid signatures. *) + let json = Ezjsonm.from_string data in + let* response = + RPC.(call_raw node (post_chain_block_helpers_scripts_run_operation json)) in - let proc_malformed_annots = - (* We cannot use the client to test the injection of malformed - annotations. This is because the client will reject the invalid - annotations and will not propagate the malformed data to the server. - Instead we have to use RPCs directly. Hence [curl]. *) - Process.spawn - "curl" - ["-H"; "Content-type: application/json"; "-d"; data; rpc_path] - in - Process.check_and_read_stdout proc_malformed_annots + return response.body in (* We send a valid annotation. *) let* output = send_operation @@ make_data "\"%test\"" in diff --git a/tezt/tests/run_operation_RPC.ml b/tezt/tests/run_operation_RPC.ml new file mode 100644 index 0000000000000000000000000000000000000000..7da94c8f5cfcf811a091823f415e18cbb23cc5fb --- /dev/null +++ b/tezt/tests/run_operation_RPC.ml @@ -0,0 +1,546 @@ +(*****************************************************************************) +(* *) +(* 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: Protocol's plugin + Invocation: dune exec tezt/tests/main.exe -- --file "run_operation_RPC.ml" + Subject: Test the [run_operation] RPC: + [POST /chains//blocks//helpers/scripts/run_operation]. + These tests focus on the semantics of the RPC, ie. whether + the operation is successfully run, rather than on the exact + form of the output, which is why they are in their own file + instead of [RPC_test.ml]. +*) + +(** Tags shared by all tests in this file. *) +let run_operation_tags = ["rpc"; "run_operation"] + +(** Check that the RPC [response]'s code is [500] (Internal Server + Error), and that its body has an "id" field that ends in + [expected_proto_error]. *) +let check_response_contains_proto_error ~expected_proto_error + (response : JSON.t RPC.response) = + Log.info + "Checking RPC response:\n code: %s\n body: %s" + Cohttp.Code.(string_of_status (status_of_code response.code)) + (JSON.encode response.body) ; + Check.( + (response.code = 500) + int + ~error_msg:"Expected response code %R, but got %L.") ; + let response_proto_error = + try + let id = JSON.(response.body |=> 0 |-> "id" |> as_string) in + List.(hd (rev (String.split_on_char '.' id))) + with exn -> + Test.fail + "Failed to parse the following RPC response body:\n\ + %s.\n\ + The following exception was raised:\n\ + %s" + (JSON.encode response.body) + (Printexc.to_string exn) + in + Check.( + (response_proto_error = expected_proto_error) + string + ~error_msg:"Expected the %R protocol error, but got %L.") + +(** Craft a batch that contains the given individual manager + operation(s), call the [run_operation] RPC on it, and call + {!check_response_contains_proto_error} and the RPC response. *) +let run_manager_operations_and_check_proto_error ~expected_proto_error + (manager_operations : Operation_core.Manager.t list) node client = + let* op = Operation.Manager.operation manager_operations client in + let* op_json = Operation.make_run_operation_input op client in + Log.debug + "Crafted operation: %s" + (Ezjsonm.value_to_string ~minify:false op_json) ; + let* response = + RPC.( + call_json node (post_chain_block_helpers_scripts_run_operation op_json)) + in + check_response_contains_proto_error ~expected_proto_error response ; + unit + +(** This test checks that the [run_operation] RPC used to allow + batches of manager operations containing different sources in + protocol versions before Kathmandu (014), but rejects them from + Kathmandu on. *) +let test_batch_inconsistent_sources protocols = + let register_inconsistent_sources ~supports ~title + call_run_operation_and_check_response = + Protocol.register_test + ~__FILE__ + ~supports + ~title + ~tags:(run_operation_tags @ ["manager"; "batch"; "inconsistent_sources"]) + (fun protocol -> + Log.info "Initialize a node and a client." ; + let* node, client = + Client.init_with_protocol + ~nodes_args:[Synchronisation_threshold 0] + ~protocol + `Client + () + in + let source1 = Constant.bootstrap1 + and source2 = Constant.bootstrap2 + and dest = Constant.bootstrap3 in + Log.info + "Increment [%s]'s counter so that the batch we craft below has \ + consistent counters. To do this, we inject a transaction from this \ + account and bake a block." + source2.alias ; + let* () = + Client.transfer + ~amount:Tez.one + ~giver:source2.alias + ~receiver:dest.alias + client + in + let* () = Client.bake_for_and_wait ~protocol ~node client in + Log.info + "Craft a batch containing an operation from [%s] and an operation \ + from [%s]." + source1.alias + source2.alias ; + let manager_op1 = + Operation.Manager.(make ~source:source1 (transfer ~dest ())) + in + let manager_op2 = + Operation.Manager.(make ~source:source2 (transfer ~dest ())) + in + let* batch = + Operation.Manager.operation [manager_op1; manager_op2] client + in + let* batch_json = Operation.make_run_operation_input batch client in + Log.info + "Crafted batch: %s" + (Ezjsonm.value_to_string ~minify:false batch_json) ; + call_run_operation_and_check_response node batch_json) + in + register_inconsistent_sources + ~supports:Protocol.(Until_protocol (number Jakarta)) + ~title:"Run_operation inconsistent sources ok" + (fun node batch_json -> + Log.info + "Call the [run_operation] RPC on this batch and check that it succeeds." ; + let* _run_operation_output = + RPC.( + call node (post_chain_block_helpers_scripts_run_operation batch_json)) + in + unit) + protocols ; + register_inconsistent_sources + ~supports:(Protocol.From_protocol 014) + ~title:"Run_operation inconsistent sources ko" + (fun node batch_json -> + let expected_proto_error = "inconsistent_sources" in + Log.info + "Call the [run_operation] RPC on this batch, and check that it fails \ + with code [500] (Internal Server Error) and protocol error [%s]." + expected_proto_error ; + let* response = + RPC.call_json + node + (RPC.post_chain_block_helpers_scripts_run_operation batch_json) + in + check_response_contains_proto_error ~expected_proto_error response ; + unit) + protocols + +(** This test calls the [run_operation] RPC on various operations with + unexpected or inconsistent counters, and checks that the + appropriate protocol error is returned. *) +let test_inconsistent_counters = + Protocol.register_test + ~__FILE__ + ~supports:Protocol.(From_protocol 013) + ~title:"Run_operation inconsistent counters" + ~tags: + (run_operation_tags + @ [ + "manager"; + "batch"; + "counter"; + "counter_in_the_past"; + "counter_in_the_future"; + "inconsistent_counters"; + ]) + (fun protocol -> + Log.info "Initialize a node and a client." ; + let* node, client = + Client.init_with_protocol + ~nodes_args:[Synchronisation_threshold 0] + ~protocol + `Client + () + in + let run_manager_operations_and_check_proto_error ~expected_proto_error + manager_ops = + run_manager_operations_and_check_proto_error + ~expected_proto_error + manager_ops + node + client + in + let source = Constant.bootstrap1 in + let* next_counter = Operation.Manager.get_next_counter ~source client in + Log.info + "All the operations in this test will be from %s. The expected counter \ + for the next manager operation from this source is %d." + source.alias + next_counter ; + let current_counter = next_counter - 1 in + Log.info + "Call [run_operation] on a transaction with counter %d." + current_counter ; + let* () = + let transaction = + Operation.Manager.( + make ~source ~counter:current_counter (transfer ())) + in + run_manager_operations_and_check_proto_error + ~expected_proto_error:"counter_in_the_past" + [transaction] + in + let next_plus_one = next_counter + 1 in + Log.info + "Call [run_operation] on a transaction with counter %d." + next_plus_one ; + let* () = + let transaction = + Operation.Manager.(make ~source ~counter:next_plus_one (transfer ())) + in + run_manager_operations_and_check_proto_error + ~expected_proto_error:"counter_in_the_future" + [transaction] + in + Log.info + "Call [run_operation] on a batch where the first operation has the \ + expected counter %d, but the second operation also has the same \ + counter %d." + next_counter + next_counter ; + let transaction_next_counter = + Operation.Manager.( + make + ~source + ~counter:next_counter + (transfer ~dest:Constant.bootstrap2 ())) + in + let* () = + run_manager_operations_and_check_proto_error + ~expected_proto_error:"inconsistent_counters" + [transaction_next_counter; transaction_next_counter] + in + let next_plus_two = next_counter + 2 in + Log.info + "Call [run_operation] on a batch where the first operation has the \ + expected counter %d, but the second operation has the counter %d." + next_counter + next_plus_two ; + let transaction2 = + Operation.Manager.( + make + ~source + ~counter:next_plus_two + (transfer ~dest:Constant.bootstrap2 ())) + in + run_manager_operations_and_check_proto_error + ~expected_proto_error:"inconsistent_counters" + [transaction_next_counter; transaction2]) + +(** This test calls the [run_operation] RPC on various faulty + revelations. + + This test only supports protocol versions from Kathmandu (014) on, + because of changes to the revelation semantic introduced in this + protocol. *) +let test_bad_revelations = + Protocol.register_test + ~__FILE__ + ~supports:(Protocol.From_protocol 014) + ~title:"Run_operation bad revelations" + ~tags:(run_operation_tags @ ["manager"; "reveal"; "bad_revelations"]) + @@ fun protocol -> + Log.info "Initialize a node and a client." ; + let* node, client = + Client.init_with_protocol + ~nodes_args:[Synchronisation_threshold 0] + ~protocol + `Client + () + in + Log.info + "Create a fresh account: generate a key, inject a transaction that funds \ + it, and bake a block to apply the transaction." ; + let* fresh_account = Client.gen_and_show_keys client in + let* _oph = + Operation.inject_transfer + client + ~source:Constant.bootstrap2 + ~dest:fresh_account + ~gas_limit:1500 + ~amount:10_000_000 + in + let* () = Client.bake_for_and_wait ~node client in + let* fresh_account_next_counter = + Operation.Manager.get_next_counter ~source:fresh_account client + in + let incorrect_reveal_position_error = "incorrect_reveal_position" in + Log.info + "Call [run_operation] on a batch with a reveal in 2nd position, and check \ + that it returns the [%s] protocol error." + incorrect_reveal_position_error ; + let* () = + let* op = + let transaction_payload = Operation.Manager.transfer () in + let reveal_payload = Operation.Manager.reveal fresh_account in + Operation.Manager.( + operation + (make_batch + ~source:fresh_account + ~counter:fresh_account_next_counter + [transaction_payload; reveal_payload]) + client) + in + let* op_json = Operation.make_run_operation_input op client in + let* response = + RPC.( + call_json node (post_chain_block_helpers_scripts_run_operation op_json)) + in + check_response_contains_proto_error + ~expected_proto_error:incorrect_reveal_position_error + response ; + unit + in + let inconsistent_hash_error = "inconsistent_hash" in + Log.info + "Call [run_operation] on a revelation of a public key that is not \ + consistent with the source's public key hash, and check that it returns \ + the [%s] protocol error." + inconsistent_hash_error ; + let* () = + let reveal_manager_op = + Operation.Manager.( + make ~source:fresh_account (reveal Constant.bootstrap1)) + in + let* op = Operation.Manager.operation [reveal_manager_op] client in + let* op_json = Operation.make_run_operation_input op client in + let* response = + RPC.( + call_json node (post_chain_block_helpers_scripts_run_operation op_json)) + in + check_response_contains_proto_error + ~expected_proto_error:inconsistent_hash_error + response ; + unit + in + let previously_revealed_error = "previously_revealed_key" in + Log.info + "Call [run_operation] on a revelation of an already revealed key. Check \ + that the call succeeds, but the returned metadata indicate that the \ + operation's application has failed with the [%s] protocol error." + previously_revealed_error ; + let* () = + let source = Constant.bootstrap1 (* this source is already revealed *) in + let manager_op = Operation.Manager.(make ~source (reveal source)) in + let* op = Operation.Manager.operation [manager_op] client in + let* op_json = Operation.make_run_operation_input op client in + let* output = + RPC.call node (RPC.post_chain_block_helpers_scripts_run_operation op_json) + in + let operation_result = + JSON.(output |-> "contents" |=> 0 |-> "metadata" |-> "operation_result") + in + Log.info + "Checking metadata.operation_result: %s" + (JSON.encode operation_result) ; + Check.( + (JSON.(operation_result |-> "status" |> as_string) = "failed") + string + ~error_msg:"Expected operation_result status to be %R, but got %L.") ; + let id = JSON.(operation_result |-> "errors" |=> 0 |-> "id" |> as_string) in + let proto_error = + try List.(hd (rev (String.split_on_char '.' id))) + with exn -> + Test.fail + "Failed to extract proto_error from %s:\n%s" + id + (Printexc.to_string exn) + in + Check.( + (proto_error = previously_revealed_error) + string + ~error_msg:"Expected protocol error %R, but got %L.") ; + unit + in + unit + +(** This test checks that the [run_operation] RPC succeeds on a + well-formed batch containing a transaction, a delegation, and a + second transaction. *) +let test_correct_batch = + Protocol.register_test + ~__FILE__ + ~title:"Run_operation correct batch" + ~tags: + (run_operation_tags + @ ["manager"; "batch"; "transaction"; "delegation"; "correct_batch"]) + @@ fun protocol -> + Log.info "Initialize a node and a client." ; + let* node, client = + Client.init_with_protocol + ~nodes_args:[Synchronisation_threshold 0] + ~protocol + `Client + () + in + Log.info + "Craft a batch containing: a transaction, a delegation, and a second \ + transaction." ; + let* batch = + let source = Constant.bootstrap1 in + let* counter = Operation.Manager.get_next_counter ~source client in + let transaction1_payload = + Operation.Manager.transfer ~dest:Constant.bootstrap2 () + in + let delegation_payload = + Operation.Manager.delegation ~delegate:Constant.bootstrap3 () + in + let transaction2_payload = + Operation.Manager.transfer ~dest:Constant.bootstrap4 () + in + Operation.Manager.( + operation + (make_batch + ~source + ~counter + [transaction1_payload; delegation_payload; transaction2_payload]) + client) + in + let* batch_json = Operation.make_run_operation_input batch client in + Log.info + "Crafted batch: %s" + (Ezjsonm.value_to_string ~minify:false batch_json) ; + Log.info "Call the [run_operation] RPC on the batch." ; + let* _output = + RPC.(call node (post_chain_block_helpers_scripts_run_operation batch_json)) + in + unit + +(** This test creates a fresh account and calls the [run_operation] + RPC on the revelation of its public key. Then it actually injects + this revelation, and calls [run_operation] on a some other manager + operations from this fresh account. *) +let test_misc_manager_ops_from_fresh_account = + Protocol.register_test + ~__FILE__ + ~title:"Run_operation misc manager ops from fresh account" + ~tags: + (run_operation_tags + @ ["fresh_account"; "manager"; "reveal"; "transaction"; "delegation"]) + @@ fun protocol -> + Log.info "Initialize a node and a client." ; + let* node, client = + Client.init_with_protocol + ~nodes_args:[Synchronisation_threshold 0] + ~protocol + `Client + () + in + let amount = 10_000_000 (* amount of the final transaction (in mutez) *) in + Log.info + "Create a fresh account by giving it [2 x amount] mutez, then baking a \ + block to apply the transaction." ; + let* fresh_account = Client.gen_and_show_keys client in + let* _oph = + Operation.inject_transfer + client + ~source:Constant.bootstrap2 + ~dest:fresh_account + ~gas_limit:1500 + ~amount:(2 * amount) + in + let* () = Client.bake_for_and_wait ~node client in + Log.info + "Craft a revelation of the fresh account's key and call the \ + [run_operation] RPC on it." ; + let* reveal_op = + let manager_op = + Operation.Manager.(make ~source:fresh_account (reveal fresh_account)) + in + Operation.Manager.operation [manager_op] client + in + let* _run_operation_output = + let* op_json = Operation.make_run_operation_input reveal_op client in + RPC.(call node (post_chain_block_helpers_scripts_run_operation op_json)) + in + Log.info "Inject the crafted revelation and bake a block to apply it." ; + let* _oph = Operation.inject reveal_op client in + let* () = Client.bake_for_and_wait ~node client in + Log.info + "Craft a transaction (of [amount] mutez) from the fresh account and call \ + the [run_operation] RPC on it." ; + let* () = + let manager_op = + Operation.Manager.( + make + ~source:fresh_account + (transfer ~dest:Constant.bootstrap1 ~amount ())) + in + let* op = Operation.Manager.operation [manager_op] client in + let* op_json = Operation.make_run_operation_input op client in + let* _output = + RPC.(call node (post_chain_block_helpers_scripts_run_operation op_json)) + in + unit + in + Log.info + "Craft a delegation from the fresh account and call the [run_operation] \ + RPC on it." ; + let* () = + let manager_op = + Operation.Manager.( + make ~source:fresh_account (delegation ~delegate:Constant.bootstrap1 ())) + in + let* op = Operation.Manager.operation [manager_op] client in + let* op_json = Operation.make_run_operation_input op client in + let* _output = + RPC.(call node (post_chain_block_helpers_scripts_run_operation op_json)) + in + unit + in + unit + +let register ~protocols = + test_batch_inconsistent_sources protocols ; + test_inconsistent_counters protocols ; + test_bad_revelations protocols ; + test_correct_batch protocols ; + test_misc_manager_ops_from_fresh_account protocols diff --git a/tezt/tests/run_script.ml b/tezt/tests/run_script.ml index 8b8ae4273b10254ef632013241f56a0f9c02d133..807b6fe5348e1aae89dd4aabae6c2ea572954f59 100644 --- a/tezt/tests/run_script.ml +++ b/tezt/tests/run_script.ml @@ -148,13 +148,21 @@ let test_source_and_sender ~protocol () = let* bootstrap1 = Client.show_address ~alias:"bootstrap1" client in let* bootstrap2 = Client.show_address ~alias:"bootstrap2" client in - (* When --payer is absent, --source sets *both* SENDER and SOURCE. *) + (* When --payer is absent, --source sets: + - *both* SENDER and SOURCE (until Kathmandu); + - SENDER, but SOURCE is the zero address (since L). *) + let expected_source = + match protocol with + | Ithaca | Jakarta | Kathmandu -> + Format.sprintf "%S" bootstrap1.public_key_hash + | Alpha -> "0x00000000000000000000000000000000000000000000" + in let* _storage = Client.run_script ~source:"bootstrap1" ~prg:check_source ~storage:"Unit" - ~input:(Format.sprintf "%S" bootstrap1.public_key_hash) + ~input:expected_source client in let* _storage =