diff --git a/docs/developer/flextesa.rst b/docs/developer/flextesa.rst index 4d6ca9f74aa2376b6171d77c972830707f2e8e12..3dbbedc2a71ede8411f644974e11e44c2acf6d40 100644 --- a/docs/developer/flextesa.rst +++ b/docs/developer/flextesa.rst @@ -18,8 +18,7 @@ There are testing-only ``opam`` dependencies: ``dum`` and ``genspio`` Usage ----- -See ``./tezos-sandbox --help`` (or one can use -``_build/default/src/bin_flextesa/main.exe``). +See ``./tezos-sandbox --help``. When running (semi-)interactive tests, it is recommended to wrap the call with ``rlwrap`` or ``ledit``. @@ -37,11 +36,11 @@ endorsers: rlwrap ./tezos-sandbox mini-network \ --root-path /tmp/zz-mininet-test \ - --tezos-node-binary _build/default/src/bin_node/main.exe \ - --tezos-baker-alpha-binary _build/default/src/proto_alpha/bin_baker/main_baker_alpha.exe \ - --tezos-endorser-alpha-binary _build/default/src/proto_alpha/bin_endorser/main_endorser_alpha.exe \ - --tezos-accuser-alpha-binary _build/default/src/proto_alpha/bin_accuser/main_accuser_alpha.exe \ - --tezos-client-binary _build/default/src/bin_client/main_client.exe + --tezos-node-binary ./tezos-node \ + --tezos-baker-alpha-binary ./tezos-baker-alpha \ + --tezos-endorser-alpha-binary ./tezos-endorser-alpha \ + --tezos-accuser-alpha-binary ./tezos-accuser-alpha \ + --tezos-client-binary ./tezos-client Once the network is started this test scenario becomes interactive: @@ -72,35 +71,35 @@ sandbox before killing all the nodes. --pause-at-end=true -This test among other ones can run +This test among other ones can generate configuration files for `Kiln `__ -alongside the *Ꜩ-sandbox*, for instance: - -:: - - rlwrap ./tezos-sandbox accusations simple-double-endorsing --with-kiln - -See also the options ``--kiln-*`` for configuration, and the option -``--starting-level`` (since Kiln assumes a long-running blockchain -adding more, e.g. 40, bakes at the beginning of the test brings us to a -more “normal” state). +to run alongside the *Ꜩ-sandbox*, for instance: Voting With a Ledger Nano S ~~~~~~~~~~~~~~~~~~~~~~~~~~~ - **Note:** this requires a ``tezos-client`` with the changes from - https://gitlab.com/tezos/tezos/merge_requests/848. +The voting test tries to do a full round of voting and protocol switch, +including baking on the test-chain, see documentation in +``./tezos-sandbox voting --help``. -The voting test for now goes up to the last block before the protocol is -supposed to change to the election winner (see also -``./tezos-sandbox voting --help``). +The test can run in a simpler-to-setup, or “degraded,” mode of operation +(cf. call in ``./src/bin_flextesa/dune`` for the version which +run in Gitlab-CI pipelines). In this example, we run instead a full test +with a Ledger Nano S as one of the bakers/voters. The test automatically +becomes **interactive** because the user has to press buttons on the +device, including for changing between apps. -The test can use a Ledger Nano S as one of the voters (the test -automatically becomes **interactive** then because the user has to press -buttons on the device). +To make the test work, you need to provide it with a ``tezos-client`` +which knows about the protocol which is tested and then wins the voting +period. -Get an URI for your ledger (the test requires both the Wallet and Baking -apps): +One example is this branch: +```obsidian.systems/tezos#zeronet-with-proto042`` `__ +which allows one to build an Apr2019-Zeronet-like code base with an extra +protocol, lets assume this is built at path ``$zeronet_042``. + +Also, get an URI for your ledger (the test requires both the Wallet and +Baking apps): :: @@ -110,27 +109,41 @@ And use the URI (no need to import it) for the ``--with-ledger`` option: :: - rlwrap ./tezos-sandbox voting ./src/bin_client/test/demo/ \ + rlwrap ./tezos-sandbox voting \ + $zeronet_042/src/proto_042_Pt1GS1Zi/lib_protocol/src \ + ./src/bin_client/test/proto_test_injection/ \ --with-ledger "ledger://crouching-tiger-hidden-dragon/ed25519/0'/0'" \ --serialize-proposals \ - --root $PWD/voting-test \ --base-port=20_000 \ - --tezos-client-binary ../mr848/tezos-client \ + --current-node-binary $zeronet_042/tezos-node \ + --current-client-binary $zeronet_042/tezos-client \ + --winner-client-binary $zeronet_042/tezos-client \ + --current-admin-client-binary $zeronet_042/tezos-admin-client \ --pause-on-error=true +- The first path argument has to be the path to a valid protocol which + can be switched to from the current (``proto_alpha``) one. +- The second protocol, the looser, only needs to be valid for the + protocol compilation. +- The option ``--serialize-proposals`` tells the test to call + ``tezos-client submit proposals for ...`` one proposal at a time + which is the only method the ledger Baking app can really understand. +- The ``*-binary`` options allow to set the paths to the executables + for the different protocols: ``current`` and ``winner``. + The test becomes interactive and guides you through the interactions with the ledger, e.g.: :: - Flextesa.voting: - Ledger-prompt - - Setting up "ledger://crouching-tiger-hidden-dragon/ed25519/0'/0'" for - baking. The ledger should be showing the setup parameters (Address, - Main chain, HWMs). - - Please hit “✔” on the ledger. + Flextesa.voting: + Ledger-prompt + + Setting up "ledger://crouching-tiger-hidden-dragon/ed25519/0'/0'" for + baking. The ledger should be showing the setup parameters (Address, + Main chain, HWMs). + + Please hit “✔” on the ledger. Implementation Considerations ----------------------------- @@ -161,8 +174,8 @@ See ``./src/lib_network_sandbox/internal_pervasives.ml``: ``@[<2,3>@{crazy}@ @EDSLs@n@]``). - Many standard modules are taken from Jane St Base (already a dependency of Tezos): List, String, Option, Int, Float. -- Error monad uses *more typed* errors (polymorphic variants), cf. - module ``Asynchronous_result`` (and note that ``bind`` also calls +- Error monad uses *more typed* errors (polymorphic variants), + cf. module ``Asynchronous_result`` (and note that ``bind`` also calls ``Lwt_unix.auto_yield 0.005 ()``). - All state is kept in a (*non-global*) value passed as argument everywhere needed. To simplify the dependency management the state @@ -170,4 +183,4 @@ See ``./src/lib_network_sandbox/internal_pervasives.ml``: ``Console``, etc). Also, everything uses OCamlFormat instead of ``ocp-indent`` (see -``./.ocamlformat``). +``./src/lib_network_sandbox/.ocamlformat``). diff --git a/src/bin_flextesa/command_accusations.ml b/src/bin_flextesa/command_accusations.ml index c4ef738bfa5af8a57d032486c86c3940ee429765..decfaec6919be4343d560aee6ab9ac5900d3bfd5 100644 --- a/src/bin_flextesa/command_accusations.ml +++ b/src/bin_flextesa/command_accusations.ml @@ -4,8 +4,8 @@ open Console let default_attempts = 35 -let little_mesh_with_bakers ?base_port ?kiln state ~starting_level ~node_exec - ~client_exec ~bakers () = +let little_mesh_with_bakers ?base_port ?generate_kiln_config state + ~starting_level ~node_exec ~client_exec ~bakers () = Helpers.clear_root state >>= fun () -> Interactive_test.Pauser.generic state @@ -59,29 +59,28 @@ let little_mesh_with_bakers ?base_port ?kiln state ~starting_level ~node_exec Interactive_test.Commands. [ arbitrary_command_on_clients state ~clients:[client_0; client_1; client_2] ] ; - Asynchronous_result.map_option kiln ~f:(fun k -> + Asynchronous_result.map_option generate_kiln_config ~f:(fun kiln_config -> Tezos_client.rpc state ~client:client_0 `Get ~path:"/chains/main/chain_id" >>= fun chain_id_json -> let network_id = match chain_id_json with `String s -> s | _ -> assert false in - Kiln.start state ~network_id k - ~bakers: - ( List.map baker_list ~f:(fun (account, _) -> - Tezos_protocol.Account.(name account, pubkey_hash account) ) - @ List.map [baker_0; baker_1; baker_2] ~f:(fun bak -> - ( bak.key_name - , Tezos_protocol.Key.Of_name.pubkey_hash bak.key_name ) ) - |> List.dedup_and_sort ~compare:(fun (_, a) (_, b) -> - String.compare a b ) ) - ~node_uris: + Kiln.Configuration_directory.generate state kiln_config + ~peers: + (List.map all_nodes ~f:(fun {Tezos_node.p2p_port; _} -> p2p_port)) + ~sandbox_json:(Tezos_protocol.sandbox_path ~config:state protocol) + ~nodes: (List.map all_nodes ~f:(fun {Tezos_node.rpc_port; _} -> sprintf "http://localhost:%d" rpc_port )) - >>= fun (pg, kiln) -> - Interactive_test.Pauser.generic state EF.[af "Started Kiln with its DB."] - ) - >>= fun (_ : unit option) -> + ~bakers: + (List.map protocol.Tezos_protocol.bootstrap_accounts + ~f:(fun (account, _) -> + Tezos_protocol.Account.(name account, pubkey_hash account) )) + ~network_string:network_id ~node_exec ~client_exec + >>= fun () -> + return EF.(wf "Kiln was configured at `%s`" kiln_config.path) ) + >>= fun kiln_info_opt -> let bake msg baker = Tezos_client.Keyed.bake state baker msg in List.fold (List.init (starting_level - 1) ~f:(fun n -> n)) @@ -123,10 +122,10 @@ let wait_for_operation_in_mempools state ~nodes:all_nodes ~kind ~client_exec (`Not_done (sprintf "Waiting for %S to show up in the mempool" kind)) ) -let simple_double_baking ~starting_level ?kiln ~state ~base_port node_exec - client_exec () = +let simple_double_baking ~starting_level ?generate_kiln_config ~state + ~base_port node_exec client_exec () = little_mesh_with_bakers ~bakers:1 state ~node_exec ~client_exec () ~base_port - ~starting_level ?kiln + ~starting_level ?generate_kiln_config >>= fun (all_nodes, client_0, baker_0, client_1, baker_1, client_2, baker_2) -> let kill_nth nth = List.nth_exn all_nodes nth |> Helpers.kill_node state in let restart_nth nth = @@ -236,10 +235,10 @@ let find_endorsement_in_mempool state ~client = | None -> return (`Not_done (sprintf "No endorsement so far")) | Some e -> return (`Done e) ) -let simple_double_endorsement ~starting_level ?kiln ~state ~base_port node_exec - client_exec () = +let simple_double_endorsement ~starting_level ?generate_kiln_config ~state + ~base_port node_exec client_exec () = little_mesh_with_bakers ~bakers:2 state ~node_exec ~client_exec () - ~starting_level ~base_port ?kiln + ~starting_level ~base_port ?generate_kiln_config >>= fun (all_nodes, client_0, baker_0, client_1, baker_1, client_2, baker_2) -> (* 2 bakers ⇒ baker_0 and baker_2 are for the same key on ≠ nodes *) assert ( @@ -286,8 +285,6 @@ let simple_double_endorsement ~starting_level ?kiln ~state ~base_port node_exec >>= fun () -> Helpers.restart_node state node_1 ~client_exec >>= fun () -> - (* Tezos_client.Keyed.bake state baker_0 "baker-0 baking lonelily" - * >>= fun () -> *) Test_scenario.Queries.wait_for_all_levels_to_be state ~attempts:default_attempts ~seconds:8. [node_1; node_2] (`Equal_to (starting_level + 1)) @@ -364,8 +361,7 @@ let simple_double_endorsement ~starting_level ?kiln ~state ~base_port node_exec last_level)) ) >>= fun () -> say state EF.(af "Test done.") -let with_accusers ?kiln ~state ~base_port node_exec accuser_exec client_exec () - = +let with_accusers ~state ~base_port node_exec accuser_exec client_exec () = Helpers.clear_root state >>= fun () -> let block_interval = 2 in @@ -407,9 +403,6 @@ let with_accusers ?kiln ~state ~base_port node_exec accuser_exec client_exec () let bak = Tezos_client.Keyed.make client ~key_name ~secret_key:(Tezos_protocol.Account.private_key (fst baker_0_account)) - (* ~secret_key: - * (Tezos_protocol.Key.Of_name.private_key - * (fst baker_0 |> Tezos_protocol.name_to_string)) *) in Tezos_client.Keyed.initialize state bak >>= fun _ -> return (client, bak) in @@ -419,25 +412,6 @@ let with_accusers ?kiln ~state ~base_port node_exec accuser_exec client_exec () >>= fun (client_1, baker_1) -> baker 2 >>= fun (client_2, baker_2) -> - Asynchronous_result.map_option kiln ~f:(fun k -> - Tezos_client.rpc state ~client:client_0 `Get - ~path:"/chains/main/chain_id" - >>= fun chain_id_json -> - let network_id = - match chain_id_json with `String s -> s | _ -> assert false - in - Kiln.start state ~network_id k - ~bakers: - [ Tezos_protocol.Account.( - let acc = fst baker_0_account in - (name acc, pubkey_hash acc)) ] - ~node_uris: - (List.map all_nodes ~f:(fun {Tezos_node.rpc_port; _} -> - sprintf "http://localhost:%d" rpc_port )) - >>= fun (pg, kiln) -> - Interactive_test.Pauser.generic state EF.[af "Started Kiln with its DB."] - ) - >>= fun (_ : unit option) -> Interactive_test.Pauser.add_commands state Interactive_test.Commands.( all_defaults state ~nodes:all_nodes @@ -627,18 +601,30 @@ let cmd ~pp_error () = bnod bcli accex - kiln + generate_kiln_config state -> - let actual_test = + let checks () = + let acc = if test = `With_accusers then [accex] else [] in + Helpers.System_dependencies.precheck state `Or_fail + ~executables:(acc @ [bnod; bcli]) + in + let actual_test () = match test with - | `With_accusers -> with_accusers ~state bnod accex bcli ~base_port + | `With_accusers -> + checks () + >>= fun () -> + with_accusers ~state bnod accex bcli ~base_port () | `Simple_double_baking -> - simple_double_baking ~state bnod bcli ~base_port ?kiln - ~starting_level + checks () + >>= fun () -> + simple_double_baking ~state bnod bcli ~base_port + ?generate_kiln_config ~starting_level () | `Simple_double_endorsing -> - simple_double_endorsement ~state bnod bcli ~base_port ?kiln - ~starting_level + checks () + >>= fun () -> + simple_double_endorsement ~state bnod bcli ~base_port + ?generate_kiln_config ~starting_level () in (state, Interactive_test.Pauser.run_test ~pp_error state actual_test) ) @@ -662,7 +648,7 @@ let cmd ~pp_error () = $ Tezos_executable.cli_term `Node "tezos" $ Tezos_executable.cli_term `Client "tezos" $ Tezos_executable.cli_term `Accuser "tezos" - $ Kiln.cli_term () + $ Kiln.Configuration_directory.cli_term () $ Test_command_line.cli_state ~name:"accusing" () ) (let doc = "Sandbox networks which record double-bakings." in let man : Manpage.block list = diff --git a/src/bin_flextesa/command_daemons_protocol_change.ml b/src/bin_flextesa/command_daemons_protocol_change.ml new file mode 100644 index 0000000000000000000000000000000000000000..eb087a55a0bbe62908746aba180152d8a0e7063c --- /dev/null +++ b/src/bin_flextesa/command_daemons_protocol_change.ml @@ -0,0 +1,389 @@ +open Tezos_network_sandbox +open Internal_pervasives +open Console + +let failf fmt = ksprintf (fun s -> fail (`Scenario_error s)) fmt + +let wait_for_voting_period ?level_withing_period state ~client ~attempts period + = + let period_name = Tezos_protocol.Voting_period.to_string period in + let message = + sprintf "Waiting for voting period: `%s`%s" period_name + (Option.value_map level_withing_period ~default:"" + ~f:(sprintf " (and level-within-period ≤ %d)")) + in + Console.say state EF.(wf "%s" message) + >>= fun () -> + Helpers.wait_for state ~attempts ~seconds:10. (fun nth -> + Asynchronous_result.map_option level_withing_period ~f:(fun lvl -> + Tezos_client.rpc state ~client `Get + ~path:"/chains/main/blocks/head/metadata" + >>= fun json -> + try + let voting_period_position = + Jqo.field ~k:"level" json + |> Jqo.field ~k:"voting_period_position" + |> Jqo.get_int + in + return (voting_period_position <= lvl) + with e -> + failf "Cannot get level.voting_period_position: %s" + (Printexc.to_string e) ) + >>= fun lvl_ok -> + Tezos_client.rpc state ~client `Get + ~path:"/chains/main/blocks/head/votes/current_period_kind" + >>= function + | `String p when p = period_name && (lvl_ok = None || lvl_ok = Some true) + -> + return (`Done (nth - 1)) + | other -> + Tezos_client.successful_client_cmd state ~client + ["show"; "voting"; "period"] + >>= fun res -> + Console.say state + EF.( + desc_list (wf "Voting period:") + [markdown_verbatim (String.concat ~sep:"\n" res#out)]) + >>= fun () -> return (`Not_done message) ) + +let run state ~protocol ~size ~base_port ~no_daemons_for ?external_peer_ports + ?generate_kiln_config ~node_exec ~client_exec ~first_baker_exec + ~first_endorser_exec ~first_accuser_exec ~second_baker_exec + ~second_endorser_exec ~second_accuser_exec ~admin_exec ~new_protocol_path + () = + Helpers.System_dependencies.precheck state `Or_fail + ~executables: + [ node_exec; client_exec; first_baker_exec; first_endorser_exec + ; first_accuser_exec; second_baker_exec; second_endorser_exec + ; second_accuser_exec ] + >>= fun () -> + Test_scenario.network_with_protocol ?external_peer_ports ~protocol ~size + ~base_port state ~node_exec ~client_exec + >>= fun (nodes, protocol) -> + Tezos_client.rpc state + ~client:(Tezos_client.of_node (List.hd_exn nodes) ~exec:client_exec) + `Get ~path:"/chains/main/chain_id" + >>= fun chain_id_json -> + let network_id = + match chain_id_json with `String s -> s | _ -> assert false + in + let accusers = + List.concat_map nodes ~f:(fun node -> + let client = Tezos_client.of_node node ~exec:client_exec in + [ Tezos_daemon.accuser_of_node ~exec:first_accuser_exec ~client node + ~name_tag:"first" + ; Tezos_daemon.accuser_of_node ~exec:second_accuser_exec ~client node + ~name_tag:"second" ] ) + in + List_sequential.iter accusers ~f:(fun acc -> + Running_processes.start state (Tezos_daemon.process acc ~state) + >>= fun {process; lwt} -> return () ) + >>= fun () -> + let keys_and_daemons = + let pick_a_node_and_client idx = + match List.nth nodes ((1 + idx) mod List.length nodes) with + | Some node -> (node, Tezos_client.of_node node ~exec:client_exec) + | None -> assert false + in + Tezos_protocol.bootstrap_accounts protocol + |> List.filter_mapi ~f:(fun idx acc -> + let node, client = pick_a_node_and_client idx in + let key = Tezos_protocol.Account.name acc in + if List.mem ~equal:String.equal no_daemons_for key then None + else + Some + ( acc + , client + , [ Tezos_daemon.baker_of_node ~exec:first_baker_exec ~client + node ~key ~name_tag:"first" + ; Tezos_daemon.baker_of_node ~exec:second_baker_exec ~client + ~name_tag:"second" node ~key + ; Tezos_daemon.endorser_of_node ~exec:first_endorser_exec + ~name_tag:"first" ~client node ~key + ; Tezos_daemon.endorser_of_node ~exec:second_endorser_exec + ~name_tag:"second" ~client node ~key ] ) ) + in + List_sequential.iter keys_and_daemons ~f:(fun (acc, client, daemons) -> + Tezos_client.bootstrapped ~state client + >>= fun () -> + let key, priv = Tezos_protocol.Account.(name acc, private_key acc) in + Tezos_client.import_secret_key ~state client key priv + >>= fun () -> + say state + EF.( + desc_list + (haf "Registration-as-delegate:") + [ desc (af "Client:") (af "%S" client.Tezos_client.id) + ; desc (af "Key:") (af "%S" key) ]) + >>= fun () -> + Tezos_client.register_as_delegate ~state client key + >>= fun () -> + say state + EF.( + desc_list (haf "Starting daemons:") + [ desc (af "Client:") (af "%S" client.Tezos_client.id) + ; desc (af "Key:") (af "%S" key) ]) + >>= fun () -> + List_sequential.iter daemons ~f:(fun daemon -> + Running_processes.start state (Tezos_daemon.process daemon ~state) + >>= fun {process; lwt} -> return () ) ) + >>= fun () -> + let client_0 = + Tezos_client.of_node (List.nth_exn nodes 0) ~exec:client_exec + in + let make_admin = Tezos_admin_client.of_client ~exec:admin_exec in + Interactive_test.Pauser.add_commands state + Interactive_test.Commands.( + all_defaults state ~nodes + @ [ secret_keys state ~protocol + ; arbitrary_command_on_clients state + ~command_names:["all-clients"; "cc"] ~make_admin + ~clients: + (List.map nodes ~f:(Tezos_client.of_node ~exec:client_exec)) + ; arbitrary_command_on_clients state ~command_names:["c0"; "client-0"] + ~make_admin ~clients:[client_0] ]) ; + Test_scenario.Queries.wait_for_all_levels_to_be state ~attempts:50 + ~seconds:10. nodes + (* TODO: wait for /chains/main/blocks/head/votes/listings to be + non-empty instead of counting blocks *) + (`At_least protocol.Tezos_protocol.blocks_per_voting_period) + >>= fun () -> + (* + For each node we try to see if the node knows about the protocol, + if it does we're good, if not we inject it. + This is because `inject` fails when the node already knows a protocol. + *) + List.fold ~init:(return None) nodes ~f:(fun prevm nod -> + prevm + >>= fun _ -> + System.read_file state (new_protocol_path // "TEZOS_PROTOCOL") + >>= fun protocol -> + ( try return Jqo.(of_string protocol |> field ~k:"hash" |> get_string) + with e -> + failf "Cannot parse %s/TEZOS_PROTOCOL: %s" new_protocol_path + (Printexc.to_string e) ) + >>= fun hash -> + let client = Tezos_client.of_node ~exec:client_exec nod in + Tezos_client.rpc state ~client `Get ~path:"/protocols" + >>= fun protocols -> + match protocols with + | `A l + when List.exists l ~f:(function `String h -> h = hash | _ -> false) -> + Console.say state + EF.( + wf "Node `%s` already knows protocol `%s`." nod.Tezos_node.id + hash) + >>= fun () -> return (Some hash) + | _ -> + let admin = make_admin client in + Tezos_admin_client.inject_protocol admin state + ~path:new_protocol_path + >>= fun (_, new_protocol_hash) -> + ( if new_protocol_hash = hash then + Console.say state + EF.( + wf "Injected protocol `%s` in `%s`" new_protocol_hash + nod.Tezos_node.id) + else + failf "Injecting protocol %s failed (≠ %s)" new_protocol_hash + hash ) + >>= fun () -> return (Some hash) ) + >>= fun prot_opt -> + ( match prot_opt with + | Some s -> return s + | None -> failf "protocol injection problem?" ) + >>= fun new_protocol_hash -> + Asynchronous_result.map_option generate_kiln_config ~f:(fun kiln_config -> + Kiln.Configuration_directory.generate state kiln_config + ~peers:(List.map nodes ~f:(fun {Tezos_node.p2p_port; _} -> p2p_port)) + ~sandbox_json:(Tezos_protocol.sandbox_path ~config:state protocol) + ~nodes: + (List.map nodes ~f:(fun {Tezos_node.rpc_port; _} -> + sprintf "http://localhost:%d" rpc_port )) + ~bakers: + (List.map protocol.Tezos_protocol.bootstrap_accounts + ~f:(fun (account, _) -> + Tezos_protocol.Account.(name account, pubkey_hash account) )) + ~network_string:network_id ~node_exec ~client_exec + ~protocol_execs: + [ ( protocol.Tezos_protocol.hash + , first_baker_exec + , first_endorser_exec ) + ; (new_protocol_hash, second_baker_exec, second_endorser_exec) ] + >>= fun () -> + return EF.(wf "Kiln was configured at `%s`" kiln_config.path) ) + >>= fun kiln_info_opt -> + Interactive_test.Pauser.generic state + EF. + [ wf "Test becomes interactive." + ; Option.value kiln_info_opt ~default:(wf "") + ; wf "Please type `q` to start a voting/protocol-change period." ] + ~force:true + >>= fun () -> + wait_for_voting_period state ~client:client_0 ~attempts:10 Proposal + ~level_withing_period:3 + >>= fun _ -> + List_sequential.iter keys_and_daemons ~f:(fun (acc, client, _) -> + Tezos_client.successful_client_cmd state ~client + [ "submit"; "proposals"; "for" + ; Tezos_protocol.Account.name acc + ; new_protocol_hash ] + >>= fun _ -> + Console.sayf state + Fmt.( + fun ppf () -> + pf ppf "%s voted for %s" + (Tezos_protocol.Account.name acc) + new_protocol_hash) ) + >>= fun () -> + wait_for_voting_period state ~client:client_0 ~attempts:50 Testing_vote + >>= fun _ -> + List_sequential.iter keys_and_daemons ~f:(fun (acc, client, _) -> + Tezos_client.successful_client_cmd state ~client + [ "submit"; "ballot"; "for" + ; Tezos_protocol.Account.name acc + ; new_protocol_hash; "yea" ] + >>= fun _ -> + Console.sayf state + Fmt.( + fun ppf () -> + pf ppf "%s voted Yea to test %s" + (Tezos_protocol.Account.name acc) + new_protocol_hash) ) + >>= fun () -> + wait_for_voting_period state ~client:client_0 ~attempts:50 Promotion_vote + >>= fun _ -> + List_sequential.iter keys_and_daemons ~f:(fun (acc, client, _) -> + Tezos_client.successful_client_cmd state ~client + [ "submit"; "ballot"; "for" + ; Tezos_protocol.Account.name acc + ; new_protocol_hash; "yea" ] + >>= fun _ -> + Console.sayf state + Fmt.( + fun ppf () -> + pf ppf "%s voted Yea to promote %s" + (Tezos_protocol.Account.name acc) + new_protocol_hash) ) + >>= fun () -> + wait_for_voting_period state ~client:client_0 ~attempts:50 Proposal + >>= fun _ -> + Tezos_client.successful_client_cmd state ~client:client_0 + ["show"; "voting"; "period"] + >>= fun res -> + Helpers.wait_for state ~attempts:3 ~seconds:4. (fun _ -> + Console.say state EF.(wf "Checking actual protocol transition") + >>= fun () -> + Tezos_client.rpc state ~client:client_0 `Get + ~path:"/chains/main/blocks/head/metadata" + >>= fun json -> + ( try Jqo.field ~k:"protocol" json |> Jqo.get_string |> return + with e -> failf "Cannot parse metadata: %s" (Printexc.to_string e) ) + >>= fun proto_hash -> + if proto_hash <> new_protocol_hash then + return + (`Not_done + (sprintf "Protocol not done: %s Vs %s" proto_hash new_protocol_hash)) + else return (`Done ()) ) + >>= fun () -> + Interactive_test.Pauser.generic state + EF. + [ wf "Test finished, protocol is now %s, things should keep baking." + new_protocol_hash + ; markdown_verbatim (String.concat ~sep:"\n" res#out) ] + ~force:true + +let cmd ~pp_error () = + let open Cmdliner in + let open Term in + Test_command_line.Run_command.make ~pp_error + ( pure + (fun size + base_port + (`External_peers external_peer_ports) + (`No_daemons_for no_daemons_for) + protocol + node_exec + client_exec + admin_exec + first_baker_exec + first_endorser_exec + first_accuser_exec + second_baker_exec + second_endorser_exec + second_accuser_exec + (`Protocol_path new_protocol_path) + generate_kiln_config + state + -> + let actual_test = + run state ~size ~base_port ~protocol ~node_exec ~client_exec + ~first_baker_exec ~first_endorser_exec ~first_accuser_exec + ~second_baker_exec ~second_endorser_exec ~second_accuser_exec + ~admin_exec ?generate_kiln_config ~external_peer_ports + ~no_daemons_for ~new_protocol_path + in + (state, Interactive_test.Pauser.run_test ~pp_error state actual_test) + ) + $ Arg.( + value & opt int 5 + & info ["size"; "S"] ~doc:"Set the size of the network.") + $ Arg.( + value & opt int 20_000 + & info ["base-port"; "P"] ~doc:"Base port number to build upon.") + $ Arg.( + pure (fun l -> `External_peers l) + $ value + (opt_all int [] + (info ["add-external-peer-port"] ~docv:"PORT-NUMBER" + ~doc:"Add $(docv) to the peers of the network nodes."))) + $ Arg.( + pure (fun l -> `No_daemons_for l) + $ value + (opt_all string [] + (info ["no-daemons-for"] ~docv:"ACCOUNT-NAME" + ~doc:"Do not start daemons for $(docv)."))) + $ Tezos_protocol.cli_term () + $ Tezos_executable.cli_term `Node "tezos" + $ Tezos_executable.cli_term `Client "tezos" + $ Tezos_executable.cli_term `Admin "tezos" + $ Tezos_executable.cli_term `Baker "first" + $ Tezos_executable.cli_term `Endorser "first" + $ Tezos_executable.cli_term `Accuser "first" + $ Tezos_executable.cli_term `Baker "second" + $ Tezos_executable.cli_term `Endorser "second" + $ Tezos_executable.cli_term `Accuser "second" + $ Arg.( + pure (fun p -> `Protocol_path p) + $ required + (pos 0 (some string) None + (info [] ~doc:"The protocol to inject and vote on." + ~docv:"PROTOCOL-PATH"))) + $ Kiln.Configuration_directory.cli_term () + $ Test_command_line.cli_state ~name:"daemons-upgrade" () ) + (let doc = + "Vote and Protocol-upgrade with bakers, endorsers, and accusers." + in + let man : Manpage.block list = + [ `S "DAEMONS-UPGRADE TEST" + ; `P + "This test builds and runs a sandbox network to do a full voting \ + round followed by a protocol change while all the daemons." + ; `P "The test is interactive-only:" + ; `Blocks + (List.concat_mapi + ~f:(fun i s -> [`Noblank; `P (sprintf "%d) %s" (i + 1) s)]) + [ "It starts a sandbox assuming the protocol of the `--first-*` \ + executables (use the `--protocol-hash` option to make sure \ + it matches)." + ; "An interactive pause is done to let the user play with the \ + `first` protocol." + ; "Once the user quits the prompt (`q` or `quit` command), a \ + full voting round happens with a single proposal: the one at \ + `PROTOCOL-PATH` (which should be the one understood by the \ + `--second-*` executables)." + ; "Once the protocol switch has happened (and been verified), \ + the test re-enters an interactive prompt to let the user \ + play with the new protocol." ]) ] + in + info "daemons-upgrade" ~man ~doc) diff --git a/src/bin_flextesa/command_ledger_baking.ml b/src/bin_flextesa/command_ledger_baking.ml new file mode 100644 index 0000000000000000000000000000000000000000..1858cf797ba386c943f0517629cfa7c0da1da005 --- /dev/null +++ b/src/bin_flextesa/command_ledger_baking.ml @@ -0,0 +1,415 @@ +open Tezos_network_sandbox +open Internal_pervasives + +let failf fmt = ksprintf (fun s -> fail (`Scenario_error s)) fmt + +let ledger_prompt_notice state ~ef ?(button = `Checkmark) () = + let button_str = + match button with + | `Checkmark -> "✔" + | `X -> "❌" + | `Both -> "❌ and ✔ at the same time" + in + Console.say state + EF.( + desc (shout "Ledger-prompt") + (list [ef; wf "Press %s on the ledger." button_str])) + +let assert_failure state msg f () = + Console.say state EF.(wf "Asserting %s" msg) + >>= fun () -> + Asynchronous_result.bind_on_error + (f () >>= fun _ -> return `Worked) + ~f:(fun ~result _ -> return `Didn'tWork) + >>= function `Worked -> failf "%s" msg | `Didn'tWork -> return () + +let failf fmt = ksprintf (fun s -> fail (`Scenario_error s)) fmt +let assert_ a = if a then return () else failf "Assertion failed" + +let assert_eq to_string ~expected ~actual = + if expected = actual then return () + else + failf "Assertion failed: expected %s but got %s" (to_string expected) + (to_string actual) + +let rec ask state ef = + Console.say state EF.(list [ef; wf " (y/n)?"]) + >>= fun () -> + Lwt_exception.catch Lwt_io.read_char Lwt_io.stdin + >>= function + | 'y' | 'Y' -> return true | 'n' | 'N' -> return false | _ -> ask state ef + +let ask_assert state ef () = ask state ef >>= fun b -> assert_ b + +let with_ledger_prompt state message expectation ~f = + ledger_prompt_notice state () + ~button:(match expectation with `Succeeds -> `Checkmark | `Fails -> `X) + ~ef: + EF.( + list + [ message; wf "\n\n" + ; wf + ( match expectation with + | `Succeeds -> ">> ACCEPT THIS <<" + | `Fails -> ">> REJECT THIS <<" ) ]) + >>= fun () -> + match expectation with + | `Succeeds -> + f () >>= fun _ -> Console.say state EF.(wf "> Got response: ACCEPTED") + | `Fails -> + assert_failure state "expected failure" f () + >>= fun () -> Console.say state EF.(wf "> Got response: REJECTED") + +let with_ledger_test_reject_and_succeed state ef f = + with_ledger_prompt state ef `Fails ~f + >>= fun () -> with_ledger_prompt state ef `Succeeds ~f + +let assert_hwms state ~client ~uri ~main ~test = + Console.say state + EF.(wf "Asserting main HWM = %d and test HWM = %d" main test) + >>= fun () -> + Tezos_client.Ledger.get_hwm state ~client ~uri + >>= fun {main= main_actual; test= test_actual; _} -> + assert_eq string_of_int ~actual:main_actual ~expected:main + >>= fun () -> assert_eq string_of_int ~actual:test_actual ~expected:test + +let get_chain_id state ~client = + Tezos_client.rpc state ~client `Get ~path:"/chains/main/chain_id" + >>= (function + | `String x -> return x + | _ -> failf "Failed to parse chain_id JSON from node" ) + >>= fun chain_id_string -> + return (Tezos_crypto.Chain_id.of_b58check_exn chain_id_string) + +let get_head_block_hash state ~client () = + Tezos_client.rpc state ~client `Get ~path:"/chains/main/blocks/head/hash" + >>= function + | `String x -> return x + | _ -> failf "Failed to parse block hash JSON from node" + +let forge_endorsement state ~client ~chain_id ~level () = + get_head_block_hash state ~client () + >>= fun branch -> + let json = + `O + [ ("branch", `String branch) + ; ( "contents" + , `A + [ `O + [ ("kind", `String "endorsement") + ; ("level", `Float (float_of_int level)) ] ] ) ] + in + Tezos_client.rpc state ~client + ~path:"/chains/main/blocks/head/helpers/forge/operations" + (`Post (Ezjsonm.to_string json)) + >>= function + | `String operation_bytes -> + let endorsement_magic_byte = "02" in + return + ( endorsement_magic_byte + ^ (chain_id |> Tezos_crypto.Chain_id.to_hex |> Hex.show) + ^ operation_bytes ) + | _ -> failf "Failed to forge operation or parse result" + +let forge_delegation state ~client ~src ~dest ?(fee = 0.00126) () = + get_head_block_hash state ~client () + >>= fun branch -> + let json = + `O + [ ("branch", `String branch) + ; ( "contents" + , `A + [ `O + [ ("kind", `String "delegation") + ; ("source", `String src) + ; ( "fee" + , `String (string_of_int (int_of_float (fee *. 1000000.))) ) + ; ("counter", `String (string_of_int 30713)) + ; ("gas_limit", `String (string_of_int 10100)) + ; ("delegate", `String dest) + ; ("storage_limit", `String (string_of_int 277)) ] ] ) ] + in + Tezos_client.rpc state ~client + ~path:"/chains/main/blocks/head/helpers/forge/operations" + (`Post (Ezjsonm.to_string json)) + >>= function + | `String operation_bytes -> + let magic_byte = "03" in + return (magic_byte ^ operation_bytes) + | _ -> failf "Failed to forge operation or parse result" + +let sign state ~client ~bytes () = + Tezos_client.successful_client_cmd state + ~client:client.Tezos_client.Keyed.client + ["sign"; "bytes"; "0x" ^ bytes; "for"; client.Tezos_client.Keyed.key_name] + >>= fun _ -> return () + +let originate_account_from state ~client ~account = + let orig_account_name = + Tezos_protocol.Account.name account ^ "-originated-account" + in + Tezos_client.successful_client_cmd state ~client + [ "originate"; "account"; orig_account_name; "for" + ; Tezos_protocol.Account.name account + ; "transferring"; string_of_int 1000; "from" + ; Tezos_protocol.Account.name account + ; "--burn-cap"; string_of_float 0.257 ] + >>= fun _ -> return orig_account_name + +let setup_baking_ledger state uri ~client ~protocol = + Console.say state EF.(wf "Setting up the ledger device %S" uri) + >>= fun () -> + let key_name = "ledgered" in + let baker = Tezos_client.Keyed.make client ~key_name ~secret_key:uri in + let assert_baking_key x () = + let to_string = function Some x -> x | None -> "" in + Console.say state + EF.(wf "Asserting that the authorized key is %s" (to_string x)) + >>= fun () -> + Tezos_client.Ledger.get_authorized_key state ~client ~uri + >>= fun auth_key -> assert_eq to_string ~expected:x ~actual:auth_key + in + Tezos_client.Ledger.deauthorize_baking state ~client ~uri + (* TODO: The following assertion doesn't confirm anything if the ledger was already not authorized to bake. *) + >>= assert_baking_key None + >>= fun () -> + Tezos_client.Ledger.show_ledger state ~client ~uri + >>= fun account -> + with_ledger_test_reject_and_succeed state + EF.( + wf + "Importing %S in client `%s`. The ledger should be prompting for \ + acknowledgment to provide the public key of %s" + uri client.Tezos_client.id + (Tezos_protocol.Account.pubkey_hash account)) + (fun () -> Tezos_client.Keyed.initialize state baker >>= fun _ -> return ()) + >>= assert_failure state "baking before setup should fail" (fun () -> + Tezos_client.Keyed.bake state baker "Baked by ledger" ) + >>= assert_failure state "endorsing before setup should fail" (fun () -> + Tezos_client.Keyed.endorse state baker "Endorsed by ledger" ) + >>= fun () -> + let test_invalid_delegations () = + let ledger_pkh = Tezos_protocol.Account.pubkey_hash account in + let other_pkh = + Tezos_protocol.Account.pubkey_hash + (fst (List.last_exn protocol.Tezos_protocol.bootstrap_accounts)) + in + let cases = + [ (ledger_pkh, other_pkh, "ledger to another account") + ; (other_pkh, ledger_pkh, "another account to ledger") + ; (other_pkh, other_pkh, "another account to another account") ] + in + List_sequential.iter cases ~f:(fun (src, dest, msg) -> + forge_delegation state ~client ~src ~dest () + >>= fun forged_delegation_bytes -> + assert_failure state + (sprintf "signing a delegation from %s (%s to %s) should fail" msg + src dest) + (sign state ~client:baker ~bytes:forged_delegation_bytes) + () ) + in + test_invalid_delegations () + >>= fun () -> + with_ledger_test_reject_and_succeed state + EF.( + wf + "Setting up %S for baking.\n\ + Address: %S\n\ + Chain: mainnet\n\ + Main HWM: 0\n\ + Test HWM: 0" + uri + (Tezos_protocol.Account.pubkey_hash account)) + (fun () -> + Tezos_client.successful_client_cmd state ~client + [ "setup"; "ledger"; "to"; "bake"; "for"; key_name; "--main-hwm"; "0" + ; "--test-hwm"; "0" ] ) + >>= assert_failure state + "signing a 'Withdraw delegate' operation in Baking App should fail" + (fun () -> + Tezos_client.successful_client_cmd state ~client + [ "--wait"; "none"; "withdraw"; "delegate"; "from" + ; Tezos_protocol.Account.pubkey_hash account ] ) + >>= assert_baking_key (Some uri) + >>= test_invalid_delegations + >>= fun () -> return (baker, account) + +let run state ~node_exec ~client_exec ~admin_exec ~size ~base_port ~uri () = + Helpers.clear_root state + >>= fun () -> + Interactive_test.Pauser.generic state + EF.[af "Ready to start"; af "Root path deleted."] + >>= fun () -> + let ledger_client = Tezos_client.no_node_client ~exec:client_exec in + Tezos_client.Ledger.show_ledger state ~client:ledger_client ~uri + >>= fun ledger_account -> + let protocol = + let open Tezos_protocol in + let d = default () in + { d with + time_between_blocks= [1; 2] + ; bootstrap_accounts= + (ledger_account, 1_000_000_000_000L) + :: List.map ~f:(fun (a, _) -> (a, 1_000L)) d.bootstrap_accounts } + in + Test_scenario.network_with_protocol ~protocol ~size ~base_port state + ~node_exec ~client_exec + >>= fun (nodes, protocol) -> + let make_admin = Tezos_admin_client.of_client ~exec:admin_exec in + Interactive_test.Pauser.add_commands state + Interactive_test.Commands.( + all_defaults state ~nodes + @ [ secret_keys state ~protocol + ; Log_recorder.Operations.show_all state + ; arbitrary_command_on_clients state ~command_names:["all-clients"] + ~make_admin + ~clients: + (List.map nodes ~f:(Tezos_client.of_node ~exec:client_exec)) ]) ; + Interactive_test.Pauser.generic state EF.[af "About to really start playing"] + >>= fun () -> + let client n = + Tezos_client.of_node ~exec:client_exec (List.nth_exn nodes n) + in + let assert_hwms_ ~main ~test () = + assert_hwms state ~client:(client 0) ~uri ~main ~test + in + let set_hwm_ level () = + with_ledger_prompt state + EF.(wf "Setting HWM to %d" level) + `Succeeds + ~f:(fun () -> + Tezos_client.Ledger.set_hwm state ~client:(client 0) ~uri ~level ) + in + get_chain_id state ~client:(client 0) + >>= fun chain_id -> + setup_baking_ledger state uri ~client:(client 0) ~protocol + >>= fun (baker, ledger_account) -> + Interactive_test.Pauser.add_commands state + Interactive_test.Commands. + [ arbitrary_command_on_clients state ~command_names:["baker"] ~make_admin + ~clients:[baker.Tezos_client.Keyed.client] ] ; + let bake () = Tezos_client.Keyed.bake state baker "Baked by ledger" in + let endorse () = + Tezos_client.Keyed.endorse state baker "Endorsed by ledger" + in + let ask_hwm ~main ~test () = + assert_hwms_ ~main ~test () + >>= ask_assert state + EF.(wf "Is 'Chain' = %S and 'Last Block Level' = %d" "mainnet" main) + in + (* Test determinism of nonces *) + Tezos_client.Keyed.generate_nonce state baker "this" + >>= fun thisNonce1 -> + Tezos_client.Keyed.generate_nonce state baker "that" + >>= fun thatNonce1 -> + Tezos_client.Keyed.generate_nonce state baker "this" + >>= fun thisNonce2 -> + Tezos_client.Keyed.generate_nonce state baker "that" + >>= fun thatNonce2 -> + assert_eq (fun x -> x) ~expected:thisNonce1 ~actual:thisNonce2 + >>= fun () -> + assert_eq (fun x -> x) ~expected:thatNonce1 ~actual:thatNonce2 + >>= fun () -> + assert_ (thisNonce1 <> thatNonce1) + >>= fun () -> + assert_failure state + "originating an account from the Tezos Baking app should fail" + (fun () -> + originate_account_from state ~client:(client 0) ~account:ledger_account + >>= fun _ -> return () ) + () + >>= fun () -> + let fee = 0.00126 in + let ledger_pkh = Tezos_protocol.Account.pubkey_hash ledger_account in + forge_delegation state ~client:(client 0) () ~src:ledger_pkh ~dest:ledger_pkh + ~fee + >>= fun forged_delegation_bytes -> + with_ledger_test_reject_and_succeed state + EF.(wf "Self delegating address %s with fee %f" ledger_pkh fee) + (sign state ~client:baker ~bytes:forged_delegation_bytes) + >>= bake >>= ask_hwm ~main:2 ~test:0 + >>= fun () -> + (let level = 1 in + with_ledger_test_reject_and_succeed state + EF.(wf "Setting HWM to %d" level) + (fun () -> + Tezos_client.Ledger.set_hwm state ~client:(client 0) ~uri ~level )) + >>= assert_hwms_ ~main:1 ~test:1 + >>= bake + >>= assert_hwms_ ~main:3 ~test:1 + >>= set_hwm_ 4 + >>= assert_hwms_ ~main:4 ~test:4 + >>= assert_failure state "endorsing a level beneath HWM should fail" endorse + >>= assert_failure state "baking a level beneath HWM should fail" bake + >>= set_hwm_ 3 >>= bake + >>= assert_hwms_ ~main:4 ~test:3 + >>= endorse + >>= assert_failure state "endorsing same block twice should not work" endorse + >>= assert_hwms_ ~main:4 ~test:3 + >>= bake + >>= assert_hwms_ ~main:5 ~test:3 + >>= forge_endorsement state ~client:baker.client ~chain_id ~level:1 + >>= fun endorsement_at_low_level_bytes -> + assert_failure state "endorsing-after-baking a level beneath HWM should fail" + (sign state ~client:baker ~bytes:endorsement_at_low_level_bytes) + () + >>= assert_hwms_ ~main:5 ~test:3 + (* HWM has not changed *) + >>= endorse + (* HWM still has not changed *) + >>= assert_hwms_ ~main:5 ~test:3 + (* Forge an endorsement on a different chain *) + >>= fun () -> + let other_chain_id = "NetXSzLHKwSumh7" in + Console.say state + EF.( + wf "Signing a forged endorsement on a different chain: %s" other_chain_id) + >>= forge_endorsement state ~client:baker.client + ~chain_id:(Tezos_crypto.Chain_id.of_b58check_exn other_chain_id) + ~level:4 + >>= fun endorsement_on_different_chain_bytes -> + sign state ~client:baker ~bytes:endorsement_on_different_chain_bytes () + (* Only the test HWM has changed *) + >>= assert_hwms_ ~main:5 ~test:4 + >>= fun () -> + Loop.n_times 5 (fun _ -> bake ()) + >>= ask_hwm ~main:10 ~test:4 + >>= fun () -> + Tezos_client.Ledger.deauthorize_baking state ~client:(client 0) ~uri + >>= assert_failure state "baking after deauthorization should fail" bake + >>= assert_failure state "endorsing after deauthorization should fail" + endorse + +let cmd ~pp_error () = + let open Cmdliner in + let open Term in + Test_command_line.Run_command.make ~pp_error + ( pure + (fun uri + node_exec + client_exec + admin_exec + size + (`Base_port base_port) + state + -> + ( state + , Interactive_test.Pauser.run_test ~pp_error state + (run state ~node_exec ~size ~admin_exec ~base_port ~client_exec + ~uri) ) ) + $ Arg.( + required + (pos 0 (some string) None + (info [] ~docv:"LEDGER-URI" ~doc:"ledger:// URI"))) + $ Tezos_executable.cli_term `Node "tezos" + $ Tezos_executable.cli_term `Client "tezos" + $ Tezos_executable.cli_term `Admin "tezos" + $ Arg.(value (opt int 5 (info ["size"; "S"] ~doc:"Size of the Network"))) + $ Arg.( + pure (fun p -> `Base_port p) + $ value + (opt int 46_000 + (info ["base-port"; "P"] ~doc:"Base port number to build upon"))) + $ Test_command_line.cli_state ~name:"ledger-baking" () ) + (let doc = "Interactive test exercising the Ledger Baking app features" in + info ~doc "ledger-baking") diff --git a/src/bin_flextesa/command_ledger_wallet.ml b/src/bin_flextesa/command_ledger_wallet.ml new file mode 100644 index 0000000000000000000000000000000000000000..8ce228eb5f42c95dfcfa3118b14a9dcb4d8ad4d3 --- /dev/null +++ b/src/bin_flextesa/command_ledger_wallet.ml @@ -0,0 +1,290 @@ +open Tezos_network_sandbox +open Internal_pervasives + +let failf fmt = ksprintf (fun s -> fail (`Scenario_error s)) fmt + +let client_async_cmd state ~client args ~f = + Running_processes.run_async_cmdf state f "sh -c %s" + ( Tezos_client.client_command client ~state args + |> Genspio.Compile.to_one_liner |> Filename.quote ) + >>= fun (status, res) -> return (status = Lwt_unix.WEXITED 0, res) + +let ledger_hash_re () = + Re.( + compile + (seq + [ str "* Blake 2B Hash (ledger-style, with operation watermark):" + ; rep1 (alt [space; eol]) + ; group (rep1 alnum) + ; rep1 (alt [space; eol]) ])) + +(* Searches a stream for an expected ledger hash from `tezos-client --verbose-signing`*) +let find_and_print_signature_hash state stream = + let re = ledger_hash_re () in + let check lines = + Re.( + match exec_opt re lines with + | None -> None + | Some matches -> Some (Group.get matches 1)) + in + Asynchronous_result.Stream.fold (Lwt_io.read_lines stream) ~init:("", false) + ~f:(fun (all_output_prev, showed_message_prev) line -> + let all_output = all_output_prev ^ "\n" ^ line in + ( if not showed_message_prev then + match check all_output with + | None -> return false + | Some x -> + Console.say state EF.(wf "Hash should be: %s" x) + >>= fun () -> return true + else return true ) + >>= fun showed_message -> return (all_output, showed_message) ) + >>= fun (output, _) -> return output + +let ledger_prompt_notice state ~ef ?(button = `Checkmark) () = + let button_str = + match button with + | `Checkmark -> "✔" + | `X -> "❌" + | `Both -> "❌ and ✔ at the same time" + in + Console.say state + EF.( + desc (shout "Ledger-prompt") + (list [ef; wf "Press %s on the ledger." button_str])) + +let ledger_prompt_notice_expectation state message expectation = + ledger_prompt_notice state () + ~button:(match expectation with `Succeeds -> `Checkmark | `Fails -> `X) + ~ef: + EF.( + list + [ message; wf "\n\n" + ; wf + ( match expectation with + | `Succeeds -> ">> ACCEPT THIS <<" + | `Fails -> ">> REJECT THIS <<" ) ]) + +let run_with_status f = + Asynchronous_result.bind_on_error + (f () >>= fun x -> return (`Worked x)) + ~f:(fun ~result x -> return (`Didn'tWork x)) + +let assert_failure state msg f () = + Console.say state EF.(wf "Asserting %s" msg) + >>= fun () -> + run_with_status f + >>= function `Worked _ -> failf "%s" msg | `Didn'tWork x -> return x + +let failf fmt = ksprintf (fun s -> fail (`Scenario_error s)) fmt +let assert_ a = if a then return () else failf "Assertion failed" + +let assert_eq to_string ~expected ~actual = + if expected = actual then return () + else + failf "Assertion failed: expected %s but got %s" (to_string expected) + (to_string actual) + +let rec ask state ef = + Console.say state EF.(list [ef; wf " (y/n)?"]) + >>= fun () -> + Lwt_exception.catch Lwt_io.read_char Lwt_io.stdin + >>= function + | 'y' | 'Y' -> return true | 'n' | 'N' -> return false | _ -> ask state ef + +let ask_assert state ef () = ask state ef >>= fun b -> assert_ b + +let with_ledger_prompt state message expectation ~f = + ledger_prompt_notice_expectation state message expectation + >>= fun () -> + match expectation with + | `Succeeds -> + f () >>= fun _ -> Console.say state EF.(wf "> Got response: ACCEPTED") + | `Fails -> + assert_failure state "expected failure" f () + >>= fun _ -> Console.say state EF.(wf "> Got response: REJECTED") + +let with_ledger_test_reject_and_succeed state ef f = + with_ledger_prompt state ef `Fails ~f + >>= fun () -> with_ledger_prompt state ef `Succeeds ~f + +let get_chain_id state ~client = + Tezos_client.rpc state ~client `Get ~path:"/chains/main/chain_id" + >>= (function + | `String x -> return x + | _ -> failf "Failed to parse chain_id JSON from node" ) + >>= fun chain_id_string -> + return (Tezos_crypto.Chain_id.of_b58check_exn chain_id_string) + +let get_head_block_hash state ~client () = + Tezos_client.rpc state ~client `Get ~path:"/chains/main/blocks/head/hash" + >>= function + | `String x -> return x + | _ -> failf "Failed to parse block hash JSON from node" + +let forge_batch_transactions state ~client ~src ~dest ~n ?(fee = 0.00126) () = + get_head_block_hash state ~client () + >>= fun branch -> + let json = + `O + [ ("branch", `String branch) + ; ( "contents" + , `A + (List.map (List.range 0 n) ~f:(fun i -> + `O + [ ("kind", `String "transaction") + ; ("source", `String src) + ; ( "destination" + , `String "tz2KZPgf2rshxNUBXFcTaCemik1LH1v9qz3F" ) + ; ("amount", `String (string_of_int 100)) + ; ( "fee" + , `String (string_of_int (int_of_float (fee *. 1000000.))) + ) + ; ("counter", `String (string_of_int i)) + ; ("gas_limit", `String (string_of_int 127)) + ; ("storage_limit", `String (string_of_int 277)) ] )) ) ] + in + Tezos_client.rpc state ~client + ~path:"/chains/main/blocks/head/helpers/forge/operations" + (`Post (Ezjsonm.to_string json)) + >>= function + | `String operation_bytes -> + let magic_byte = "03" in + return (magic_byte ^ operation_bytes) + | _ -> failf "Failed to forge operation or parse result" + +let sign state ~client ~bytes () = + Tezos_client.successful_client_cmd state + ~client:client.Tezos_client.Keyed.client + ["sign"; "bytes"; "0x" ^ bytes; "for"; client.Tezos_client.Keyed.key_name] + >>= fun _ -> return () + +let run state ~node_exec ~client_exec ~admin_exec ~size ~base_port ~uri () = + Helpers.clear_root state + >>= fun () -> + Interactive_test.Pauser.generic state + EF.[af "Ready to start"; af "Root path deleted."] + >>= fun () -> + let ledger_client = Tezos_client.no_node_client ~exec:client_exec in + Tezos_client.Ledger.show_ledger state ~client:ledger_client ~uri + >>= fun ledger_account -> + Test_scenario.network_with_protocol + ~protocol:(Tezos_protocol.default ()) + ~size ~base_port state ~node_exec ~client_exec + >>= fun (nodes, protocol) -> + let make_admin = Tezos_admin_client.of_client ~exec:admin_exec in + Interactive_test.Pauser.add_commands state + Interactive_test.Commands.( + all_defaults state ~nodes + @ [ secret_keys state ~protocol + ; Log_recorder.Operations.show_all state + ; arbitrary_command_on_clients state ~command_names:["all-clients"] + ~make_admin + ~clients: + (List.map nodes ~f:(Tezos_client.of_node ~exec:client_exec)) ]) ; + Interactive_test.Pauser.generic state EF.[af "About to really start playing"] + >>= fun () -> + let client n = + Tezos_client.of_node ~exec:client_exec (List.nth_exn nodes n) + in + let signer = + Tezos_client.Keyed.make (client 0) ~key_name:"ledgered" ~secret_key:uri + in + Tezos_client.Ledger.show_ledger state ~client:(client 0) ~uri + >>= fun ledger_account -> + with_ledger_test_reject_and_succeed state + EF.( + wf + "Importing %S in client `%s`. The ledger should be prompting for \ + acknowledgment to provide the public key of %s" + uri (client 0).Tezos_client.id + (Tezos_protocol.Account.pubkey_hash ledger_account)) + (fun () -> + Tezos_client.Keyed.initialize state signer >>= fun _ -> return () ) + >>= fun _ -> + let submit_proposals () = + client_async_cmd state ~client:(client 0) + ~f:(fun proc -> find_and_print_signature_hash state proc#stdout) + [ "submit"; "proposals"; "for" + ; Tezos_protocol.Account.pubkey_hash ledger_account + ; "Pt24m4xiPbLDhVgVfABUjirbmda3yohdN82Sp9FeuAXJ4eV9otd" + ; "Psd1ynUBhMZAeajwcZJAeq5NrxorM6UCU4GJqxZ7Bx2e9vUWB6z"; "--force" + ; "--verbose-signing" ] + in + ledger_prompt_notice_expectation state + EF.(wf "Submitting multi-protocol proposal submission") + `Fails + >>= submit_proposals + >>= fun (success, stdout) -> + assert_ (not success) + >>= fun () -> + ( match + String.substr_index stdout ~pattern:"Conditions of use not satisfied" + with + | None -> failf "expected rejection %s" stdout + | Some _ -> return () ) + >>= fun () -> + ledger_prompt_notice_expectation state + EF.(wf "Submitting multi-protocol proposal submission") + `Succeeds + >>= submit_proposals + >>= fun (success, stdout) -> + assert_ (not success) + >>= fun () -> + ( match + String.substr_index stdout + ~pattern:"not registered as valid delegate key" + with + | None -> failf "expected error that key is not registered as valid delegate" + | Some _ -> return () ) + >>= fun _ -> + forge_batch_transactions state ~client:(client 0) + ~src:(Tezos_protocol.Account.pubkey_hash ledger_account) + ~dest:"tz2KZPgf2rshxNUBXFcTaCemik1LH1v9qz3F" ~n:50 () + >>= fun batch_transaction_bytes -> + let bytes_hash = + Tezos_crypto.( + `Hex batch_transaction_bytes |> Hex.to_bytes + |> Tezos_stdlib.MBytes.of_bytes + |> (fun x -> [x]) + |> Blake2B.hash_bytes |> Blake2B.to_string |> Base58.raw_encode) + in + with_ledger_test_reject_and_succeed state + EF.( + wf "Signing batch of transaction: Unrecognized Operation - Sign Hash %s" + bytes_hash) + (* Todo blake2b hash here *) + (sign state ~client:signer ~bytes:batch_transaction_bytes) + +let cmd ~pp_error () = + let open Cmdliner in + let open Term in + Test_command_line.Run_command.make ~pp_error + ( pure + (fun uri + node_exec + client_exec + admin_exec + size + (`Base_port base_port) + state + -> + ( state + , Interactive_test.Pauser.run_test ~pp_error state + (run state ~node_exec ~size ~admin_exec ~base_port ~client_exec + ~uri) ) ) + $ Arg.( + required + (pos 0 (some string) None + (info [] ~docv:"LEDGER-URI" ~doc:"ledger:// URI"))) + $ Tezos_executable.cli_term `Node "tezos" + $ Tezos_executable.cli_term `Client "tezos" + $ Tezos_executable.cli_term `Admin "tezos" + $ Arg.(value (opt int 5 (info ["size"; "S"] ~doc:"Size of the Network"))) + $ Arg.( + pure (fun p -> `Base_port p) + $ value + (opt int 46_000 + (info ["base-port"; "P"] ~doc:"Base port number to build upon"))) + $ Test_command_line.cli_state ~name:"ledger-wallet" () ) + (let doc = "Interactive test exercising the Ledger Wallet app features" in + info ~doc "ledger-wallet") diff --git a/src/bin_flextesa/command_mini_network.ml b/src/bin_flextesa/command_mini_network.ml index 8a8486a690fa2d6b09ef7e1f5906f5e139fbc5d6..37200658b2e65181262e6de7b565325379104731 100644 --- a/src/bin_flextesa/command_mini_network.ml +++ b/src/bin_flextesa/command_mini_network.ml @@ -2,10 +2,15 @@ open Tezos_network_sandbox open Internal_pervasives open Console -let run state ~protocol ~size ~base_port ?kiln node_exec client_exec baker_exec - endorser_exec accuser_exec () = - Test_scenario.network_with_protocol ~protocol ~size ~base_port state - ~node_exec ~client_exec +let run state ~protocol ~size ~base_port ~no_daemons_for ?external_peer_ports + ?generate_kiln_config node_exec client_exec baker_exec endorser_exec + accuser_exec () = + Helpers.System_dependencies.precheck state `Or_fail + ~executables: + [node_exec; client_exec; baker_exec; endorser_exec; accuser_exec] + >>= fun () -> + Test_scenario.network_with_protocol ?external_peer_ports ~protocol ~size + ~base_port state ~node_exec ~client_exec >>= fun (nodes, protocol) -> Tezos_client.rpc state ~client:(Tezos_client.of_node (List.hd_exn nodes) ~exec:client_exec) @@ -14,16 +19,20 @@ let run state ~protocol ~size ~base_port ?kiln node_exec client_exec baker_exec let network_id = match chain_id_json with `String s -> s | _ -> assert false in - Asynchronous_result.map_option kiln ~f:(fun k -> - Kiln.start state ~network_id k + Asynchronous_result.map_option generate_kiln_config ~f:(fun kiln_config -> + Kiln.Configuration_directory.generate state kiln_config + ~peers:(List.map nodes ~f:(fun {Tezos_node.p2p_port; _} -> p2p_port)) + ~sandbox_json:(Tezos_protocol.sandbox_path ~config:state protocol) + ~nodes: + (List.map nodes ~f:(fun {Tezos_node.rpc_port; _} -> + sprintf "http://localhost:%d" rpc_port )) ~bakers: (List.map protocol.Tezos_protocol.bootstrap_accounts ~f:(fun (account, _) -> Tezos_protocol.Account.(name account, pubkey_hash account) )) - ~node_uris: - (List.map nodes ~f:(fun {Tezos_node.rpc_port; _} -> - sprintf "http://localhost:%d" rpc_port )) - >>= fun (pg, kiln) -> return () ) + ~network_string:network_id ~node_exec ~client_exec + ~protocol_execs: + [(protocol.Tezos_protocol.hash, baker_exec, endorser_exec)] ) >>= fun (_ : unit option) -> let accusers = List.map nodes ~f:(fun node -> @@ -41,14 +50,17 @@ let run state ~protocol ~size ~base_port ?kiln node_exec client_exec baker_exec | None -> assert false in Tezos_protocol.bootstrap_accounts protocol - |> List.mapi ~f:(fun idx acc -> + |> List.filter_mapi ~f:(fun idx acc -> let node, client = pick_a_node_and_client idx in let key = Tezos_protocol.Account.name acc in - ( acc - , client - , [ Tezos_daemon.baker_of_node ~exec:baker_exec ~client node ~key - ; Tezos_daemon.endorser_of_node ~exec:endorser_exec ~client node - ~key ] ) ) + if List.mem ~equal:String.equal no_daemons_for key then None + else + Some + ( acc + , client + , [ Tezos_daemon.baker_of_node ~exec:baker_exec ~client node ~key + ; Tezos_daemon.endorser_of_node ~exec:endorser_exec ~client + node ~key ] ) ) in List_sequential.iter keys_and_daemons ~f:(fun (acc, client, daemons) -> Tezos_client.bootstrapped ~state client @@ -90,9 +102,23 @@ let cmd ~pp_error () = let open Cmdliner in let open Term in Test_command_line.Run_command.make ~pp_error - ( pure (fun size base_port protocol bnod bcli bak endo accu kiln state -> + ( pure + (fun size + base_port + (`External_peers external_peer_ports) + (`No_daemons_for no_daemons_for) + protocol + bnod + bcli + bak + endo + accu + generate_kiln_config + state + -> let actual_test = - run state ~size ~base_port ~protocol bnod bcli bak endo accu ?kiln + run state ~size ~base_port ~protocol bnod bcli bak endo accu + ?generate_kiln_config ~external_peer_ports ~no_daemons_for in (state, Interactive_test.Pauser.run_test ~pp_error state actual_test) ) @@ -102,13 +128,25 @@ let cmd ~pp_error () = $ Arg.( value & opt int 20_000 & info ["base-port"; "P"] ~doc:"Base port number to build upon.") + $ Arg.( + pure (fun l -> `External_peers l) + $ value + (opt_all int [] + (info ["add-external-peer-port"] ~docv:"PORT-NUMBER" + ~doc:"Add $(docv) to the peers of the network nodes."))) + $ Arg.( + pure (fun l -> `No_daemons_for l) + $ value + (opt_all string [] + (info ["no-daemons-for"] ~docv:"ACCOUNT-NAME" + ~doc:"Do not start daemons for $(docv)."))) $ Tezos_protocol.cli_term () $ Tezos_executable.cli_term `Node "tezos" $ Tezos_executable.cli_term `Client "tezos" $ Tezos_executable.cli_term `Baker "tezos" $ Tezos_executable.cli_term `Endorser "tezos" $ Tezos_executable.cli_term `Accuser "tezos" - $ Kiln.cli_term () + $ Kiln.Configuration_directory.cli_term () $ Test_command_line.cli_state ~name:"mininet" () ) (let doc = "Small network sandbox with bakers, endorsers, and accusers." in let man : Manpage.block list = diff --git a/src/bin_flextesa/command_voting.ml b/src/bin_flextesa/command_voting.ml index 41e6fb88e8345bf8c074959a33885d936db6d002..850c3e8edfd1ec4c01df2252a3cabf5c24c8fe3c 100644 --- a/src/bin_flextesa/command_voting.ml +++ b/src/bin_flextesa/command_voting.ml @@ -43,23 +43,6 @@ let setup_baking_ledger state uri ~client = let failf fmt = ksprintf (fun s -> fail (`Scenario_error s)) fmt -type voting_period = - Tezos_client_alpha.Proto_alpha.Alpha_context.Voting_period - .kind = - | Proposal - | Testing_vote - | Testing - | Promotion_vote - -let voting_period_to_string (p : voting_period) = - match - Tezos_data_encoding.Data_encoding.Json.construct - Tezos_client_alpha.Proto_alpha.Alpha_context.Voting_period.kind_encoding - p - with - | `String s -> s - | other -> assert false - let transfer state ~client ~src ~dst ~amount = Tezos_client.successful_client_cmd state ~client [ "--wait"; "none"; "transfer"; sprintf "%Ld" amount; "from"; src; "to"; dst @@ -68,7 +51,7 @@ let transfer state ~client ~src ~dst ~amount = let bake_until_voting_period ?keep_alive_delegate state ~baker ~attempts period = let client = baker.Tezos_client.Keyed.client in - let period_name = voting_period_to_string period in + let period_name = Tezos_protocol.Voting_period.to_string period in Helpers.wait_for state ~attempts ~seconds:0.5 (fun nth -> Tezos_client.rpc state ~client `Get ~path:"/chains/main/blocks/head/votes/current_period_kind" @@ -87,11 +70,34 @@ let bake_until_voting_period ?keep_alive_delegate state ~baker ~attempts period >>= fun () -> return (`Not_done (sprintf "Waiting for %S period" period_name)) ) -let run state ~demo_path ~node_exec ~client_exec ~admin_exec ~size ~base_port +let check_understood_protocols state ~chain ~client ~protocol_hash + ~expect_clueless_client = + Asynchronous_result.bind_on_result + (Tezos_client.successful_client_cmd state ~client + ["--chain"; chain; "list"; "understood"; "protocols"]) + ~f:(function + | Ok client_protocols_result -> ( + match + List.find client_protocols_result#out ~f:(fun prefix -> + String.is_prefix protocol_hash ~prefix ) + with + | Some p -> return `Proper_understanding + | None when expect_clueless_client -> return `Expected_misunderstanding + | None -> return `Failure_to_understand ) + | Error (`Client_command_error _) when expect_clueless_client -> + return `Expected_misunderstanding + | Error e -> fail e ) + +let run state ~winner_path ~demo_path ~current_hash ~node_exec ~client_exec + ~clueless_winner ~admin_exec ~winner_client_exec ~size ~base_port ~serialize_proposals ?with_ledger () = - let default_attempts = 35 in + let default_attempts = 50 in Helpers.clear_root state >>= fun () -> + Helpers.System_dependencies.precheck state `Or_fail + ~executables:[node_exec; client_exec; admin_exec; winner_client_exec] + ~protocol_paths:[winner_path; demo_path] + >>= fun () -> Interactive_test.Pauser.generic state EF.[af "Ready to start"; af "Root path deleted."] >>= fun () -> @@ -99,8 +105,10 @@ let run state ~demo_path ~node_exec ~client_exec ~admin_exec ~size ~base_port let open Tezos_protocol in let d = default () in let baker = List.nth_exn d.bootstrap_accounts 0 in + let hash = Option.value ~default:d.hash current_hash in ( { d with - time_between_blocks= [1; 0] + hash + ; time_between_blocks= [1; 0] ; bootstrap_accounts= List.map d.bootstrap_accounts ~f:(fun (n, v) -> if fst baker = n then (n, v) else (n, 1_000L) ) } @@ -151,6 +159,23 @@ let run state ~demo_path ~node_exec ~client_exec ~admin_exec ~size ~base_port Tezos_client.Keyed.initialize state baker >>= fun _ -> return baker | Some uri -> setup_baking_ledger state ~client:(client 0) uri ) >>= fun special_baker -> + let winner_client = {baker_0.client with exec= winner_client_exec} in + let winner_baker_0 = + let open Tezos_client.Keyed in + {baker_0 with client= winner_client} + in + let winner_special_baker = + let open Tezos_client.Keyed in + {special_baker with client= winner_client} + in + Interactive_test.Pauser.add_commands state + Interactive_test.Commands. + [ arbitrary_command_on_clients state + ~command_names:["wc"; "winner-client"] ?make_admin:None + ~clients:[winner_client] ] ; + Interactive_test.Pauser.generic state + EF.[wf "You can now try the new-client"] + >>= fun () -> Interactive_test.Pauser.add_commands state Interactive_test.Commands. [ arbitrary_command_on_clients state ~command_names:["baker"] ~make_admin @@ -225,21 +250,32 @@ let run state ~demo_path ~node_exec ~client_exec ~admin_exec ~size ~base_port Tezos_admin_client.successful_command admin_0 state ["list"; "protocols"] >>= fun res -> let default_protocols = res#out in - let make_and_inject_protocol name = + let make_and_inject_protocol ?(make_different = false) name path = let tmpdir = Paths.root state // sprintf "protocol-%s" name in Console.say state EF.(wf "Injecting protocol from %s" tmpdir) >>= fun () -> - Running_processes.run_successful_cmdf state - "cp -L -r %s %s && echo '(* Protocol %s *)' >> %s/main.mli" - (Filename.quote (Filename.dirname demo_path)) (Filename.quote tmpdir) name - (Filename.quote tmpdir) + Running_processes.run_successful_cmdf state "cp -L -r %s %s" + (Filename.quote path) (Filename.quote tmpdir) >>= fun _ -> - Tezos_admin_client.successful_command admin_0 state - ["inject"; "protocol"; tmpdir] - >>= fun res -> return () + ( if make_different then + Running_processes.run_successful_cmdf state + "echo '(* Protocol %s *)' >> %s/main.mli" name (Filename.quote tmpdir) + >>= fun _ -> return () + else return () ) + >>= fun () -> + Tezos_admin_client.inject_protocol admin_0 state ~path:tmpdir + >>= fun (res, hash) -> + Interactive_test.Pauser.generic state + EF. + [ af "Just injected %s (%s): %s" name path hash + ; markdown_verbatim (String.concat ~sep:"\n" res#out) ] + >>= fun () -> return hash in - Loop.n_times 3 (fun nth -> make_and_inject_protocol (sprintf "The%dth" nth)) - >>= fun () -> + make_and_inject_protocol "winner" winner_path + >>= fun winner_hash -> + make_and_inject_protocol ~make_different:(winner_path = demo_path) "demo" + demo_path + >>= fun demo_hash -> Tezos_admin_client.successful_command admin_0 state ["list"; "protocols"] >>= fun res -> let after_injections_protocols = res#out in @@ -252,12 +288,12 @@ let run state ~demo_path ~node_exec ~client_exec ~admin_exec ~size ~base_port af "`%s` (%s)" p ( if List.mem default_protocols p ~equal:String.equal then "previously known" - else "injected" ) )) ] + else + match p with + | _ when p = winner_hash -> "injected winner" + | _ when p = demo_hash -> "injected demo" + | _ -> "injected unknown" ) )) ] >>= fun () -> - let new_protocols = - List.filter after_injections_protocols ~f:(fun ph -> - not (List.mem default_protocols ph ~equal:String.equal) ) - in Asynchronous_result.map_option with_ledger ~f:(fun _ -> Interactive_test.Pauser.generic state EF. @@ -279,15 +315,15 @@ let run state ~demo_path ~node_exec ~client_exec ~admin_exec ~size ~base_port (["submit"; "proposals"; "for"; baker.key_name] @ props) >>= fun _ -> return () in + let to_submit_first = [winner_hash; demo_hash] in ( match serialize_proposals with - | false -> submit_proposals special_baker new_protocols + | false -> submit_proposals special_baker to_submit_first | true -> - List_sequential.iter new_protocols ~f:(fun one -> + List_sequential.iter to_submit_first ~f:(fun one -> submit_proposals special_baker [one] ) ) >>= fun () -> - let winner = List.hd_exn new_protocols in Tezos_client.successful_client_cmd state ~client:baker_0.client - ["submit"; "proposals"; "for"; baker_0.key_name; winner] + ["submit"; "proposals"; "for"; baker_0.key_name; winner_hash] >>= fun res -> bake_until_voting_period state ~baker:baker_0 ~attempts:protocol.blocks_per_voting_period Testing_vote @@ -303,22 +339,23 @@ let run state ~demo_path ~node_exec ~client_exec ~admin_exec ~size ~base_port Tezos_client.rpc state ~client:(client 1) `Get ~path:"/chains/main/blocks/head/votes/current_proposal" >>= fun current_proposal_json -> - if current_proposal_json <> `String winner then + if current_proposal_json <> `String winner_hash then return (`Not_done - (sprintf "Waiting for current_proposal_json to be %s (%s)" winner + (sprintf "Waiting for current_proposal_json to be %s (%s)" + winner_hash Ezjsonm.(to_string (wrap current_proposal_json)))) else return (`Done ()) ) >>= fun () -> Tezos_client.successful_client_cmd state ~client:baker_0.client - ["submit"; "ballot"; "for"; baker_0.key_name; winner; "yay"] + ["submit"; "ballot"; "for"; baker_0.key_name; winner_hash; "yay"] >>= fun _ -> Asynchronous_result.map_option with_ledger ~f:(fun _ -> ledger_prompt_notice state - EF.(wf "Submitting “Yes” ballot for %S" winner) ) + EF.(wf "Submitting “Yes” ballot for %S" winner_hash) ) >>= fun (_ : unit option) -> Tezos_client.successful_client_cmd state ~client:special_baker.client - ["submit"; "ballot"; "for"; special_baker.key_name; winner; "yay"] + ["submit"; "ballot"; "for"; special_baker.key_name; winner_hash; "yay"] >>= fun _ -> Interactive_test.Pauser.generic state EF.[af "Ballots are in (not baked though)"] @@ -333,6 +370,43 @@ let run state ~demo_path ~node_exec ~client_exec ~admin_exec ~size ~base_port ~attempts:default_attempts ~seconds:8. nodes (`At_least (Counter_log.sum level_counter)) >>= fun () -> + check_understood_protocols state ~client:winner_client ~chain:"main" + ~protocol_hash:winner_hash ~expect_clueless_client:clueless_winner + >>= (function + | `Proper_understanding -> + let chain = "test" in + Asynchronous_result.map_option with_ledger ~f:(fun _ -> + Interactive_test.Pauser.generic state + EF. + [ af "About to bake on the test chain." + ; haf + "Please switch back to the Baking app and quit (`q`) \ + this prompt." ] + ~force:true ) + >>= fun (_ : unit option) -> + let testing_bakes = 5 in + Loop.n_times testing_bakes (fun ith -> + let baker = + if ith mod 2 = 0 then winner_baker_0 + else winner_special_baker + in + Tezos_client.Keyed.bake ~chain state baker + (sprintf "Baking on the test chain [%d/%d]" (ith + 1) + testing_bakes) ) + >>= fun () -> + Test_scenario.Queries.wait_for_all_levels_to_be state ~chain + ~attempts:default_attempts ~seconds:8. nodes + (`At_least (Counter_log.sum level_counter + testing_bakes)) + >>= fun () -> + Interactive_test.Pauser.generic state + EF.[wf "Testing period, with proper winner-client, have fun."] + >>= fun () -> return () + | `Expected_misunderstanding -> + Console.say state + EF.(wf "Winner-Client cannot bake on test chain (expected)") + | `Failure_to_understand -> + failf "Winner-Client cannot bake on test chain!" ) + >>= fun () -> Helpers.wait_for state ~attempts:default_attempts ~seconds:0.3 (fun nth -> Tezos_client.rpc state ~client:(client 1) `Get ~path:"/chains/main/blocks/head/metadata" @@ -342,7 +416,7 @@ let run state ~demo_path ~node_exec ~client_exec ~admin_exec ~size ~base_port Jqo.field metadata_json ~k:"test_chain_status" |> Jqo.field ~k:"protocol" with - | `String s when s = winner -> return (`Done ()) + | `String s when s = winner_hash -> return (`Done ()) | other -> return (`Not_done @@ -367,14 +441,22 @@ let run state ~demo_path ~node_exec ~client_exec ~admin_exec ~size ~base_port Interactive_test.Pauser.generic state EF.[haf "Before ballots"] >>= fun () -> Tezos_client.successful_client_cmd state ~client:baker_0.client - ["submit"; "ballot"; "for"; baker_0.key_name; winner; "yay"] + ["submit"; "ballot"; "for"; baker_0.key_name; winner_hash; "yay"] >>= fun _ -> Asynchronous_result.map_option with_ledger ~f:(fun _ -> + Interactive_test.Pauser.generic state + EF. + [ af "About to cast approval ballot." + ; haf + "Please switch back to the Wallet app and quit (`q`) this prompt." + ] + ~force:true + >>= fun () -> ledger_prompt_notice state - EF.(wf "Submitting “Yes” ballot for %S" winner) ) + EF.(wf "Submitting “Yes” ballot for %S" winner_hash) ) >>= fun (_ : unit option) -> Tezos_client.successful_client_cmd state ~client:special_baker.client - ["submit"; "ballot"; "for"; special_baker.key_name; winner; "yay"] + ["submit"; "ballot"; "for"; special_baker.key_name; winner_hash; "yay"] >>= fun _ -> Interactive_test.Pauser.generic state EF.[af "Final ballot(s) are in (not baked though)"] @@ -407,7 +489,7 @@ let run state ~demo_path ~node_exec ~client_exec ~admin_exec ~size ~base_port let json_string = curl_res#out |> String.concat ~sep:"\n" in let json_metadata = Ezjsonm.from_string json_string in match Jqo.field json_metadata ~k:"next_protocol" with - | `String p when p = winner -> return (`Done (nth - 1)) + | `String p when p = winner_hash -> return (`Done (nth - 1)) | other -> transfer state ~client ~amount:1L ~src:baker_0.Tezos_client.Keyed.key_name @@ -416,33 +498,75 @@ let run state ~demo_path ~node_exec ~client_exec ~admin_exec ~size ~base_port ksprintf (Tezos_client.Keyed.bake state baker_0) "Baker %s bakes %d/%d waiting for next protocol: %S" client.id nth - attempts winner + attempts winner_hash >>= fun () -> return (`Not_done - (sprintf "Waiting for next_protocol: %S (≠ %s)" winner + (sprintf "Waiting for next_protocol: %S (≠ %s)" winner_hash Ezjsonm.(to_string (wrap other)))) ) >>= fun extra_bakes_waiting_for_next_protocol -> Counter_log.add level_counter "wait-for-next-protocol" extra_bakes_waiting_for_next_protocol ; - ( match - List.find client_protocols_result#out ~f:(fun prefix -> - String.is_prefix winner ~prefix ) - with - | Some p -> Console.say state EF.(wf "The client knows about %s" winner) - (* - TODO: - - make winner a protocol that the client knows - - bake on test chain - - test protocol switch - - test ≠ not-enough-votes “failures” - *) - | None -> - Console.say state EF.(wf "The client does not know about %s" winner) ) + check_understood_protocols state ~client:winner_client ~chain:"main" + ~protocol_hash:winner_hash ~expect_clueless_client:clueless_winner + >>= (function + | `Expected_misunderstanding -> + Console.say state + EF.( + wf "As expected, the client does not know about %s" winner_hash) + | `Failure_to_understand -> + failf "The winner-client does not know about `%s`" winner_hash + | `Proper_understanding -> ( + Console.say state EF.(wf "The client knows about %s" winner_hash) + >>= fun () -> + (* This actually depends on the protocol upgrade. *) + Asynchronous_result.bind_on_result + (Tezos_client.successful_client_cmd state ~client:winner_client + ["upgrade"; "baking"; "state"]) + ~f:(function + | Ok _ -> return () + | Error _ -> + Console.say state + EF.( + desc (shout "Warning") + (wf + "Command `upgrade baking state` failed, but we \ + keep going with the baking.")) ) + >>= fun () -> + Asynchronous_result.map_option with_ledger ~f:(fun _ -> + Interactive_test.Pauser.generic state + EF. + [ af "About to bake on the new winning protocol." + ; haf + "Please switch to the Baking app and quit (`q`) this \ + prompt." ] + ~force:true + >>= fun () -> + Console.say state EF.(wf "Sleeping for a couple of seconds…") + >>= fun () -> System.sleep 4. + (* USB thing is often slower than humans hitting `q` *) ) + >>= fun (_ : unit option) -> + Tezos_client.Keyed.bake state winner_baker_0 + "First bake on new protocol !!" + >>= fun () -> + Counter_log.incr level_counter "baker-0-bakes-on-new-protocol" ; + Tezos_client.Keyed.bake state winner_special_baker + "Second bake on new protocol !!" + >>= fun () -> + Counter_log.incr level_counter + "special-baker-bakes-on-new-protocol" ; + Tezos_client.rpc state ~client:winner_client `Get + ~path:"/chains/main/blocks/head/metadata" + >>= fun json_metadata -> + match Jqo.field json_metadata ~k:"protocol" with + | `String p when p = winner_hash -> return () + | other -> + failf "Protocol is not `%s` but `%s`" winner_hash + Ezjsonm.(to_string (wrap other)) ) ) >>= fun () -> Interactive_test.Pauser.generic state EF. - [ haf "End of Current WIP of the Voting test: SUCCESS \\o/" + [ haf "End of the Voting test: SUCCESS \\o/" ; desc (af "Estimated level: %d" (Counter_log.sum level_counter)) (markdown_verbatim (Counter_log.to_table_string level_counter)) ] @@ -453,11 +577,15 @@ let cmd ~pp_error () = let open Term in Test_command_line.Run_command.make ~pp_error ( pure - (fun demo_path + (fun winner_path + demo_path node_exec client_exec admin_exec + winner_client_exec size + (`Clueless_winner clueless_winner) + (`Hash current_hash) (`Base_port base_port) (`With_ledger with_ledger) (`Serialize_proposals serialize_proposals) @@ -465,18 +593,45 @@ let cmd ~pp_error () = -> ( state , Interactive_test.Pauser.run_test state ~pp_error - (run state ~serialize_proposals ~demo_path ~node_exec ~size - ~admin_exec ~base_port ~client_exec ?with_ledger) ) ) + (run state ~serialize_proposals ~current_hash ~winner_path + ~clueless_winner ~demo_path ~node_exec ~size ~admin_exec + ~base_port ~client_exec ~winner_client_exec ?with_ledger) ) ) + $ Arg.( + pure Filename.dirname + $ required + (pos 0 (some string) None + (info [] ~docv:"WINNER-PROTOCOL-PATH" + ~doc: + "The protocol to inject and make win the election, e.g. \ + `src/proto_004_Pt24m4xi/lib_protocol/src/TEZOS_PROTOCOL`."))) $ Arg.( - required - (pos 0 (some string) None - (info [] ~docv:"PROTOCOL-PATH" - ~doc: - "The protocol to inject, e.g. `./src/bin_client/test/demo/`."))) - $ Tezos_executable.cli_term `Node "tezos" - $ Tezos_executable.cli_term `Client "tezos" - $ Tezos_executable.cli_term `Admin "tezos" + pure Filename.dirname + $ required + (pos 1 (some string) None + (info [] ~docv:"LOOSER-PROTOCOL-PATH" + ~doc: + "The protocol to inject and down-vote, e.g. \ + `./src/bin_client/test/demo/TEZOS_PROTOCOL`."))) + $ Tezos_executable.cli_term `Node "current" + $ Tezos_executable.cli_term `Client "current" + $ Tezos_executable.cli_term `Admin "current" + $ Tezos_executable.cli_term `Client "winner" $ Arg.(value (opt int 5 (info ["size"; "S"] ~doc:"Size of the Network."))) + $ Arg.( + pure (fun b -> `Clueless_winner b) + $ value + (flag + (info + ["winning-client-is-clueless"] + ~doc: + "Do not fail if the client does not know about “next” \ + protocol."))) + $ Arg.( + pure (fun p -> `Hash p) + $ value + (opt (some string) None + (info ["current-hash"] + ~doc:"The hash to advertise as the current protocol."))) $ Arg.( pure (fun p -> `Base_port p) $ value @@ -501,16 +656,37 @@ let cmd ~pp_error () = $ Test_command_line.cli_state ~name:"voting" () ) (let doc = "Sandbox network with a full round of voting." in let man : Manpage.block list = - let pf fmt = ksprintf (fun s -> `P s) fmt in [ `S "VOTING TEST" - ; pf + ; `P "This command provides a test which uses a network sandbox to \ - perform a full round of protocol vote and upgrade. For now, it \ - goes up to the last block before the protocol switch, baking on \ - the test chain, and with the new protocol is future work." - ; pf + perform a full round of protocol vote and upgrade, including \ + voting and baking on the test chain with or without a Ledger Nano \ + S."; `P "There are two main test behaviors:" + ; `P + "* $(b,SIMPLE:) The simple one does as much as possible with any \ + dummy protocol candidates and a Tezos code-base which doesn't \ + handle them: it tests all the voting periods until baking the \ + last block of the currently understood protocol."; `Noblank + ; `P + "To allow the test to succeed in this case, the option \ + `--winning-client-is-clueless` is required; it is meant to signal \ + that the “winner” `tezos-client` executable (from the \ + `--winner-client-binary` option) is expected to not understand \ + the winning protocol."; `Noblank + ; `P + "This is the version running in Gitlab-CI, see `bin_flextesa/dune`." + ; `P + "* $(b,FULL:) Without the `--winning-client-is-clueless` option, \ + the test will try to bake on the test chain as well as after the \ + protocol switch (with the winner-client). This requires the \ + winning protocol to be a working one and, of course, the \ + winning-client to understand it." + ; `P "The test can run fully automated unless one uses the \ `\"--with-ledger=ledger://...\"` option in which case some steps \ - have to be interactive." ] + have to be interactive. In this case, the option \ + `--serialize-proposals` is recommended, because if it is not \ + provided, the proposal vote will be a “Sign Unverfied” \ + operation." ] in info ~doc ~man "voting") diff --git a/src/bin_flextesa/dune b/src/bin_flextesa/dune index da11553720728362eea00fba3436fef88c93e492..c1b94e033f19b4cfc312bf837f599d2bd350a0a5 100644 --- a/src/bin_flextesa/dune +++ b/src/bin_flextesa/dune @@ -31,14 +31,17 @@ (locks /tcp-port/30000_range) (action (run %{exe:main.exe} voting + %{lib:tezos-embedded-protocol-demo:raw/TEZOS_PROTOCOL} %{lib:tezos-embedded-protocol-demo:raw/TEZOS_PROTOCOL} --root-path %{env:ROOT_PATH=/tmp/flextesa-voting-demo/} --base-port 30_000 - --size 3 --with-timestamp - --tezos-client-binary %{bin:tezos-client} - --tezos-admin-client-binary %{bin:tezos-admin-client} - --tezos-node-binary %{bin:tezos-node} + --size 3 + --winning-client-is-clueless + --winner-client-binary %{bin:tezos-client} + --current-client-binary %{bin:tezos-client} + --current-admin-client-binary %{bin:tezos-admin-client} + --current-node-binary %{bin:tezos-node} ))) (alias diff --git a/src/bin_flextesa/main.ml b/src/bin_flextesa/main.ml index cc4763706fce45cff7e2e7ef9d6c6197e053399a..cdacab276ea2dab96c1cc65c5087a3132e6d11f6 100644 --- a/src/bin_flextesa/main.ml +++ b/src/bin_flextesa/main.ml @@ -34,6 +34,10 @@ module Small_utilities = struct , fun () -> Test_scenario.Network.netstat_listening_ports state >>= fun ports -> + let to_display = + List.map ports ~f:(fun (p, _) -> p) + |> List.sort ~compare:Int.compare + in Console.sayf state Fmt.( hvbox ~indent:2 (fun ppf () -> @@ -42,8 +46,8 @@ module Small_utilities = struct box (list ~sep:(fun ppf () -> string ppf "," ; sp ppf ()) - (fun ppf (p, _) -> fmt "%d" ppf p)) - ppf ports )) ) ) + (fun ppf p -> fmt "%d" ppf p)) + ppf to_display )) ) ) $ Test_command_line.cli_state ~disable_interactivity:true ~name:"netstat-ports" () ) (info "netstat-listening-ports" @@ -67,12 +71,16 @@ let () = | `Admin_command_error _ as e -> Tezos_admin_client.Command_error.pp fmt e | `Waiting_for (msg, `Time_out) -> Format.fprintf fmt "WAITING-FOR “%s”: Time-out" msg + | `Precheck_failure _ as p -> Helpers.System_dependencies.Error.pp fmt p in Term.exit @@ Term.eval_choice (help : unit Term.t * _) ( Small_utilities.all ~pp_error () @ [ Command_mini_network.cmd () ~pp_error + ; Command_daemons_protocol_change.cmd () ~pp_error ; Command_voting.cmd () ~pp_error ; Command_accusations.cmd () ~pp_error - ; Command_prevalidation.cmd () ~pp_error ] ) + ; Command_prevalidation.cmd () ~pp_error + ; Command_ledger_baking.cmd () ~pp_error + ; Command_ledger_wallet.cmd () ~pp_error ] ) diff --git a/src/lib_network_sandbox/console.ml b/src/lib_network_sandbox/console.ml index 3516438d087448629fa389f43f4aa02c694ad875..4de364d4ea5ade30133ded7b92434012a6dd79ed 100644 --- a/src/lib_network_sandbox/console.ml +++ b/src/lib_network_sandbox/console.ml @@ -68,12 +68,10 @@ let cli_term () = value & opt (enum answers) `G & info ["color"] ~doc))) let do_output t = - Lwt_exception.catch - Lwt.( - fun () -> - Lwt_io.write t.channel (Buffer.contents t.buffer) - >>= fun () -> Buffer.clear t.buffer ; return_unit) - () + Lwt.( + fun () -> + Lwt_io.write t.channel (Buffer.contents t.buffer) + >>= fun () -> Buffer.clear t.buffer ; return_unit) let sayf (o : _ Base_state.t) (fmt : Format.formatter -> unit -> unit) : (_, _) Asynchronous_result.t = @@ -95,7 +93,7 @@ let sayf (o : _ Base_state.t) (fmt : Format.formatter -> unit -> unit) : pp_print_newline ppf () ; pp_close_box ppf () ; pp_print_flush ppf ()) ; - do_output o#console + Lwt_exception.catch (do_output o#console) () let say (o : _ Base_state.t) ef : (_, _) Asynchronous_result.t = let date = @@ -111,7 +109,7 @@ let say (o : _ Base_state.t) ef : (_, _) Asynchronous_result.t = fprintf fmt "%a" Easy_format.Pretty.to_formatter msg ; pp_print_newline fmt () ; pp_print_flush fmt ()) ; - do_output o#console + Lwt_exception.catch (do_output o#console) () module Prompt = struct type item = @@ -153,12 +151,14 @@ module Prompt = struct List.mem m.commands c ~equal:String.equal ) with | Some {action; _} -> ( - Asynchronous_result.bind_on_error (action more) ~f:(fun err -> + Asynchronous_result.bind_on_error (action more) + ~f:(fun ~result _ -> say state EF.( desc (shout "Error in action:") - (custom (fun fmt -> - Error.pp fmt err ~error:(fun fmt -> function + (custom (fun ppf -> + Attached_result.pp ppf result (* Error.pp ppf err *) + ~pp_error:(fun fmt -> function | `Lwt_exn _ as e -> Lwt_exception.pp fmt e | `Command_line s -> Format.fprintf fmt "Wrong command line: %s" s diff --git a/src/lib_network_sandbox/helpers.ml b/src/lib_network_sandbox/helpers.ml index ad8c324151c6eb2c0d56b93c98bee33d426ffe40..8e421f039c0023b693f257e790ce471e3d655d47 100644 --- a/src/lib_network_sandbox/helpers.ml +++ b/src/lib_network_sandbox/helpers.ml @@ -83,3 +83,66 @@ module Counter_log = struct n ) |> String.concat ~sep:"\n" end + +module System_dependencies = struct + module Error = struct + type t = [`Precheck_failure of string] + + let pp fmt (`Precheck_failure f) = + Format.fprintf fmt "Failed precheck: %S" f + + let failf fmt = Format.kasprintf (fun s -> fail (`Precheck_failure s)) fmt + end + + open Error + + let precheck ?(using_docker = false) ?(protocol_paths = []) + ?(executables : Tezos_executable.t list = []) state how_to_react = + let commands_to_check = + (if using_docker then ["docker"] else []) + @ ["jq"; "setsid"; "curl"; "netstat"] + @ List.map executables ~f:Tezos_executable.get + in + List.fold ~init:(return []) commands_to_check ~f:(fun prev_m cmd -> + prev_m + >>= fun prev -> + Running_processes.run_cmdf state "type %s" (Filename.quote cmd) + >>= fun result -> + match result#status with + | Unix.WEXITED 0 -> return prev + | _ -> return (`Missing_exec (cmd, result) :: prev) ) + >>= fun errors_or_warnings -> + List.fold protocol_paths ~init:(return errors_or_warnings) + ~f:(fun prev_m path -> + prev_m + >>= fun prev -> + Lwt_exception.catch Lwt_unix.file_exists (path // "TEZOS_PROTOCOL") + >>= function + | true -> return prev + | false -> return (`Not_a_protocol_path path :: prev) ) + >>= fun errors_or_warnings -> + match (errors_or_warnings, how_to_react) with + | [], _ -> return () + | more, `Or_fail -> + Console.sayf state + Format.( + fun ppf () -> + pp_print_string ppf "System dependencies failed precheck:" ; + pp_print_space ppf () ; + pp_open_hvbox ppf 0 ; + List.iter more ~f:(fun item -> + pp_print_if_newline ppf () ; + pp_print_string ppf "* " ; + pp_open_hovbox ppf 0 ; + ( match item with + | `Missing_exec (path, _) -> + (* pp_open_hovbox ppf 0 ; *) + pp_print_text ppf + (sprintf "Missing executable: `%s`." path) + | `Not_a_protocol_path path -> + pp_print_text ppf + (sprintf "Not a protocol path: `%s`." path) ) ; + pp_close_box ppf () ; pp_print_space ppf () ) ; + pp_close_box ppf ()) + >>= fun () -> failf "Error/Warnings were raised during precheck." +end diff --git a/src/lib_network_sandbox/helpers.mli b/src/lib_network_sandbox/helpers.mli index 281b8a2f9342bc67aede3fbd126e5ad38759b9e4..6163a50a2dea89b390d2dea1327c87bfeab51d64 100644 --- a/src/lib_network_sandbox/helpers.mli +++ b/src/lib_network_sandbox/helpers.mli @@ -34,7 +34,7 @@ val kill_node : (** Kill a node's process. *) val restart_node : - client_exec:[`Client] Tezos_executable.t + client_exec:Tezos_executable.t -> < application_name: string ; console: Console.t ; paths: Paths.t @@ -56,3 +56,23 @@ module Counter_log : sig val sum : t -> int val to_table_string : t -> string end + +module System_dependencies : sig + module Error : sig + type t = [`Precheck_failure of string] + + val pp : Format.formatter -> [< `Precheck_failure of string] -> unit + end + + val precheck : + ?using_docker:bool + -> ?protocol_paths:string list + -> ?executables:Tezos_executable.t list + -> < application_name: string + ; console: Console.t + ; paths: Paths.t + ; runner: Running_processes.State.t + ; .. > + -> [< `Or_fail] + -> (unit, [> Lwt_exception.t | Error.t]) Asynchronous_result.t +end diff --git a/src/lib_network_sandbox/interactive_test.ml b/src/lib_network_sandbox/interactive_test.ml index 3d304c21b5233be28561fbfa36a91e7150774baf..fa3bcc4c65ac2af16b29bc491d7966aa739b9a46 100644 --- a/src/lib_network_sandbox/interactive_test.ml +++ b/src/lib_network_sandbox/interactive_test.ml @@ -165,7 +165,7 @@ module Commands = struct ] :: prev) ) >>= fun ef -> say state EF.(list ef) - | _other -> cmdline_fail "command expects 1 argument: name-prefix") + | _other -> cmdline_fail "command expects 1 argument: name-prefix" ) let kill_all state = unit_loop_no_args @@ -232,7 +232,7 @@ module Commands = struct [ desc (af "output") (ocaml_string_list res) ; desc (af "exn") (exn e) ]) >>= fun () -> return [] ) - | `Error -> return []) + | `Error -> return [] ) >>= fun contracts -> let balance block contract = let path = @@ -481,12 +481,12 @@ module Pauser = struct say state EF.(wf "Test done, sleeping %.02f seconds" n) >>= fun () -> System.sleep n ) >>= fun () -> finish () ) - ~f:(fun {error_value; attachments} -> + ~f:(fun ~result error_value (* {error_value; attachments} *) -> generic state ~force:(Interactivity.pause_on_error state) EF. [ haf "Last pause before the test will Kill 'Em All and Quit." ; desc (shout "Error:") (af "%a" pp_error error_value) ] >>= fun () -> - finish () >>= fun () -> fail error_value ~attach:attachments ) + finish () >>= fun () -> fail error_value ~attach:result.attachments ) end diff --git a/src/lib_network_sandbox/internal_pervasives.ml b/src/lib_network_sandbox/internal_pervasives.ml index 0354af42da3bcce718e1e9bbf03fb159724c0d65..bf876287b454b6645c693fdb0ce418771496b6a8 100644 --- a/src/lib_network_sandbox/internal_pervasives.ml +++ b/src/lib_network_sandbox/internal_pervasives.ml @@ -33,7 +33,8 @@ module EF = struct list ~delimiters:("(", ")") ~sep:"," ~param: { default_list with - space_after_opening= false; space_before_closing= false } + space_after_opening= false + ; space_before_closing= false } let shout = atom ~param:{atom_style= Some "shout"} let prompt = atom ~param:{atom_style= Some "prompt"} @@ -84,60 +85,126 @@ module Dbg = struct let pp_any fmt v = Dum.to_formatter fmt v end -(** An “typed error type” based on polymorphic variants *) -module Error = struct - type +'a t = - {error_value: 'a; attachments: (string * string) list} - constraint 'a = [> ] - - let make ?(attach = []) error_value = {error_value; attachments= attach} - - let pp ~error fmt {error_value; attachments} = - EF.( - label (shout "Error: ") - (list - [ custom (fun fmt -> error fmt error_value) - ; ocaml_list - (List.map attachments ~f:(fun (k, v) -> - ocaml_tuple [atom k; atom v] )) ]) - |> Easy_format.Pretty.to_formatter fmt) +(** An “decorated result type” based on polymorphic variants *) +module Attached_result = struct + type content = [`Text of string | `String_value of string] + + type ('ok, 'error) t = + {result: ('ok, 'error) result; attachments: (string * content) list} + constraint 'error = [> ] + + let ok ?(attachments = []) o = {result= Ok o; attachments} + let error ?(attachments = []) o = {result= Error o; attachments} + + let pp ppf ?pp_ok ?pp_error {result; attachments} = + let open Format in + ( match result with + | Ok o -> + pp_open_hvbox ppf 2 ; + pp_open_tag ppf "success" ; + pp_print_string ppf "OK" ; + pp_close_tag ppf () ; + Option.iter pp_ok ~f:(fun pp -> pp ppf o) ; + pp_close_box ppf () ; + () + | Error e -> + pp_open_hvbox ppf 2 ; + pp_open_tag ppf "shout" ; + pp_print_string ppf "ERROR:" ; + pp_print_space ppf () ; + pp_close_tag ppf () ; + Option.iter pp_error ~f:(fun pp -> pp ppf e) ; + pp_close_box ppf () ) ; + match attachments with + | [] -> () + | more -> + pp_print_newline ppf () ; + pp_open_hovbox ppf 4 ; + List.iter more ~f:(fun (k, v) -> + pp_print_if_newline ppf () ; + pp_print_string ppf "* " ; + fprintf ppf "%s:@ " k ; + match v with + | `Text s -> pp_print_text ppf s + | `String_value s -> fprintf ppf "%S" s ) end (** A wrapper around [('ok, 'a Error.t) result Lwt.t]. *) module Asynchronous_result = struct - type ('ok, 'a) t = ('ok, 'a Error.t) result Lwt.t + open Attached_result - let return o : (_, _) t = Lwt.return (Ok o) + type ('ok, 'error) t = ('ok, 'error) Attached_result.t Lwt.t + + let return o : (_, _) t = Lwt.return (ok o) let yield () = (* https://github.com/ocsigen/lwt/issues/631 *) if false then Lwt_unix.auto_yield 0.005 () else Lwt_main.yield () let fail ?attach error_value : (_, _) t = - Lwt.return (Error (Error.make ?attach error_value)) + Lwt.return (error ?attachments:attach error_value) + + (* let error e : (_, _) t = Lwt.return (error e) *) let bind (o : (_, _) t) f : (_, _) t = let open Lwt.Infix in o >>= function - | Ok o -> yield () >>= fun () -> f o | Error _ as e -> Lwt.return e - - let bind_on_error (o : (_, _) t) ~f : (_, _) t = - Lwt.bind o (function Ok o -> return o | Error e -> f e) + | {result= Ok o; attachments= attach} -> + yield () + >>= fun () -> + f o + >>= fun {result; attachments} -> + Lwt.return {result; attachments= attachments @ attach} + | {result= Error _; _} as e -> Lwt.return e + + let bind_on_error : + ('a, 'b) t + -> f:( result:('c, 'b) Attached_result.t + -> 'b + -> ('a, 'd) Attached_result.t Lwt.t) + -> ('a, 'd) t = + fun o ~f -> + let open Lwt.Infix in + o + >>= function + | {result= Ok _; _} as o -> Lwt.return o + | {result= Error e; attachments= attach} as res -> + f ~result:res e + >>= fun {result; attachments} -> + Lwt.return {result; attachments= attachments @ attach} let transform_error o ~f = - Lwt.bind o (function - | Ok o -> return o - | Error {Error.error_value; attachments} -> f error_value attachments ) + let open Lwt.Infix in + o + >>= function + | {result= Ok _; _} as o -> Lwt.return o + | {result= Error e; attachments} -> + Lwt.return {result= Error (f e); attachments} + + let bind_all : + ('ok, 'error) t + -> f:(('ok, 'error) Attached_result.t -> ('ok2, 'error2) t) + -> ('ok2, 'error2) t = + fun o ~f -> + let open Lwt.Infix in + o >>= fun res -> f res let bind_on_result : ('ok, 'error) t - -> f:(('ok, 'error Error.t) result -> ('ok2, 'error2) t) + -> f:(('ok, 'error) result -> ('ok2, 'error2) t) -> ('ok2, 'error2) t = - fun o ~f -> Lwt.bind o f + fun o ~f -> + let open Lwt.Infix in + o + >>= fun {result; attachments= attach} -> + f result + >>= fun {result; attachments} -> + Lwt.return {result; attachments= attachments @ attach} (** The module opened everywhere. *) - module Std = struct let ( >>= ) = bind let return = return let fail = fail + module Std = struct + let ( >>= ) = bind let return = return let fail = fail end open Std @@ -173,10 +240,36 @@ module Asynchronous_result = struct loop times end + module Stream = struct + let fold : + 'elt Lwt_stream.t + -> f:('b -> 'elt -> ('b, 'error) t) + -> init:'b + -> ('b, 'error) t = + fun stream ~f ~init -> + let error = ref None in + Lwt.catch + (fun () -> + Lwt_stream.fold_s + (fun elt prevm -> + match prevm.result with + | Ok x -> f x elt + | Error _ -> + error := Some prevm ; + Lwt.fail Not_found ) + stream (Attached_result.ok init) ) + (fun e -> + match !error with + | Some res -> Lwt.return res + | None -> + (* `f` threw a forbidden exception! *) + Lwt.fail e ) + end + let run_application r = - match Lwt_main.run (r ()) with - | Ok () -> exit 0 - | Error {Error.error_value= `Die ret; _} -> exit ret + match Lwt_main.run (r () : (_, _) t) with + | {result= Ok (); _} -> exit 0 + | {result= Error (`Die ret); _} -> exit ret end include Asynchronous_result.Std @@ -184,7 +277,9 @@ module List_sequential = Asynchronous_result.List_sequential module Loop = Asynchronous_result.Loop module Lwt_exception = struct - let fail ?attach (e : exn) = fail ?attach (`Lwt_exn e) + type t = [`Lwt_exn of exn] + + let fail ?attach (e : exn) = fail ?attach (`Lwt_exn e : [> t]) let catch ?attach f x = Lwt.catch @@ -222,9 +317,16 @@ module Process_result = struct let pp fmt = function | (`Wrong_status (res, msg) : [< t]) -> - Format.fprintf fmt "Process-error, wrong status: '%s': %s" - (status_to_string res#status) - msg + Format.( + fprintf fmt "Process-error, wrong status:@ '%s':@ %s" + (status_to_string res#status) + msg ; + fprintf fmt "@.```out@." ; + List.iter res#out ~f:(fprintf fmt " | %s@.") ; + fprintf fmt "@.```@." ; + fprintf fmt "@.```err@." ; + List.iter res#err ~f:(fprintf fmt " | %s@.") ; + fprintf fmt "@.```@.") let fail_if_non_zero (res : output) msg = if res#status <> Unix.WEXITED 0 then @@ -242,7 +344,22 @@ module Base_state = struct end (** Some {!Lwt_unix} functions. *) -module System = struct let sleep f = Lwt_exception.catch Lwt_unix.sleep f +module System = struct + let sleep f = Lwt_exception.catch Lwt_unix.sleep f + + let write_file (_state : _ Base_state.t) ?perm path ~content = + Lwt_exception.catch + (fun () -> + Lwt_io.with_file ?perm ~mode:Lwt_io.output path (fun out -> + Lwt_io.write out content ) ) + () + + let read_file (_state : _ Base_state.t) path = + Lwt_exception.catch + (fun () -> + Lwt_io.with_file ~mode:Lwt_io.input path (fun out -> Lwt_io.read out) + ) + () end (** WIP [jq]-like manipulation in pure OCaml. *) @@ -269,4 +386,7 @@ module Jqo = struct | other -> ksprintf failwith "Jqo.remove_field %S: No an object: %s" name (to_string other) + + let get_string = Ezjsonm.get_string + let get_int = Ezjsonm.get_int end diff --git a/src/lib_network_sandbox/kiln.ml b/src/lib_network_sandbox/kiln.ml index 38c5ca5e32208dc1ca8b34318ed5e3c3e9e41db0..492b4f3b7d6ce4bb1efeeb60abc07ee2c159ba38 100644 --- a/src/lib_network_sandbox/kiln.ml +++ b/src/lib_network_sandbox/kiln.ml @@ -1,119 +1,109 @@ open Internal_pervasives -type t = {run: [`Docker of string]; port: int; postgres_port: int} +module Configuration_directory = struct + type t = {path: string; clean: bool; p2p_port: int} -let make ~run ~port ~postgres_port = {run; port; postgres_port} -let default_docker_image = "obsidiansystems/tezos-bake-monitor:0.4.0" - -let default = - make ~run:(`Docker default_docker_image) ~port:8086 ~postgres_port:4_532 - -let start ?(network_id = "zeronet") state - {run= `Docker image; port; postgres_port} ~node_uris ~bakers = - let name nonbase = sprintf "flxts-%s" nonbase in - let pg_password = Tezos_protocol.Key.Of_name.pubkey "pg-password" in - let pg_port = postgres_port in - let kiln_port = port in - let pg = - Running_processes.Process.docker_run (name "kiln-postgres-db") - ~image:"postgres" - ~options: - [ "-p"; sprintf "%d:5432" pg_port; "-e" - ; sprintf "POSTGRES_PASSWORD=%s" pg_password ] - ~args:[] - in - Running_processes.start state pg - >>= fun pg_process -> - Helpers.wait_for state ~attempts:20 ~seconds:8. (fun attempt -> + let generate state ?(protocol_execs = []) t ~peers ~sandbox_json ~nodes + ~bakers ~network_string ~node_exec ~client_exec = + (* For now, client-exec in Kiln is not protocol dependent, this + should be fixed soon. *) + let {path; clean; p2p_port} = t in + ( if clean then Running_processes.run_cmdf state - "docker run --rm -e PGPASSWORD=%s --network host -it postgres psql -h \ - localhost -p %d -U postgres -w -c '\\l'" - pg_password pg_port - >>= fun res -> - Console.display_errors_of_command state res - >>= function - | true -> return (`Done ()) - | false -> - return - (`Not_done - (sprintf "Waiting for postgres to be ready (%d)" attempt)) ) - >>= fun () -> - (* We need to use /tmp and not the root-path because of Docker access rights. *) - let tmp = "/tmp" // sprintf "kiln-config-%d" port in - Running_processes.run_cmdf state - "rm -fr %s ; mkdir -p %s/config ; chmod -R 777 %s" tmp tmp tmp - >>= fun _ -> - Lwt_exception.catch - (fun () -> - Lwt_io.with_file ~perm:0o777 ~mode:Lwt_io.output (tmp // "config/loggers") - (fun out -> - Lwt_io.write out - {json|[ -{ "logger":{"Stderr":{}} , "filters": { "SQL":"Error" , "":"Info"}}, -{ "logger":{"File":{"file":"/var/run/bake-monitor/kiln.log"}}, "filters": { "": "Debug" } } -]|json} - ) ) - () - >>= fun () -> - Running_processes.run_cmdf state " chmod -R 777 %s" tmp - >>= fun _ -> - let kiln = - Running_processes.Process.docker_run (name "kiln-backend") ~image - ~options: - ["--network"; "host"; "-v"; sprintf "%s:/var/run/bake-monitor" tmp] - ~args: - [ sprintf - "--pg-connection=host=localhost port=%d dbname=postgres \ - user=postgres password=%s" - pg_port pg_password - ; "--nodes" - ; String.concat ~sep:"," node_uris - ; "--network"; network_id; "--"; "--port"; Int.to_string kiln_port ] - in - Running_processes.start state kiln - >>= fun kiln_process -> - Console.say state - EF.( - wf "Kiln was started with nodes: %s, and network-id: %s" - (List.map node_uris ~f:(sprintf "`%s`") |> String.concat ~sep:", ") - network_id) - >>= fun () -> - ( match bakers with - | [] -> return () - | _ -> - Interactive_test.Pauser.generic state ~force:true - EF. - [ wf "Importing bakers in Kiln." - ; wf - "You should open and import the following \ - bakers:" - kiln_port - ; list - (List.map bakers ~f:(fun (n, pkh) -> af "Baker: `%s` -> %s" n pkh)) - ] ) - >>= fun () -> return (pg_process, kiln_process) + "rm -fr %s ; mkdir -p %s ; chmod -R 777 %s" path path path + >>= fun _ -> return () + else return () ) + >>= fun _ -> + System.write_file state ~perm:0o777 (path // "loggers") + ~content: + Ezjsonm.( + `A + [ dict + [ ("logger", dict [("Stderr", dict [])]) + ; ( "filters" + , dict [("SQL", string "Error"); ("", string "Info")] ) ] ] + |> to_string) + (* {json|[{ "logger":{"Stderr":{}} , "filters": { "SQL":"Error" , "":"Info"}}]|json} *) + >>= fun () -> + let node_config = path // "node-config.json" in + System.write_file state ~perm:0o777 node_config + ~content: + Ezjsonm.( + dict + [ ("data-dir", string (path // "node-data-dir-unused")) + ; ("rpc", dict [("listen-addr", string "127.0.0.1")]) + ; ("p2p", dict [("expected-proof-of-work", int 1)]) ] + |> to_string) + >>= fun () -> + System.write_file state ~perm:0o777 + (path // "kiln-node-net-port") + ~content:(sprintf "%d" p2p_port) + >>= fun () -> + let pwd = Sys.getenv "PWD" in + let absolutize path = + if Filename.is_relative path then pwd // path else path + in + System.write_file state ~perm:0o777 + (path // "kiln-node-custom-args") + ~content: + (sprintf + "--config-file %s --private-mode --no-bootstrap-peers %s \ + --bootstrap-threshold 0 --connections %d --sandbox %s" + (absolutize node_config) + ( List.map peers ~f:(sprintf "--peer 127.0.0.1:%d") + |> String.concat ~sep:" " ) + (List.length peers - 1) + sandbox_json) + >>= fun () -> + System.write_file state ~perm:0o777 (path // "nodes") + ~content:(String.concat ~sep:"," nodes) + >>= fun () -> + System.write_file state ~perm:0o777 (path // "bakers") + ~content: + ( List.map bakers ~f:(fun (n, addr) -> sprintf "%s@%s" addr n) + |> String.concat ~sep:"," ) + >>= fun () -> + System.write_file state ~perm:0o777 (path // "network") + ~content:network_string + >>= fun () -> + System.write_file state ~perm:0o777 (path // "binary-paths") + ~content: + Ezjsonm.( + let absolutize exec = + let path = Tezos_executable.get exec in + absolutize path + in + dict + [ ("node-path", string (absolutize node_exec)) + ; ("client-path", string (absolutize client_exec)) + ; ( "baker-endorser-paths" + , list + (fun (p, bak, endo) -> + strings [p; absolutize bak; absolutize endo] ) + protocol_execs ) ] + |> to_string ~minify:false) + >>= fun () -> + Running_processes.run_cmdf state " chmod -R 777 %s" path + >>= fun _ -> return () -let cli_term () = - let open Cmdliner in - Term.( - pure (fun run port postgres_port -> function - | true -> Some (make ~run ~postgres_port ~port) | false -> None ) - $ Arg.( - let doc = "Set the Kiln docker image." in - pure (fun docker_image -> `Docker docker_image) - $ value - (opt string default_docker_image (info ["kiln-docker-image"] ~doc))) - $ Arg.( - value - (opt int default.port (info ["kiln-port"] ~doc:"Set the kiln port."))) - $ Arg.( - value - (opt int default.postgres_port - (info ["kiln-pg-port"] ~doc:"Set the Postgres port for Kiln."))) - $ Arg.( - value - (flag - (info ["with-kiln"] - ~doc: - "Add Kiln to the network (may make the test partially \ - interactive).")))) + let cli_term () = + let open Cmdliner in + Term.( + pure (fun x clean -> + Option.map x ~f:(fun (path, p2p_port) -> {path; p2p_port; clean}) ) + $ Arg.( + value + (opt + (some (pair ~sep:',' string int)) + None + (info + ["generate-kiln-configuration-path"] + ~docv:"PATH,PORT" + ~doc:"Generate a kiln configuration at $(docv)"))) + $ Arg.( + value + (flag + (info + ["clean-kiln-configuration"] + ~doc:"Delete configuration path before generating it")))) +end diff --git a/src/lib_network_sandbox/kiln.mli b/src/lib_network_sandbox/kiln.mli index d64cc29d8c7c7f06de63518157b02c4f6554438d..815d80ebabe5f33e4c5aa8ee033a0d6e113e25fe 100644 --- a/src/lib_network_sandbox/kiln.mli +++ b/src/lib_network_sandbox/kiln.mli @@ -1,38 +1,26 @@ -(** Manage a Kiln process next to a network-sandbox. *) +(** Helpers to run Kiln with a network-sandbox. *) open Internal_pervasives -type t +(** Generate Kiln ["./config/"] directories from sandbox parameters. *) +module Configuration_directory : sig + type t = {path: string; clean: bool; p2p_port: int} -val make : run:[`Docker of string] -> port:int -> postgres_port:int -> t -(** Configure a Kiln process-to-be, running on port [~port] and - managing a PostgreSQL database on port [~postgres_port]. *) + val generate : + < application_name: string + ; paths: Paths.t + ; runner: Running_processes.State.t + ; .. > + -> ?protocol_execs:(string * Tezos_executable.t * Tezos_executable.t) list + -> t + -> peers:int list + -> sandbox_json:string + -> nodes:string list + -> bakers:(string * string) list + -> network_string:string + -> node_exec:Tezos_executable.t + -> client_exec:Tezos_executable.t + -> (unit, [> Lwt_exception.t]) Asynchronous_result.t -val default_docker_image : string -val default : t - -val start : - ?network_id:string - -> < application_name: string - ; console: Console.t - ; paths: Paths.t - ; pauser: Interactive_test.Pauser.t - ; runner: Running_processes.State.t - ; test_interactivity: Interactive_test.Interactivity.t - ; .. > - -> t - -> node_uris:string list - -> bakers:(string * string) list - -> ( Running_processes.State.process_state - * Running_processes.State.process_state - , [> `Lwt_exn of exn | `Waiting_for of string * [`Time_out]] ) - Asynchronous_result.t -(** Start the Kiln and Postgres processes. [~network_id] is usually - the chain-id of the sandbox, [~node_uris] is the list or URIs given to - the ["--nodes"] option, if [~bakers] is not [[]] the test will force - [state#pauser] to pause for the user to add the baker addresses to - Kiln. *) - -val cli_term : unit -> t option Cmdliner.Term.t -(** Build a {!Cmdliner.Term.t} which provides options like - ["--with-kiln"] or ["--kiln-docker-image"]. *) + val cli_term : unit -> t option Cmdliner.Term.t +end diff --git a/src/lib_network_sandbox/running_processes.ml b/src/lib_network_sandbox/running_processes.ml index 261a8458d36d17125b37fd3c8ea9cd3a39f180f3..5d8355bfc5a99fa02ccb3cbb9181774bed27a85f 100644 --- a/src/lib_network_sandbox/running_processes.ml +++ b/src/lib_network_sandbox/running_processes.ml @@ -109,7 +109,8 @@ let start t process = let date = Tezos_stdlib_unix.Systime_os.now () |> Tezos_base.Time.System.to_notation in let open_file f = - Lwt_exception.catch ~attach:[("open_file", f)] + Lwt_exception.catch + ~attach:[("open_file", `String_value f)] Lwt.Infix.( fun () -> Tezos_stdlib_unix.Lwt_utils_unix.create_dir ~perm:0o700 @@ -152,6 +153,17 @@ let start t process = in State.add_process t process proc >>= fun () -> return {process; lwt= proc} +let start_full t process = + let proc_full = + Lwt_process.open_process_full + (Option.value ~default:"" process.binary, Array.of_list process.command) + in + let proc = (proc_full :> Lwt_process.process_none) in + State.add_process t process proc + >>= fun () -> + return {process; lwt= proc} + >>= fun proc_state -> return (proc_state, proc_full) + let wait _t {lwt; _} = Lwt_exception.catch (fun () -> lwt#close) () >>= fun _status -> return _status @@ -245,6 +257,18 @@ let run_cmdf state fmt = end) ) fmt +let run_async_cmdf state f fmt = + ksprintf + (fun s -> + let id = fresh_id state "cmd" ~seed:s in + let proc = Process.make_in_session id ["sh"; "-c"; s] in + start_full state proc + >>= fun (proc_state, proc) -> + f proc + >>= fun res -> + wait state proc_state >>= fun status -> return (status, res) ) + fmt + let run_successful_cmdf state fmt = ksprintf (fun cmd -> diff --git a/src/lib_network_sandbox/running_processes.mli b/src/lib_network_sandbox/running_processes.mli index 48a6b6897b1362742c362c3cc42683a9da77008a..0adb39772a35f11e70e588ed690b9fa48d7d5b4c 100644 --- a/src/lib_network_sandbox/running_processes.mli +++ b/src/lib_network_sandbox/running_processes.mli @@ -30,10 +30,7 @@ module State : sig end val output_path : - < paths: Paths.t ; .. > - -> Process.t - -> [ `Meta | `Stderr | `Stdout] - -> string + < paths: Paths.t ; .. > -> Process.t -> [`Meta | `Stderr | `Stdout] -> string (** Return the path (within {!Paths}'s root-path) where the process writes its output or metadata. *) @@ -79,6 +76,18 @@ val run_cmdf : -> 'a (** Run a shell command and wait for its end. *) +val run_async_cmdf : + < runner: State.t ; .. > + -> ( Lwt_process.process_full + -> ('a, ([> `Lwt_exn of exn] as 'b)) Asynchronous_result.t) + -> ( 'c + , unit + , string + , (Unix.process_status * 'a, 'b) Asynchronous_result.t ) + format4 + -> 'c +(** Run a shell command and run a function over the process data before waiting for its end. *) + val run_successful_cmdf : < paths: Paths.t ; runner: State.t ; .. > -> ( 'a diff --git a/src/lib_network_sandbox/test_command_line.ml b/src/lib_network_sandbox/test_command_line.ml index 7c985b56468110ead785f81787dfac95db16ecec..52ea3392a7cc8cec517be5ef2cec69c808e98e39 100644 --- a/src/lib_network_sandbox/test_command_line.ml +++ b/src/lib_network_sandbox/test_command_line.ml @@ -4,11 +4,12 @@ module Run_command = struct let or_hard_fail state main ~pp_error : unit = let open Asynchronous_result in run_application (fun () -> - bind_on_error (main ()) ~f:(fun e -> + bind_on_error (main ()) ~f:(fun ~result _ -> transform_error - ~f:(fun (`Lwt_exn _) _ -> die 3) + ~f:(fun (`Lwt_exn _) -> `Die 3) (Console.say state - EF.(custom (fun fmt -> (Error.pp ~error:pp_error) fmt e))) + EF.( + custom (fun ppf -> Attached_result.pp ppf result ~pp_error))) >>= fun () -> die 2 ) ) let term ~pp_error () = diff --git a/src/lib_network_sandbox/test_scenario.ml b/src/lib_network_sandbox/test_scenario.ml index 817e5c9fd0c31b1bbb66abf7f04fa09b3908cf4e..24689d301d5513f60e5f4c521b87f7950105e39b 100644 --- a/src/lib_network_sandbox/test_scenario.ml +++ b/src/lib_network_sandbox/test_scenario.ml @@ -71,7 +71,8 @@ module Topology = struct | Net_in_the_middle {left; right; middle} -> continue middle @ continue left @ continue right - let build ?protocol ?(base_port = 15_001) ~exec network = + let build ?(external_peer_ports = []) ?protocol ?(base_port = 15_001) ~exec + network = let all_ports = ref [] in let next_port = ref (base_port + (base_port mod 2)) in let rpc name = @@ -87,13 +88,16 @@ module Topology = struct let node peers id = let rpc_port = rpc id in let p2p_port = p2p id in - let expected_connections = List.length peers in + let expected_connections = + List.length peers + List.length external_peer_ports + in let peers = List.filter_map peers ~f:(fun p -> if p <> id then Some (p2p p) else None ) in Tezos_node.make ?protocol ~exec id ~expected_connections ~rpc_port - ~p2p_port peers + ~p2p_port + (external_peer_ports @ peers) in let dbgp prefx names = Printf.eprintf "%s:\n %s\n%!" prefx @@ -237,10 +241,10 @@ module Network = struct Tezos_client.bootstrapped client ~state ) end -let network_with_protocol ?base_port ?(size = 5) ?protocol state ~node_exec - ~client_exec = +let network_with_protocol ?external_peer_ports ?base_port ?(size = 5) ?protocol + state ~node_exec ~client_exec = let nodes = - Topology.build ?base_port ?protocol ~exec:node_exec + Topology.build ?base_port ?protocol ~exec:node_exec ?external_peer_ports (Topology.mesh "N" size) in let protocols = @@ -253,15 +257,15 @@ let network_with_protocol ?base_port ?(size = 5) ?protocol state ~node_exec >>= fun () -> return (nodes, protocol) module Queries = struct - let all_levels state ~nodes = + let all_levels ?(chain = "main") state ~nodes = List.fold nodes ~init:(return []) ~f:(fun prevm {Tezos_node.id; rpc_port; _} -> prevm >>= fun prev -> Running_processes.run_cmdf state - "curl http://localhost:%d/chains/main/blocks/head/metadata | jq \ + "curl http://localhost:%d/chains/%s/blocks/head/metadata | jq \ .level.level" - rpc_port + rpc_port chain >>= fun lvl -> Console.display_errors_of_command state lvl ~should_output:true >>= function @@ -281,7 +285,7 @@ module Queries = struct in return sorted - let wait_for_all_levels_to_be state ~attempts ~seconds nodes level = + let wait_for_all_levels_to_be ?chain state ~attempts ~seconds nodes level = let check_level = match level with | `Equal_to l -> ( = ) l @@ -307,12 +311,13 @@ module Queries = struct in Console.say state EF.( - wf "Checking for all levels to be %s (nodes: %s)" level_string + wf "Checking for all levels to be %s (nodes: %s%s)" level_string (String.concat ~sep:", " - (List.map nodes ~f:(fun n -> n.Tezos_node.id)))) + (List.map nodes ~f:(fun n -> n.Tezos_node.id))) + (Option.value_map chain ~default:"" ~f:(sprintf ", chain: %s"))) >>= fun () -> Helpers.wait_for state ~attempts ~seconds (fun _nth -> - all_levels state ~nodes + all_levels state ~nodes ?chain >>= fun results -> let not_readys = List.filter_map results ~f:(function diff --git a/src/lib_network_sandbox/test_scenario.mli b/src/lib_network_sandbox/test_scenario.mli index 1cc7fbd8383ed2ed4bbcbeccc12879116aa7c668..cd7931d30c3a82d953de078735c3ba31c8e78f1d 100644 --- a/src/lib_network_sandbox/test_scenario.mli +++ b/src/lib_network_sandbox/test_scenario.mli @@ -8,9 +8,8 @@ module Inconsistency_error : sig val should_be_one_protocol : 'a list -> ( 'a - , [> `Empty_protocol_list | `Too_many_protocols of 'a list] Error.t ) - result - Lwt.t + , [> `Empty_protocol_list | `Too_many_protocols of 'a list] ) + Asynchronous_result.t val pp : Format.formatter @@ -50,9 +49,10 @@ module Topology : sig string -> 'a network -> 'b network -> 'c network -> ('b * 'a * 'c) network val build : - ?protocol:Tezos_protocol.t + ?external_peer_ports:int list + -> ?protocol:Tezos_protocol.t -> ?base_port:int - -> exec:[`Node] Tezos_executable.t + -> exec:Tezos_executable.t -> 'a network -> 'a end @@ -73,7 +73,7 @@ module Network : sig val start_up : ?check_ports:bool -> < paths: Paths.t ; runner: Running_processes.State.t ; .. > - -> client_exec:[`Client] Tezos_executable.t + -> client_exec:Tezos_executable.t -> t -> ( unit , [> `Empty_protocol_list @@ -85,12 +85,13 @@ module Network : sig end val network_with_protocol : - ?base_port:int + ?external_peer_ports:int list + -> ?base_port:int -> ?size:int -> ?protocol:Tezos_protocol.t -> < paths: Paths.t ; runner: Running_processes.State.t ; .. > - -> node_exec:[`Node] Tezos_executable.t - -> client_exec:[`Client] Tezos_executable.t + -> node_exec:Tezos_executable.t + -> client_exec:Tezos_executable.t -> ( Tezos_node.t list * Tezos_protocol.t , [> `Empty_protocol_list | `Lwt_exn of exn @@ -104,7 +105,8 @@ val network_with_protocol : (** Run queries on running networks. *) module Queries : sig val all_levels : - < application_name: string + ?chain:string + -> < application_name: string ; console: Console.t ; paths: Paths.t ; runner: Running_processes.State.t @@ -118,7 +120,8 @@ module Queries : sig node-ID × level } values. *) val wait_for_all_levels_to_be : - < application_name: string + ?chain:string + -> < application_name: string ; console: Console.t ; paths: Paths.t ; runner: Running_processes.State.t diff --git a/src/lib_network_sandbox/tezos_admin_client.ml b/src/lib_network_sandbox/tezos_admin_client.ml index 7c7154d8b7588c9caa84d6b2530b594c0b02c08f..fff5ad98d059d9a0c0a76ee1c0a27bf62eee4ac1 100644 --- a/src/lib_network_sandbox/tezos_admin_client.ml +++ b/src/lib_network_sandbox/tezos_admin_client.ml @@ -1,6 +1,6 @@ open Internal_pervasives -type t = {id: string; port: int; exec: [`Admin] Tezos_executable.t} +type t = {id: string; port: int; exec: Tezos_executable.t} let base_dir t ~state = Paths.root state // sprintf "Admin-client-base-%s" t.id @@ -45,3 +45,15 @@ let successful_command admin state args = | true -> return res | false -> failf ~args "Admin-command failure: %s" (String.concat ~sep:" " args) + +let inject_protocol admin state ~path = + successful_command admin state ["inject"; "protocol"; path] + >>= fun res -> + String.concat ~sep:" " res#out + |> String.split ~on:' ' |> List.map ~f:String.strip + |> (function + | _ :: _ :: hash :: _ when hash.[0] = 'P' -> return hash + | _ -> + failf "inject protocol: cannot parse hash of protocol: %s" + (String.concat ~sep:", " (List.map ~f:(sprintf "%S") res#out)) ) + >>= fun hash -> return (res, hash) diff --git a/src/lib_network_sandbox/tezos_admin_client.mli b/src/lib_network_sandbox/tezos_admin_client.mli index b5bd1f32310fe8de0b543b2f1e20153958a595d9..2a3a342df0a8b5f36b399b393bd3637f2211cc16 100644 --- a/src/lib_network_sandbox/tezos_admin_client.mli +++ b/src/lib_network_sandbox/tezos_admin_client.mli @@ -2,10 +2,10 @@ open Internal_pervasives (** [t] is very similar to {!Tezos_client.t}. *) -type t = private {id: string; port: int; exec: [`Admin] Tezos_executable.t} +type t = private {id: string; port: int; exec: Tezos_executable.t} -val of_client : exec:[`Admin] Tezos_executable.t -> Tezos_client.t -> t -val of_node : exec:[`Admin] Tezos_executable.t -> Tezos_node.t -> t +val of_client : exec:Tezos_executable.t -> Tezos_client.t -> t +val of_node : exec:Tezos_executable.t -> Tezos_node.t -> t val make_command : t -> < paths: Paths.t ; .. > -> string list -> unit Genspio.EDSL.t @@ -33,3 +33,15 @@ val successful_command : -> ( Process_result.t , [> Command_error.t | `Lwt_exn of exn] ) Asynchronous_result.t + +val inject_protocol : + t + -> < application_name: string + ; console: Console.t + ; paths: Paths.t + ; runner: Running_processes.State.t + ; .. > + -> path:string + -> ( Process_result.t * string + , [> Command_error.t | `Lwt_exn of exn] ) + Asynchronous_result.t diff --git a/src/lib_network_sandbox/tezos_client.ml b/src/lib_network_sandbox/tezos_client.ml index c1a8a8940ae38b4a0dc4ac42b0ca60cb4dbad1a2..b607caa892fc1093fc29101cf3b0438699f39b61 100644 --- a/src/lib_network_sandbox/tezos_client.ml +++ b/src/lib_network_sandbox/tezos_client.ml @@ -1,8 +1,10 @@ open Internal_pervasives -type t = {id: string; port: int; exec: [`Client] Tezos_executable.t} +type t = {id: string; port: int; exec: Tezos_executable.t} type client = t +let no_node_client ~exec = {id= "C-null"; port= 0; exec} + let of_node ~exec n = let id = sprintf "C-%s" n.Tezos_node.id in let port = n.Tezos_node.rpc_port in @@ -103,13 +105,18 @@ end open Command_error open Console -let successful_client_cmd state ~client args = +let client_cmd state ~client args = Running_processes.run_cmdf state "sh -c %s" ( client_command client ~state args |> Genspio.Compile.to_one_liner |> Filename.quote ) >>= fun res -> Console.display_errors_of_command state res - >>= function + >>= fun success -> return (success, res) + +let successful_client_cmd state ~client args = + client_cmd state ~client args + >>= fun (success, res) -> + match success with | true -> return res | false -> failf ~args "Client-command failure: %s" (String.concat ~sep:" " args) @@ -200,6 +207,120 @@ let get_block_header state ~client block = in rpc state ~client `Get ~path +let list_known_addresses state ~client = + successful_client_cmd state ~client ["list"; "known"; "addresses"] + >>= fun res -> + let re = + Re.( + compile + (seq + [ group (rep1 (alt [alnum; char '_'])) + ; str ": " + ; group (rep1 alnum) + ; alt [space; eol; eos] ])) + in + return + (List.filter_map res#out + ~f: + Re.( + fun line -> + match exec_opt re line with + | None -> None + | Some matches -> Some (Group.get matches 1, Group.get matches 2))) + +module Ledger = struct + type hwm = {main: int; test: int; chain: Tezos_crypto.Chain_id.t option} + + let set_hwm state ~client ~uri ~level = + successful_client_cmd state ~client + [ "set"; "ledger"; "high"; "watermark"; "for"; uri; "to" + ; string_of_int level ] + >>= fun _ -> return () + + let get_hwm state ~client ~uri = + successful_client_cmd state ~client + [ "get"; "ledger"; "high"; "watermark"; "for"; uri + ; "--no-legacy-instructions" ] + (* TODO: Use --for-script when available *) + >>= fun res -> + (* e.g. The high water mark values for married-bison-ill-burmese/P-256 are + 0 for the main-chain (NetXH12Aer3be93) and + 0 for the test-chain. *) + let re = + Re.( + let num = rep1 digit in + compile + (seq + [ group num + ; str " for the main-chain (" + ; group (rep1 alnum) + ; str ") and "; group num; str " for the test-chain." ])) + in + let matches = Re.exec re (String.concat ~sep:" " res#out) in + try + return + { main= int_of_string (Re.Group.get matches 1) + ; chain= + (let v = Re.Group.get matches 2 in + if v = "'Unspecified'" then None + else Some (Tezos_crypto.Chain_id.of_b58check_exn v)) + ; test= int_of_string (Re.Group.get matches 3) } + with e -> + failf + "Couldn't understand result of 'get high watermark for %S': error %S: \ + from %S" + uri (Exn.to_string e) + (String.concat ~sep:"\n" res#out) + + let show_ledger state ~client ~uri = + successful_client_cmd state ~client ["show"; "ledger"; uri] + (* TODO: Use --for-script when available *) + >>= fun res -> + list_known_addresses state ~client + >>= fun known_addresses -> + let pk = Re.(rep1 alnum) in + let addr_re = Re.(compile (seq [str "* Public Key Hash: "; group pk])) in + let pubkey_re = Re.(compile (seq [str "* Public Key: "; group pk])) in + let out = String.concat ~sep:" " res#out in + try + let pubkey = Re.(Group.get (exec pubkey_re out) 1) in + let pubkey_hash = Re.(Group.get (exec addr_re out) 1) in + let name = + match + List.find known_addresses ~f:(fun (_, pkh) -> pkh = pubkey_hash) + with + | None -> "" + | Some (alias, _) -> alias + in + return + (Tezos_protocol.Account.key_pair name ~pubkey ~pubkey_hash + ~private_key:uri) + with e -> + failf "Couldn't understand result of 'show ledger %S': error %S: from %S" + uri (Exn.to_string e) + (String.concat ~sep:"\n" res#out) + + let deauthorize_baking state ~client ~uri = + successful_client_cmd state ~client + ["deauthorize"; "ledger"; "baking"; "for"; uri] + >>= fun _ -> return () + + let get_authorized_key state ~client ~uri = + successful_client_cmd state ~client + ["get"; "ledger"; "authorized"; "path"; "for"; uri] + >>= fun res -> + let re_uri = + Re.(compile (seq [str "Authorized baking URI: "; group (rep1 any); eol])) + in + let re_none = Re.(compile (str "No baking key authorized")) in + let out = String.concat ~sep:" " res#out in + return + Re.( + match exec_opt re_none out with + | Some _ -> None + | None -> Some (Group.get (exec re_uri out) 1)) +end + module Keyed = struct type t = {client: client; key_name: string; secret_key: string} @@ -209,9 +330,13 @@ module Keyed = struct successful_client_cmd state ~client ["import"; "secret"; "key"; key_name; secret_key; "--force"] - let bake state baker msg = + let bake ?chain state baker msg = + let chain_arg = + Option.value_map chain ~default:[] ~f:(fun c -> ["--chain"; c]) + in successful_client_cmd state ~client:baker.client - ["bake"; "for"; baker.key_name; "--force"; "--minimal-timestamp"] + ( chain_arg + @ ["bake"; "for"; baker.key_name; "--force"; "--minimal-timestamp"] ) >>= fun res -> Log_recorder.Operations.bake state ~client:baker.client.id ~output:res#out msg ; @@ -233,6 +358,11 @@ module Keyed = struct (af "Successful bake (%s: %s):" baker.client.id msg) (ocaml_string_list res#out)) + let generate_nonce state {client; key_name; _} data = + successful_client_cmd state ~client + ["generate"; "nonce"; "hash"; "for"; key_name; "from"; data] + >>= fun res -> return (List.hd_exn res#out) + let forge_and_inject state {client; key_name; _} ~json = rpc state ~client ~path:"/chains/main/blocks/head/helpers/forge/operations" (`Post (Ezjsonm.to_string json)) diff --git a/src/lib_network_sandbox/tezos_client.mli b/src/lib_network_sandbox/tezos_client.mli index 49c8b679baa3e57f4a887868ec6f2effa50a79ec..d05569910fee4c567eb5bfdb30217f1d62fc6e68 100644 --- a/src/lib_network_sandbox/tezos_client.mli +++ b/src/lib_network_sandbox/tezos_client.mli @@ -1,17 +1,22 @@ (** Wrapper around the main ["tezos-client"] application. *) open Internal_pervasives -type t = private {id: string; port: int; exec: [`Client] Tezos_executable.t} +type t = {id: string; port: int; exec: Tezos_executable.t} type client = t -val of_node : exec:[`Client] Tezos_executable.t -> Tezos_node.t -> t +val of_node : exec:Tezos_executable.t -> Tezos_node.t -> t (** Create a client which is meant to communicate with a given node. *) +val no_node_client : exec:Tezos_executable.t -> t +(** Create a client not connected to a node (e.g. for ledger interaction). *) + val base_dir : t -> state:< paths: Paths.t ; .. > -> string +(** Get the path to the ["--base-dir"] option of the client. *) + +(** {3 Build Scripts } *) val client_command : t -> state:< paths: Paths.t ; .. > -> string list -> unit Genspio.EDSL.t -(** {3 Build Scripts } *) val bootstrapped_script : t -> state:< paths: Paths.t ; .. > -> unit Genspio.EDSL.t @@ -60,6 +65,16 @@ module Command_error : sig val pp : Format.formatter -> t -> unit end +val client_cmd : + < application_name: string + ; console: Console.t + ; paths: Paths.t + ; runner: Running_processes.State.t + ; .. > + -> client:client + -> string list + -> (bool * Process_result.t, [> `Lwt_exn of exn]) Asynchronous_result.t + val successful_client_cmd : < application_name: string ; console: Console.t @@ -135,6 +150,76 @@ val get_block_header : Asynchronous_result.t (** Call the RPC ["/chains/main/blocks//header"]. *) +val list_known_addresses : + < application_name: string + ; console: Console.t + ; paths: Paths.t + ; runner: Running_processes.State.t + ; .. > + -> client:t + -> ( (string * string) list + , [> Command_error.t | `Lwt_exn of exn] ) + Asynchronous_result.t + +module Ledger : sig + type hwm = {main: int; test: int; chain: Tezos_crypto.Chain_id.t option} + + val get_hwm : + < application_name: string + ; console: Console.t + ; paths: Paths.t + ; runner: Running_processes.State.t + ; .. > + -> client:t + -> uri:string + -> (hwm, [> Command_error.t | `Lwt_exn of exn]) Asynchronous_result.t + + val set_hwm : + < application_name: string + ; console: Console.t + ; paths: Paths.t + ; runner: Running_processes.State.t + ; .. > + -> client:t + -> uri:string + -> level:int + -> (unit, [> Command_error.t | `Lwt_exn of exn]) Asynchronous_result.t + + val show_ledger : + < application_name: string + ; console: Console.t + ; paths: Paths.t + ; runner: Running_processes.State.t + ; .. > + -> client:t + -> uri:string + -> ( Tezos_protocol.Account.t + , [> Command_error.t | `Lwt_exn of exn] ) + Asynchronous_result.t + + val deauthorize_baking : + < application_name: string + ; console: Console.t + ; paths: Paths.t + ; runner: Running_processes.State.t + ; .. > + -> client:t + -> uri:string + -> (unit, [> Command_error.t | `Lwt_exn of exn]) Asynchronous_result.t + + val get_authorized_key : + < application_name: string + ; console: Console.t + ; paths: Paths.t + ; runner: Running_processes.State.t + ; .. > + -> client:t + -> uri:string + -> ( string option + , [> Command_error.t | `Lwt_exn of exn] ) + Asynchronous_result.t +end + module Keyed : sig type t = {client: client; key_name: string; secret_key: string} @@ -152,7 +237,8 @@ module Keyed : sig Asynchronous_result.t val bake : - < application_name: string + ?chain:string + -> < application_name: string ; console: Console.t ; operations_log: Log_recorder.Operations.t ; paths: Paths.t @@ -173,6 +259,17 @@ module Keyed : sig -> string -> (unit, [> Command_error.t | `Lwt_exn of exn]) Asynchronous_result.t + val generate_nonce : + < application_name: string + ; console: Console.t + ; operations_log: Log_recorder.Operations.t + ; paths: Paths.t + ; runner: Running_processes.State.t + ; .. > + -> t + -> string + -> (string, [> Command_error.t | `Lwt_exn of exn]) Asynchronous_result.t + val forge_and_inject : < application_name: string ; console: Console.t diff --git a/src/lib_network_sandbox/tezos_daemon.ml b/src/lib_network_sandbox/tezos_daemon.ml index e7c2bbef0d57e45747b7980c47a8f18ae2662642..eb0611dd49a8c1dd292f5bd9bf72a40fa92a32d7 100644 --- a/src/lib_network_sandbox/tezos_daemon.ml +++ b/src/lib_network_sandbox/tezos_daemon.ml @@ -1,7 +1,5 @@ open Internal_pervasives -type kind = [`Baker | `Endorser | `Accuser] - type args = | Baker : string -> args | Endorser : string -> args @@ -10,13 +8,16 @@ type args = type t = { node: Tezos_node.t ; client: Tezos_client.t - ; exec: kind Tezos_executable.t - ; args: args } + ; exec: Tezos_executable.t + ; args: args + ; name_tag: string option } + +let of_node ?name_tag node args ~exec ~client = + {node; exec; client; args; name_tag} -let of_node node args ~exec ~client = {node; exec; client; args} -let baker_of_node nod ~key = of_node nod (Baker key) -let endorser_of_node nod ~key = of_node nod (Endorser key) -let accuser_of_node nod = of_node nod Accuser +let baker_of_node ?name_tag nod ~key = of_node nod ?name_tag (Baker key) +let endorser_of_node ?name_tag nod ~key = of_node nod ?name_tag (Endorser key) +let accuser_of_node ?name_tag nod = of_node ?name_tag nod Accuser let arg_to_string = function | Baker k -> sprintf "baker-%s" k @@ -29,8 +30,9 @@ let to_script (t : t) ~state = Tezos_executable.call t.exec ~path: ( base_dir - // sprintf "exec-%s-%d" (arg_to_string t.args) - t.node.Tezos_node.rpc_port ) + // sprintf "exec-%s-%d%s" (arg_to_string t.args) + t.node.Tezos_node.rpc_port + (Option.value_map t.name_tag ~default:"" ~f:(sprintf "-%s")) ) args in match t.args with @@ -54,5 +56,6 @@ let to_script (t : t) ~state = let process (t : t) ~state = Running_processes.Process.genspio - (sprintf "%s-for-%s" (arg_to_string t.args) t.node.Tezos_node.id) + (sprintf "%s-for-%s%s" (arg_to_string t.args) t.node.Tezos_node.id + (Option.value_map t.name_tag ~default:"" ~f:(sprintf "-%s"))) (to_script t ~state) diff --git a/src/lib_network_sandbox/tezos_daemon.mli b/src/lib_network_sandbox/tezos_daemon.mli index ecacacce5d3adc37c997313d7cc92d19fe9a0699..98d4567ce8ee73a31488b18ed028ee04723f55b1 100644 --- a/src/lib_network_sandbox/tezos_daemon.mli +++ b/src/lib_network_sandbox/tezos_daemon.mli @@ -1,5 +1,3 @@ -type kind = [`Accuser | `Baker | `Endorser] - type args = private | Baker : string -> args | Endorser : string -> args @@ -8,32 +6,40 @@ type args = private type t = private { node: Tezos_node.t ; client: Tezos_client.t - ; exec: kind Tezos_executable.t - ; args: args } + ; exec: Tezos_executable.t + ; args: args + ; name_tag: string option } val of_node : - Tezos_node.t + ?name_tag:string + -> Tezos_node.t -> args - -> exec:kind Tezos_executable.t + -> exec:Tezos_executable.t -> client:Tezos_client.t -> t val baker_of_node : - Tezos_node.t + ?name_tag:string + -> Tezos_node.t -> key:string - -> exec:kind Tezos_executable.t + -> exec:Tezos_executable.t -> client:Tezos_client.t -> t val endorser_of_node : - Tezos_node.t + ?name_tag:string + -> Tezos_node.t -> key:string - -> exec:kind Tezos_executable.t + -> exec:Tezos_executable.t -> client:Tezos_client.t -> t val accuser_of_node : - Tezos_node.t -> exec:kind Tezos_executable.t -> client:Tezos_client.t -> t + ?name_tag:string + -> Tezos_node.t + -> exec:Tezos_executable.t + -> client:Tezos_client.t + -> t val arg_to_string : args -> string val to_script : t -> state:< paths: Paths.t ; .. > -> unit Genspio.Language.t diff --git a/src/lib_network_sandbox/tezos_executable.ml b/src/lib_network_sandbox/tezos_executable.ml index 6531f7dfc35aa64d5046b1073e322c5f787fabce..9f65f492228f6f5cce3359879d56837e7fa470c2 100644 --- a/src/lib_network_sandbox/tezos_executable.ml +++ b/src/lib_network_sandbox/tezos_executable.ml @@ -15,16 +15,14 @@ end type kind = [`Node | `Baker | `Endorser | `Accuser | `Client | `Admin] -type 'kind t = - { kind: - 'kind - (* if needed, it's easy to remove this overengineered type parameter. *) +type t = + { kind: kind ; binary: string option ; unix_files_sink: Unix_files_sink.t option ; environment: (string * string) list } -let node ?binary ?unix_files_sink ?(environment = []) () = - {kind= `Node; binary; unix_files_sink; environment} +let make ?binary ?unix_files_sink ?(environment = []) (kind : [< kind]) = + {kind; binary; unix_files_sink; environment} let kind_string (kind : [< kind]) = match kind with @@ -36,8 +34,9 @@ let kind_string (kind : [< kind]) = | `Admin -> "admin-client" let default_binary t = sprintf "tezos-%s" (kind_string t.kind) +let get t = Option.value t.binary ~default:(default_binary t) -let call (t : [< kind] t) ~path args = +let call t ~path args = let open Genspio.EDSL in seq ( Option.value_map t.unix_files_sink ~default:[] ~f:(function @@ -51,7 +50,7 @@ let call (t : [< kind] t) ~path args = ; write_stdout ~path:(path // "last-cmd" |> str) (printf (str "ARGS: %s\\n") [str (String.concat ~sep:" " args)]) - ; exec (Option.value t.binary ~default:(default_binary t) :: args) ] ) + ; exec (get t :: args) ] ) let cli_term kind prefix = let open Cmdliner in diff --git a/src/lib_network_sandbox/tezos_executable.mli b/src/lib_network_sandbox/tezos_executable.mli index 16b3c32cd0b402f649d3190955e7e9df7d75dd2c..ebb366e2d72befd72f27dd5c12ed3a8410b4a0d4 100644 --- a/src/lib_network_sandbox/tezos_executable.mli +++ b/src/lib_network_sandbox/tezos_executable.mli @@ -21,34 +21,37 @@ end type kind = [`Node | `Baker | `Endorser | `Accuser | `Client | `Admin] (** The wrapper of the tezos-executable. *) -type 'kind t = private - { kind: 'kind +type t = private + { kind: kind ; binary: string option ; unix_files_sink: Unix_files_sink.t option ; environment: (string * string) list } -val node : +val make : ?binary:string -> ?unix_files_sink:Unix_files_sink.t -> ?environment:(string * string) list - -> unit - -> [> `Node] t + -> kind + -> t (** Create a ["tezos-node"] executable. *) -val kind_string : [< kind] -> string +val kind_string : kind -> string (** Convert a [kind] to a [string]. *) -val default_binary : [< kind] t -> string +val default_binary : t -> string (** Get the path/name of the default binary for a given kind, e.g., ["tezos-admin-client"]. *) -val call : [< kind] t -> path:string -> string list -> unit Genspio.EDSL.t +val get : t -> string +(** The path to the executable. *) + +val call : t -> path:string -> string list -> unit Genspio.EDSL.t (** Build a [Genspio.EDSL.t] script to run a tezos command, the [~path] argument is used as a toplevel path for the unix-files event-sink (event-logging-framework) and for other local logging files. *) -val cli_term : ([< kind] as 'a) -> string -> 'a t Cmdliner.Term.t +val cli_term : kind -> string -> t Cmdliner.Term.t (** Build a [Cmdliner] term which creates tezos-executables, the second argument is a prefix of option names (e.g. ["tezos"] for the option ["--tezos-accuser-alpha-binary"]). *) diff --git a/src/lib_network_sandbox/tezos_node.ml b/src/lib_network_sandbox/tezos_node.ml index 1f9ecd914a4a9ff81821346a88eb9b835cf81193..56186a5cedc3c2ffd50d198b4ee74b47fd78a232 100644 --- a/src/lib_network_sandbox/tezos_node.ml +++ b/src/lib_network_sandbox/tezos_node.ml @@ -7,7 +7,7 @@ type t = ; p2p_port: int ; (* Ports: *) peers: int list - ; exec: [`Node] Tezos_executable.t + ; exec: Tezos_executable.t ; protocol: Tezos_protocol.t } let ef t = @@ -64,8 +64,7 @@ let start_script t ~config = [] in let tmp_config = tmp_file (config_file t ~config) in - check_sequence - ~verbosity:(`Announce (sprintf "Node-%s-start" t.id)) + check_sequence ~verbosity:`Output_all [ (let opts = config_options t ~config in ( "config-init" , if_seq @@ -77,7 +76,7 @@ let start_script t ~config = [ write_stdout ~path:tmp_config#path (exec [ "jq" - ; {jq|.p2p += { "limits" : { "connection-timeout" : 2, "swap-linger" : 2 } }|jq} + ; {jq|.p2p += { "limits" : { "maintenance-idle-time": 3, "connection-timeout" : 2, "swap-linger" : 2 } }|jq} ; config_file t ~config ]) ; call [str "mv"; tmp_config#path; str (config_file t ~config)] ] ) ; ( "ensure-identity" diff --git a/src/lib_network_sandbox/tezos_node.mli b/src/lib_network_sandbox/tezos_node.mli index 6b038b3d81105d3416585e751bf86615f6f8b49b..0754d1571abd9b21f3d3747c2342e9282be3bc0a 100644 --- a/src/lib_network_sandbox/tezos_node.mli +++ b/src/lib_network_sandbox/tezos_node.mli @@ -4,14 +4,14 @@ type t = private ; rpc_port: int ; p2p_port: int ; peers: int list - ; exec: [`Node] Tezos_executable.t + ; exec: Tezos_executable.t ; protocol: Tezos_protocol.t } val ef : t -> Easy_format.t val pp : Format.formatter -> t -> unit val make : - exec:[`Node] Tezos_executable.t + exec:Tezos_executable.t -> ?protocol:Tezos_protocol.t -> string -> expected_connections:int diff --git a/src/lib_network_sandbox/tezos_protocol.ml b/src/lib_network_sandbox/tezos_protocol.ml index 3b86c71f4f6942feac8e62217dc32587295577c0..178d89c3f12b461ee638dcab9037bfe83d5b3a65 100644 --- a/src/lib_network_sandbox/tezos_protocol.ml +++ b/src/lib_network_sandbox/tezos_protocol.ml @@ -192,6 +192,23 @@ module Account = struct | Key_pair k -> k.private_key end +module Voting_period = struct + type t = Tezos_client_alpha.Proto_alpha.Alpha_context.Voting_period.kind = + | Proposal + | Testing_vote + | Testing + | Promotion_vote + + let to_string (p : t) = + match + Tezos_data_encoding.Data_encoding.Json.construct + Tezos_client_alpha.Proto_alpha.Alpha_context.Voting_period + .kind_encoding p + with + | `String s -> s + | _other -> assert false +end + type t = { id: string ; bootstrap_accounts: (Account.t * Int64.t) list @@ -289,12 +306,18 @@ let ensure t ~config = | 0 -> return () | _other -> Lwt_exception.fail (Failure "sys.command non-zero") - ~attach:[("location", "Tezos_protocol.ensure")] + ~attach:[("location", `String_value "Tezos_protocol.ensure")] let cli_term () = let open Cmdliner in let open Term in - pure (fun remove_default_bas (`Time_between_blocks tbb) add_bootstraps -> + pure + (fun remove_default_bas + (`Blocks_per_voting_period bpvp) + (`Protocol_hash hashopt) + (`Time_between_blocks tbb) + add_bootstraps + -> let d = default () in let id = if add_bootstraps = [] && remove_default_bas = false then d.id @@ -307,12 +330,33 @@ let cli_term () = add_bootstraps @ if remove_default_bas then [] else d.bootstrap_accounts in - {d with id; bootstrap_accounts; time_between_blocks} ) + let blocks_per_voting_period = + match bpvp with Some v -> v | None -> d.blocks_per_voting_period + in + let hash = Option.value hashopt ~default:d.hash in + { d with + id + ; hash + ; bootstrap_accounts + ; time_between_blocks + ; blocks_per_voting_period } ) $ Arg.( value (flag (info ~doc:"Do not create any of the default bootstrap accounts." ["remove-default-bootstrap-accounts"]))) + $ Arg.( + pure (fun x -> `Blocks_per_voting_period x) + $ value + (opt (some int) None + (info + ["blocks-per-voting-period"] + ~doc:"Set the length of voting periods"))) + $ Arg.( + pure (fun x -> `Protocol_hash x) + $ value + (opt (some string) None + (info ["protocol-hash"] ~doc:"Set the (starting) protocol hash."))) $ Arg.( pure (fun x -> `Time_between_blocks x) $ value diff --git a/src/lib_network_sandbox/tezos_protocol.mli b/src/lib_network_sandbox/tezos_protocol.mli index f6ac171de07dc97a8c34ef31352c411bffe9d4ce..4a7f547608988d781be7c76192f4fb557bb15bd6 100644 --- a/src/lib_network_sandbox/tezos_protocol.mli +++ b/src/lib_network_sandbox/tezos_protocol.mli @@ -64,6 +64,16 @@ module Account : sig val private_key : t -> string end +module Voting_period : sig + type t = Tezos_client_alpha.Proto_alpha.Alpha_context.Voting_period.kind = + | Proposal + | Testing_vote + | Testing + | Promotion_vote + + val to_string : t -> string +end + (** [t] wraps bootstrap parameters for sandboxed protocols. *) type t = { id: string