From 0cfad894d7b3c1800c5d85116ddaf745767d931f Mon Sep 17 00:00:00 2001 From: Sebastien Mondet Date: Fri, 16 Aug 2019 13:32:28 -0400 Subject: [PATCH 1/6] =?UTF-8?q?Rename=20`bin=5Fflextesa`=20=E2=86=92=20`bi?= =?UTF-8?q?n=5Fsandbox`?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- .gitlab-ci.yml | 6 +++--- Makefile | 4 ++-- src/{bin_flextesa => bin_sandbox}/.ocamlformat | 0 src/{bin_flextesa => bin_sandbox}/command_accusations.ml | 0 .../command_daemons_protocol_change.ml | 0 src/{bin_flextesa => bin_sandbox}/command_ledger_baking.ml | 0 src/{bin_flextesa => bin_sandbox}/command_ledger_wallet.ml | 0 src/{bin_flextesa => bin_sandbox}/command_mini_network.ml | 0 src/{bin_flextesa => bin_sandbox}/command_prevalidation.ml | 0 src/{bin_flextesa => bin_sandbox}/command_voting.ml | 0 src/{bin_flextesa => bin_sandbox}/dune | 0 src/{bin_flextesa => bin_sandbox}/main.ml | 0 12 files changed, 5 insertions(+), 5 deletions(-) rename src/{bin_flextesa => bin_sandbox}/.ocamlformat (100%) rename src/{bin_flextesa => bin_sandbox}/command_accusations.ml (100%) rename src/{bin_flextesa => bin_sandbox}/command_daemons_protocol_change.ml (100%) rename src/{bin_flextesa => bin_sandbox}/command_ledger_baking.ml (100%) rename src/{bin_flextesa => bin_sandbox}/command_ledger_wallet.ml (100%) rename src/{bin_flextesa => bin_sandbox}/command_mini_network.ml (100%) rename src/{bin_flextesa => bin_sandbox}/command_prevalidation.ml (100%) rename src/{bin_flextesa => bin_sandbox}/command_voting.ml (100%) rename src/{bin_flextesa => bin_sandbox}/dune (100%) rename src/{bin_flextesa => bin_sandbox}/main.ml (100%) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 29a8ec3564d5..e995afc63a0e 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -230,7 +230,7 @@ integration:proto:sandbox: integration:sandboxes:voting: <<: *integration_definition script: - - ROOT_PATH=$PWD/flextesa-voting-demo-noops dune build @src/bin_flextesa/runtest_sandbox_voting_demo_noops + - ROOT_PATH=$PWD/flextesa-voting-demo-noops dune build @src/bin_sandbox/runtest_sandbox_voting_demo_noops artifacts: paths: - flextesa-voting-demo-noops @@ -241,7 +241,7 @@ integration:sandboxes:voting: integration:sandboxes:acc-baking: <<: *integration_definition script: - - ROOT_PATH=$PWD/flextesa-acc-sdb dune build @src/bin_flextesa/runtest_sandbox_accusations_simple_double_baking + - ROOT_PATH=$PWD/flextesa-acc-sdb dune build @src/bin_sandbox/runtest_sandbox_accusations_simple_double_baking artifacts: paths: - flextesa-acc-sdb @@ -251,7 +251,7 @@ integration:sandboxes:acc-baking: integration:sandboxes:acc-endorsement: <<: *integration_definition script: - - ROOT_PATH=$PWD/flextesa-acc-sde dune build @src/bin_flextesa/runtest_sandbox_accusations_simple_double_endorsing + - ROOT_PATH=$PWD/flextesa-acc-sde dune build @src/bin_sandbox/runtest_sandbox_accusations_simple_double_endorsing artifacts: paths: - flextesa-acc-sde diff --git a/Makefile b/Makefile index dd7fda758ec1..31b4580bb109 100644 --- a/Makefile +++ b/Makefile @@ -83,8 +83,8 @@ doc-html-and-linkcheck: doc-html @${MAKE} -C docs all build-sandbox: - @dune build src/bin_flextesa/main.exe - @cp _build/default/src/bin_flextesa/main.exe tezos-sandbox + @dune build src/bin_sandbox/main.exe + @cp _build/default/src/bin_sandbox/main.exe tezos-sandbox build-test: build-sandbox @dune build @buildtest diff --git a/src/bin_flextesa/.ocamlformat b/src/bin_sandbox/.ocamlformat similarity index 100% rename from src/bin_flextesa/.ocamlformat rename to src/bin_sandbox/.ocamlformat diff --git a/src/bin_flextesa/command_accusations.ml b/src/bin_sandbox/command_accusations.ml similarity index 100% rename from src/bin_flextesa/command_accusations.ml rename to src/bin_sandbox/command_accusations.ml diff --git a/src/bin_flextesa/command_daemons_protocol_change.ml b/src/bin_sandbox/command_daemons_protocol_change.ml similarity index 100% rename from src/bin_flextesa/command_daemons_protocol_change.ml rename to src/bin_sandbox/command_daemons_protocol_change.ml diff --git a/src/bin_flextesa/command_ledger_baking.ml b/src/bin_sandbox/command_ledger_baking.ml similarity index 100% rename from src/bin_flextesa/command_ledger_baking.ml rename to src/bin_sandbox/command_ledger_baking.ml diff --git a/src/bin_flextesa/command_ledger_wallet.ml b/src/bin_sandbox/command_ledger_wallet.ml similarity index 100% rename from src/bin_flextesa/command_ledger_wallet.ml rename to src/bin_sandbox/command_ledger_wallet.ml diff --git a/src/bin_flextesa/command_mini_network.ml b/src/bin_sandbox/command_mini_network.ml similarity index 100% rename from src/bin_flextesa/command_mini_network.ml rename to src/bin_sandbox/command_mini_network.ml diff --git a/src/bin_flextesa/command_prevalidation.ml b/src/bin_sandbox/command_prevalidation.ml similarity index 100% rename from src/bin_flextesa/command_prevalidation.ml rename to src/bin_sandbox/command_prevalidation.ml diff --git a/src/bin_flextesa/command_voting.ml b/src/bin_sandbox/command_voting.ml similarity index 100% rename from src/bin_flextesa/command_voting.ml rename to src/bin_sandbox/command_voting.ml diff --git a/src/bin_flextesa/dune b/src/bin_sandbox/dune similarity index 100% rename from src/bin_flextesa/dune rename to src/bin_sandbox/dune diff --git a/src/bin_flextesa/main.ml b/src/bin_sandbox/main.ml similarity index 100% rename from src/bin_flextesa/main.ml rename to src/bin_sandbox/main.ml -- GitLab From 3b360ffd2af989c8035d585cb0a08ff1c1e0062c Mon Sep 17 00:00:00 2001 From: Sebastien Mondet Date: Fri, 16 Aug 2019 13:43:13 -0400 Subject: [PATCH 2/6] Use vendored flextesa (at `357fd56b85`) --- .gitlab-ci.yml | 22 +- src/bin_sandbox/command_accusations.ml | 2 +- .../command_daemons_protocol_change.ml | 553 +++++-------- src/bin_sandbox/command_ledger_baking.ml | 2 +- src/bin_sandbox/command_ledger_wallet.ml | 2 +- src/bin_sandbox/command_mini_network.ml | 2 +- src/bin_sandbox/command_prevalidation.ml | 2 +- src/bin_sandbox/command_voting.ml | 736 ++++++------------ src/bin_sandbox/dune | 2 +- src/bin_sandbox/main.ml | 2 +- src/lib_network_sandbox/.ocamlformat | 11 - src/lib_network_sandbox/dune | 16 - src/lib_network_sandbox/interactive_test.mli | 196 ----- src/lib_network_sandbox/log_recorder.ml | 52 -- src/lib_network_sandbox/test_scenario.mli | 143 ---- .../tezos_admin_client.mli | 48 -- src/lib_network_sandbox/tezos_node.mli | 55 -- src/lib_network_sandbox/tezos_protocol.ml | 450 ----------- vendors/flextesa-lib/.ocamlformat | 1 + .../flextesa-lib}/console.ml | 185 ++--- .../flextesa-lib}/console.mli | 0 vendors/flextesa-lib/dump_files.ml | 29 + vendors/flextesa-lib/dump_files.mli | 23 + vendors/flextesa-lib/dune | 18 + vendors/flextesa-lib/experiments.ml | 98 +++ .../flextesa-lib/flextesa.opam | 9 +- .../flextesa-lib}/helpers.ml | 84 +- .../flextesa-lib}/helpers.mli | 0 .../flextesa-lib/interactive_mini_network.ml | 150 ++++ .../flextesa-lib}/interactive_test.ml | 527 ++++++------- vendors/flextesa-lib/interactive_test.mli | 200 +++++ .../flextesa-lib}/internal_pervasives.ml | 217 ++---- .../flextesa-lib}/kiln.ml | 78 +- .../flextesa-lib}/kiln.mli | 0 vendors/flextesa-lib/liquidity.ml | 346 ++++++++ vendors/flextesa-lib/liquidity.mli | 196 +++++ vendors/flextesa-lib/log_recorder.ml | 45 ++ .../flextesa-lib}/paths.ml | 0 .../flextesa-lib}/paths.mli | 0 .../flextesa-lib}/running_processes.ml | 149 ++-- .../flextesa-lib}/running_processes.mli | 0 vendors/flextesa-lib/test_api.ml | 107 +++ vendors/flextesa-lib/test_api.mli | 18 + .../flextesa-lib}/test_command_line.ml | 3 +- .../flextesa-lib}/test_command_line.mli | 0 .../flextesa-lib}/test_scenario.ml | 273 +++---- vendors/flextesa-lib/test_scenario.mli | 136 ++++ .../flextesa-lib}/tezos_admin_client.ml | 26 +- vendors/flextesa-lib/tezos_admin_client.mli | 47 ++ .../flextesa-lib}/tezos_client.ml | 328 +++----- .../flextesa-lib}/tezos_client.mli | 2 +- .../flextesa-lib}/tezos_daemon.ml | 3 +- .../flextesa-lib}/tezos_daemon.mli | 0 .../flextesa-lib}/tezos_executable.ml | 73 +- .../flextesa-lib}/tezos_executable.mli | 40 +- .../flextesa-lib}/tezos_node.ml | 142 ++-- vendors/flextesa-lib/tezos_node.mli | 46 ++ vendors/flextesa-lib/tezos_protocol.ml | 243 ++++++ .../flextesa-lib}/tezos_protocol.mli | 101 +-- 59 files changed, 2946 insertions(+), 3293 deletions(-) delete mode 100644 src/lib_network_sandbox/.ocamlformat delete mode 100644 src/lib_network_sandbox/dune delete mode 100644 src/lib_network_sandbox/interactive_test.mli delete mode 100644 src/lib_network_sandbox/log_recorder.ml delete mode 100644 src/lib_network_sandbox/test_scenario.mli delete mode 100644 src/lib_network_sandbox/tezos_admin_client.mli delete mode 100644 src/lib_network_sandbox/tezos_node.mli delete mode 100644 src/lib_network_sandbox/tezos_protocol.ml create mode 100644 vendors/flextesa-lib/.ocamlformat rename {src/lib_network_sandbox => vendors/flextesa-lib}/console.ml (64%) rename {src/lib_network_sandbox => vendors/flextesa-lib}/console.mli (100%) create mode 100644 vendors/flextesa-lib/dump_files.ml create mode 100644 vendors/flextesa-lib/dump_files.mli create mode 100644 vendors/flextesa-lib/dune create mode 100644 vendors/flextesa-lib/experiments.ml rename src/lib_network_sandbox/tezos-network-sandbox.opam => vendors/flextesa-lib/flextesa.opam (75%) rename {src/lib_network_sandbox => vendors/flextesa-lib}/helpers.ml (74%) rename {src/lib_network_sandbox => vendors/flextesa-lib}/helpers.mli (100%) create mode 100644 vendors/flextesa-lib/interactive_mini_network.ml rename {src/lib_network_sandbox => vendors/flextesa-lib}/interactive_test.ml (51%) create mode 100644 vendors/flextesa-lib/interactive_test.mli rename {src/lib_network_sandbox => vendors/flextesa-lib}/internal_pervasives.ml (70%) rename {src/lib_network_sandbox => vendors/flextesa-lib}/kiln.ml (67%) rename {src/lib_network_sandbox => vendors/flextesa-lib}/kiln.mli (100%) create mode 100644 vendors/flextesa-lib/liquidity.ml create mode 100644 vendors/flextesa-lib/liquidity.mli create mode 100644 vendors/flextesa-lib/log_recorder.ml rename {src/lib_network_sandbox => vendors/flextesa-lib}/paths.ml (100%) rename {src/lib_network_sandbox => vendors/flextesa-lib}/paths.mli (100%) rename {src/lib_network_sandbox => vendors/flextesa-lib}/running_processes.ml (71%) rename {src/lib_network_sandbox => vendors/flextesa-lib}/running_processes.mli (100%) create mode 100644 vendors/flextesa-lib/test_api.ml create mode 100644 vendors/flextesa-lib/test_api.mli rename {src/lib_network_sandbox => vendors/flextesa-lib}/test_command_line.ml (99%) rename {src/lib_network_sandbox => vendors/flextesa-lib}/test_command_line.mli (100%) rename {src/lib_network_sandbox => vendors/flextesa-lib}/test_scenario.ml (60%) create mode 100644 vendors/flextesa-lib/test_scenario.mli rename {src/lib_network_sandbox => vendors/flextesa-lib}/tezos_admin_client.ml (77%) create mode 100644 vendors/flextesa-lib/tezos_admin_client.mli rename {src/lib_network_sandbox => vendors/flextesa-lib}/tezos_client.ml (63%) rename {src/lib_network_sandbox => vendors/flextesa-lib}/tezos_client.mli (100%) rename {src/lib_network_sandbox => vendors/flextesa-lib}/tezos_daemon.ml (99%) rename {src/lib_network_sandbox => vendors/flextesa-lib}/tezos_daemon.mli (100%) rename {src/lib_network_sandbox => vendors/flextesa-lib}/tezos_executable.ml (50%) rename {src/lib_network_sandbox => vendors/flextesa-lib}/tezos_executable.mli (82%) rename {src/lib_network_sandbox => vendors/flextesa-lib}/tezos_node.ml (51%) create mode 100644 vendors/flextesa-lib/tezos_node.mli create mode 100644 vendors/flextesa-lib/tezos_protocol.ml rename {src/lib_network_sandbox => vendors/flextesa-lib}/tezos_protocol.mli (51%) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index e995afc63a0e..315cd25b8959 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -743,41 +743,41 @@ opam:67:tezos-tooling: variables: package: tezos-tooling -opam:68:tezos-version: +opam:68:flextesa: + <<: *opam_definition + variables: + package: flextesa + +opam:69:tezos-version: <<: *opam_definition variables: package: tezos-version -opam:69:tezos-protocol-alpha-tests: +opam:70:tezos-protocol-alpha-tests: <<: *opam_definition variables: package: tezos-protocol-alpha-tests -opam:70:tezos-alpha-test-helpers: +opam:71:tezos-alpha-test-helpers: <<: *opam_definition variables: package: tezos-alpha-test-helpers -opam:71:tezos-endorser-alpha: +opam:72:tezos-endorser-alpha: <<: *opam_definition variables: package: tezos-endorser-alpha -opam:72:tezos-accuser-alpha-commands: +opam:73:tezos-accuser-alpha-commands: <<: *opam_definition variables: package: tezos-accuser-alpha-commands -opam:73:tezos-baker-alpha: +opam:74:tezos-baker-alpha: <<: *opam_definition variables: package: tezos-baker-alpha -opam:74:tezos-network-sandbox: - <<: *opam_definition - variables: - package: tezos-network-sandbox - opam:75:tezos-signer: <<: *opam_definition variables: diff --git a/src/bin_sandbox/command_accusations.ml b/src/bin_sandbox/command_accusations.ml index 54e1fe58665a..41c750cdf9a2 100644 --- a/src/bin_sandbox/command_accusations.ml +++ b/src/bin_sandbox/command_accusations.ml @@ -1,4 +1,4 @@ -open Tezos_network_sandbox +open Flextesa open Internal_pervasives open Console diff --git a/src/bin_sandbox/command_daemons_protocol_change.ml b/src/bin_sandbox/command_daemons_protocol_change.ml index 2a6d5db7e6a9..f2f23bfc17ba 100644 --- a/src/bin_sandbox/command_daemons_protocol_change.ml +++ b/src/bin_sandbox/command_daemons_protocol_change.ml @@ -1,4 +1,4 @@ -open Tezos_network_sandbox +open Flextesa open Internal_pervasives open Console @@ -8,22 +8,15 @@ let wait_for_voting_period ?level_within_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_within_period - ~default:"" + sprintf "Waiting for voting period: `%s`%s" period_name + (Option.value_map level_within_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_within_period ~f:(fun lvl -> - Tezos_client.rpc - state - ~client - `Get + Tezos_client.rpc state ~client `Get ~path:"/chains/main/blocks/head/metadata" >>= fun json -> try @@ -34,32 +27,24 @@ let wait_for_voting_period ?level_within_period state ~client ~attempts period in return (voting_period_position >= lvl) with e -> - failf - "Cannot get level.voting_period_position: %s" - (Printexc.to_string e)) + failf "Cannot get level.voting_period_position: %s" + (Printexc.to_string e) ) >>= fun lvl_ok -> - Tezos_client.rpc - state - ~client - `Get + 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 + Tezos_client.successful_client_cmd state ~client ["show"; "voting"; "period"] >>= fun res -> - Console.say - state + Console.say state EF.( - desc_list - (wf "Voting period:") + desc_list (wf "Voting period:") [markdown_verbatim (String.concat ~sep:"\n" res#out)]) - >>= fun () -> return (`Not_done message)) + >>= 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 @@ -67,34 +52,19 @@ let run state ~protocol ~size ~base_port ~no_daemons_for ?external_peer_ports ~second_endorser_exec ~second_accuser_exec ~admin_exec ~new_protocol_path ~extra_dummy_proposals_batch_size ~extra_dummy_proposals_batch_levels ~waiting_attempts test_variant () = - Helpers.System_dependencies.precheck - state - `Or_fail + Helpers.System_dependencies.precheck state `Or_fail ~protocol_paths:[new_protocol_path] ~executables: - [ node_exec; - client_exec; - first_baker_exec; - first_endorser_exec; - first_accuser_exec; - second_baker_exec; - second_endorser_exec; - second_accuser_exec ] + [ 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 + Test_scenario.network_with_protocol ?external_peer_ports ~protocol ~size + ~base_port state ~node_exec ~client_exec >>= fun (nodes, protocol) -> - Tezos_client.rpc - state + Tezos_client.rpc state ~client:(Tezos_client.of_node (List.hd_exn nodes) ~exec:client_exec) - `Get - ~path:"/chains/main/chain_id" + `Get ~path:"/chains/main/chain_id" >>= fun chain_id_json -> let network_id = match chain_id_json with `String s -> s | _ -> assert false @@ -102,111 +72,78 @@ let run state ~protocol ~size ~base_port ~no_daemons_for ?external_peer_ports 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" ]) + [ 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 {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 + | 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 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 ] )) + ( 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 + let key, priv = Tezos_protocol.Account.(name acc, private_key acc) in Tezos_client.import_secret_key ~state client key priv >>= fun () -> - say - state + say state EF.( desc_list (haf "Registration-as-delegate:") - [ desc (af "Client:") (af "%S" client.Tezos_client.id); - desc (af "Key:") (af "%S" key) ]) + [ 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 + say state EF.( - desc_list - (haf "Starting daemons:") - [ desc (af "Client:") (af "%S" client.Tezos_client.id); - desc (af "Key:") (af "%S" key) ]) + 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 {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.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 + @ [ 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] ]) ; + (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] ]) ; (* 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. @@ -219,9 +156,7 @@ let run state ~protocol ~size ~base_port ~no_daemons_for ?external_peer_ports >>= 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 + 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 @@ -230,64 +165,47 @@ let run state ~protocol ~size ~base_port ~no_daemons_for ?external_peer_ports match protocols with | `A l when List.exists l ~f:(function `String h -> h = hash | _ -> false) -> - Console.say - state + Console.say state EF.( - wf - "Node `%s` already knows protocol `%s`." - nod.Tezos_node.id + 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 + Tezos_admin_client.inject_protocol admin state ~path:new_protocol_path >>= fun (_, new_protocol_hash) -> ( if new_protocol_hash = hash then - Console.say - state + Console.say state EF.( - wf - "Injected protocol `%s` in `%s`" - new_protocol_hash + wf "Injected protocol `%s` in `%s`" new_protocol_hash nod.Tezos_node.id) else - failf - "Injecting protocol %s failed (≠ %s)" - new_protocol_hash + failf "Injecting protocol %s failed (≠ %s)" new_protocol_hash hash ) - >>= fun () -> return (Some hash)) + >>= fun () -> return (Some hash) ) >>= fun prot_opt -> ( match prot_opt with - | Some s -> - return s - | None -> - failf "protocol injection problem?" ) + | 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 + 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)) + sprintf "http://localhost:%d" rpc_port )) ~bakers: - (List.map - protocol.Tezos_protocol.bootstrap_accounts + (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 + 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) ] + [ ( protocol.Tezos_protocol.hash + , first_baker_exec + , first_endorser_exec ) + ; (new_protocol_hash, second_baker_exec, second_endorser_exec) ] >>= fun () -> let msg = EF.( @@ -295,155 +213,106 @@ let run state ~protocol ~size ~base_port ~no_daemons_for ?external_peer_ports (shout "Kiln-Configuration DONE") (wf "Kiln was configured at `%s`" kiln_config.path)) in - Console.say state msg >>= fun () -> return msg) + Console.say state msg >>= fun () -> return msg ) >>= fun kiln_info_opt -> - Test_scenario.Queries.wait_for_all_levels_to_be - state - ~attempts:waiting_attempts - ~seconds:10. - nodes + Test_scenario.Queries.wait_for_all_levels_to_be state + ~attempts:waiting_attempts ~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 () -> - Interactive_test.Pauser.generic - state + 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." ] + [ 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:waiting_attempts - Proposal - ~level_within_period:3 + wait_for_voting_period state ~client:client_0 ~attempts:waiting_attempts + `Proposal ~level_within_period:3 >>= fun _ -> let submit_prop acc client hash = - Tezos_client.successful_client_cmd - state - ~client - [ "submit"; - "proposals"; - "for"; - Tezos_protocol.Account.name acc; - hash; - "--force" ] + Tezos_client.successful_client_cmd state ~client + [ "submit"; "proposals"; "for" + ; Tezos_protocol.Account.name acc + ; hash; "--force" ] >>= fun _ -> - Console.sayf - state + Console.sayf state Fmt.( fun ppf () -> pf ppf "%s voted for %s" (Tezos_protocol.Account.name acc) hash) in List_sequential.iter keys_and_daemons ~f:(fun (acc, client, _) -> - submit_prop acc client new_protocol_hash) + submit_prop acc client new_protocol_hash ) >>= fun () -> let make_dummy_protocol_hashes t tag = List.map (List.init extra_dummy_proposals_batch_size ~f:(fun s -> - sprintf "proto-%s-%d" tag s)) + sprintf "proto-%s-%d" tag s )) ~f:(fun s -> - (t, Tezos_crypto.Protocol_hash.(hash_string [s] |> to_b58check))) + (t, Tezos_crypto.Protocol_hash.(hash_string [s] |> to_b58check)) ) in let extra_dummy_protocols = List.bind extra_dummy_proposals_batch_levels ~f:(fun l -> - make_dummy_protocol_hashes l (sprintf "%d" l)) + make_dummy_protocol_hashes l (sprintf "%d" l) ) in - Console.say - state + Console.say state EF.( - wf - "Going to also vote for %s" + wf "Going to also vote for %s" (String.concat ~sep:", " (List.map extra_dummy_protocols ~f:snd))) >>= fun () -> - List_sequential.iteri - extra_dummy_protocols + List_sequential.iteri extra_dummy_protocols ~f:(fun nth (level, proto_hash) -> match List.nth keys_and_daemons (nth / 19) with | None -> failf "Too many dummy protocols Vs available voting power (%d)" nth | Some (acc, client, _) -> - wait_for_voting_period - state - ~client:client_0 - ~attempts:waiting_attempts - Proposal - ~level_within_period:level - >>= fun _ -> submit_prop acc client proto_hash) + wait_for_voting_period state ~client:client_0 + ~attempts:waiting_attempts `Proposal ~level_within_period:level + >>= fun _ -> submit_prop acc client proto_hash ) >>= fun () -> - wait_for_voting_period - state - ~client:client_0 - ~attempts:waiting_attempts - Testing_vote + wait_for_voting_period state ~client:client_0 ~attempts:waiting_attempts + `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" ] + Tezos_client.successful_client_cmd state ~client + [ "submit"; "ballot"; "for" + ; Tezos_protocol.Account.name acc + ; new_protocol_hash; "yea" ] >>= fun _ -> - Console.sayf - state + Console.sayf state Fmt.( fun ppf () -> - pf - ppf - "%s voted Yea to test %s" + pf ppf "%s voted Yea to test %s" (Tezos_protocol.Account.name acc) - new_protocol_hash)) + new_protocol_hash) ) >>= fun () -> - wait_for_voting_period - state - ~client:client_0 - ~attempts:waiting_attempts - Promotion_vote + wait_for_voting_period state ~client:client_0 ~attempts:waiting_attempts + `Promotion_vote >>= fun _ -> let protocol_switch_will_happen = match test_variant with - | `Full_upgrade -> - true - | `Nay_for_promotion -> - false + | `Full_upgrade -> true + | `Nay_for_promotion -> false in 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; - (if protocol_switch_will_happen then "yea" else "nay") ] + Tezos_client.successful_client_cmd state ~client + [ "submit"; "ballot"; "for" + ; Tezos_protocol.Account.name acc + ; new_protocol_hash + ; (if protocol_switch_will_happen then "yea" else "nay") ] >>= fun _ -> - Console.sayf - state + Console.sayf state Fmt.( fun ppf () -> - pf - ppf - "%s voted Yea to promote %s" + pf ppf "%s voted Yea to promote %s" (Tezos_protocol.Account.name acc) - new_protocol_hash)) + new_protocol_hash) ) >>= fun () -> - wait_for_voting_period - state - ~client:client_0 - ~attempts:waiting_attempts - Proposal + wait_for_voting_period state ~client:client_0 ~attempts:waiting_attempts + `Proposal >>= fun _ -> - Tezos_client.successful_client_cmd - state - ~client:client_0 + Tezos_client.successful_client_cmd state ~client:client_0 ["show"; "voting"; "period"] >>= fun res -> let protocol_to_wait_for = @@ -453,10 +322,7 @@ let run state ~protocol ~size ~base_port ~no_daemons_for ?external_peer_ports Helpers.wait_for state ~attempts:waiting_attempts ~seconds:4. (fun _ -> Console.say state EF.(wf "Checking actual protocol transition") >>= fun () -> - Tezos_client.rpc - state - ~client:client_0 - `Get + 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 @@ -465,85 +331,65 @@ let run state ~protocol ~size ~base_port ~no_daemons_for ?external_peer_ports if proto_hash <> protocol_to_wait_for then return (`Not_done - (sprintf - "Protocol not done: %s Vs %s" - proto_hash + (sprintf "Protocol not done: %s Vs %s" proto_hash protocol_to_wait_for)) - else return (`Done ())) + else return (`Done ()) ) >>= fun () -> - Interactive_test.Pauser.generic - state + Interactive_test.Pauser.generic state EF. - [ wf - "Test finished, protocol is now %s, things should keep baking." - protocol_to_wait_for; - markdown_verbatim (String.concat ~sep:"\n" res#out) ] + [ wf "Test finished, protocol is now %s, things should keep baking." + protocol_to_wait_for + ; markdown_verbatim (String.concat ~sep:"\n" res#out) ] ~force:true let cmd ~pp_error () = let open Cmdliner in let open Term in let variants = - [ ( "full-upgrade", - `Full_upgrade, - "Go through the whole voting process and do the protocol change." ); - ( "nay-for-promotion", - `Nay_for_promotion, - "Go through the whole voting process but vote Nay at the last period \ + [ ( "full-upgrade" + , `Full_upgrade + , "Go through the whole voting process and do the protocol change." ) + ; ( "nay-for-promotion" + , `Nay_for_promotion + , "Go through the whole voting process but vote Nay at the last period \ and hence stay on the same protocol." ) ] in - Test_command_line.Run_command.make - ~pp_error + Test_command_line.Run_command.make ~pp_error ( pure (fun size - base_port - (`Attempts waiting_attempts) - (`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) - (`Extra_dummy_proposals_batch_size - extra_dummy_proposals_batch_size) - (`Extra_dummy_proposals_batch_levels - extra_dummy_proposals_batch_levels) - generate_kiln_config - test_variant - state - -> + base_port + (`Attempts waiting_attempts) + (`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) + (`Extra_dummy_proposals_batch_size extra_dummy_proposals_batch_size) + (`Extra_dummy_proposals_batch_levels + extra_dummy_proposals_batch_levels) + generate_kiln_config + test_variant + 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 - test_variant - ~waiting_attempts + 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 test_variant ~waiting_attempts ~extra_dummy_proposals_batch_size ~extra_dummy_proposals_batch_levels in - (state, Interactive_test.Pauser.run_test ~pp_error state actual_test)) + (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.") @@ -553,32 +399,21 @@ let cmd ~pp_error () = $ Arg.( pure (fun n -> `Attempts n) $ value - (opt - int - 60 - (info - ["waiting-attempts"] + (opt int 60 + (info ["waiting-attempts"] ~doc: "Number of attempts done while waiting for voting periods"))) $ Arg.( pure (fun l -> `External_peers l) $ value - (opt_all - int - [] - (info - ["add-external-peer-port"] - ~docv:"PORT-NUMBER" + (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" + (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" @@ -593,20 +428,13 @@ let cmd ~pp_error () = $ Arg.( pure (fun p -> `Protocol_path p) $ required - (pos - 0 - (some string) - None - (info - [] - ~doc:"The protocol to inject and vote on." + (pos 0 (some string) None + (info [] ~doc:"The protocol to inject and vote on." ~docv:"PROTOCOL-PATH"))) $ Arg.( pure (fun l -> `Extra_dummy_proposals_batch_size l) $ value - (opt - int - 0 + (opt int 0 (info ["extra-dummy-proposals-batch-size"] ~docv:"NUMBER" @@ -614,9 +442,7 @@ let cmd ~pp_error () = $ Arg.( pure (fun x -> `Extra_dummy_proposals_batch_levels x) $ value - (opt - (list ~sep:',' int) - [] + (opt (list ~sep:',' int) [] (info ["extra-dummy-proposals-batch-levels"] ~docv:"NUMBER" @@ -626,8 +452,7 @@ let cmd ~pp_error () = $ Kiln.Configuration_directory.cli_term () $ Arg.( let doc = - sprintf - "Which variant of the test to run (one of {%s})" + sprintf "Which variant of the test to run (one of {%s})" ( List.map ~f:(fun (n, _, _) -> n) variants |> String.concat ~sep:", " ) in @@ -641,31 +466,31 @@ let cmd ~pp_error () = "Vote and Protocol-upgrade with bakers, endorsers, and accusers." in let man : Manpage.block list = - [ `S "DAEMONS-UPGRADE TEST"; - `P + [ `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 + round followed by a protocol change while all the daemons." + ; `P (sprintf "There are for now %d variants (see option `--test-variant`):" - (List.length variants)); - `Blocks + (List.length variants)) + ; `Blocks (List.concat_map variants ~f:(fun (n, _, desc) -> - [`Noblank; `P (sprintf "* `%s`: %s" n desc)])); - `P "The test is interactive-only:"; - `Blocks + [`Noblank; `P (sprintf "* `%s`: %s" n desc)] )) + ; `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 \ + 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 potential protocol switch has happened (and been \ + `--second-*` executables)." + ; "Once the potential protocol switch has happened (and been \ verified), the test re-enters an interactive prompt to let \ the user play with the protocol (the first or second one, \ depending on the `--test-variant` option)." ]) ] diff --git a/src/bin_sandbox/command_ledger_baking.ml b/src/bin_sandbox/command_ledger_baking.ml index 58c8ebf39d4d..4854539fa3e4 100644 --- a/src/bin_sandbox/command_ledger_baking.ml +++ b/src/bin_sandbox/command_ledger_baking.ml @@ -1,4 +1,4 @@ -open Tezos_network_sandbox +open Flextesa open Internal_pervasives let failf fmt = ksprintf (fun s -> fail (`Scenario_error s)) fmt diff --git a/src/bin_sandbox/command_ledger_wallet.ml b/src/bin_sandbox/command_ledger_wallet.ml index 988b9430cca5..9c448f9da268 100644 --- a/src/bin_sandbox/command_ledger_wallet.ml +++ b/src/bin_sandbox/command_ledger_wallet.ml @@ -1,4 +1,4 @@ -open Tezos_network_sandbox +open Flextesa open Internal_pervasives let failf fmt = ksprintf (fun s -> fail (`Scenario_error s)) fmt diff --git a/src/bin_sandbox/command_mini_network.ml b/src/bin_sandbox/command_mini_network.ml index 231d34c53788..85dee65b529f 100644 --- a/src/bin_sandbox/command_mini_network.ml +++ b/src/bin_sandbox/command_mini_network.ml @@ -1,4 +1,4 @@ -open Tezos_network_sandbox +open Flextesa open Internal_pervasives open Console diff --git a/src/bin_sandbox/command_prevalidation.ml b/src/bin_sandbox/command_prevalidation.ml index 67234a3b46d8..8a8f24f98039 100644 --- a/src/bin_sandbox/command_prevalidation.ml +++ b/src/bin_sandbox/command_prevalidation.ml @@ -1,4 +1,4 @@ -open Tezos_network_sandbox +open Flextesa open Internal_pervasives open Console diff --git a/src/bin_sandbox/command_voting.ml b/src/bin_sandbox/command_voting.ml index 564256df7a10..65d366d0b607 100644 --- a/src/bin_sandbox/command_voting.ml +++ b/src/bin_sandbox/command_voting.ml @@ -1,145 +1,95 @@ (* Semi-interactive test for voting *) -open Tezos_network_sandbox +open Flextesa open Internal_pervasives module Counter_log = Helpers.Counter_log let ledger_prompt_notice state ef = - Console.say - state + Console.say state EF.( - desc - (shout "Ledger-prompt") + desc (shout "Ledger-prompt") (list [ef; wf "Please hit “✔” on the ledger."])) let setup_baking_ledger state uri ~client = - Interactive_test.Pauser.generic - state + Interactive_test.Pauser.generic state EF. - [ wf "Setting up the ledger device %S" uri; - haf + [ wf "Setting up the ledger device %S" uri + ; haf "Please make sure the ledger is on the Baking app and quit (`q`) \ this prompt to continue." ] ~force:true >>= fun () -> let key_name = "ledgered" in let baker = Tezos_client.Keyed.make client ~key_name ~secret_key:uri in - ledger_prompt_notice - state + ledger_prompt_notice state EF.( wf "Importing %S in client `%s`. The ledger should be prompting for \ acknowledgment to provide the public key." - uri - client.Tezos_client.id) + uri client.Tezos_client.id) >>= fun () -> Tezos_client.Keyed.initialize state baker >>= fun _ -> - ledger_prompt_notice - state + ledger_prompt_notice state EF.( wf "Setting up %S for baking. The ledger should be showing the setup \ parameters (Address, Main chain, HWMs)." uri) >>= fun () -> - Tezos_client.successful_client_cmd - state - ~client - [ "setup"; - "ledger"; - "to"; - "bake"; - "for"; - key_name; - "--main-hwm"; - "0"; - "--test-hwm"; - "0" ] + Tezos_client.successful_client_cmd state ~client + [ "setup"; "ledger"; "to"; "bake"; "for"; key_name; "--main-hwm"; "0" + ; "--test-hwm"; "0" ] >>= fun _ -> return baker let failf fmt = ksprintf (fun s -> fail (`Scenario_error s)) fmt let transfer state ~client ~src ~dst ~amount = - Tezos_client.successful_client_cmd - state - ~client - [ "--wait"; - "none"; - "transfer"; - sprintf "%Ld" amount; - "from"; - src; - "to"; - dst; - "--fee"; - "0.05"; - "--burn-cap"; - "0.3" ] + Tezos_client.successful_client_cmd state ~client + [ "--wait"; "none"; "transfer"; sprintf "%Ld" amount; "from"; src; "to"; dst + ; "--fee"; "0.05"; "--burn-cap"; "0.3" ] let register state ~client ~dst = - Tezos_client.successful_client_cmd - state - ~client - [ "--wait"; - "none"; - "register"; - "key"; - dst; - "as"; - "delegate"; - "--fee"; - "0.05" ] + Tezos_client.successful_client_cmd state ~client + [ "--wait"; "none"; "register"; "key"; dst; "as"; "delegate"; "--fee" + ; "0.05" ] let bake_until_voting_period ?keep_alive_delegate state ~baker ~attempts period = let client = baker.Tezos_client.Keyed.client 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 + Tezos_client.rpc state ~client `Get ~path:"/chains/main/blocks/head/votes/current_period_kind" >>= function - | `String p when p = period_name -> - return (`Done (nth - 1)) + | `String p when p = period_name -> return (`Done (nth - 1)) | other -> Asynchronous_result.map_option keep_alive_delegate ~f:(fun dst -> - register state ~client ~dst >>= fun res -> return ()) + register state ~client ~dst >>= fun res -> return () ) >>= fun _ -> ksprintf (Tezos_client.Keyed.bake state baker) - "Baker %s bakes %d/%d waiting for %S voting period" - client.id - nth - attempts - period_name + "Baker %s bakes %d/%d waiting for %S voting period" client.id nth + attempts period_name >>= fun () -> - return (`Not_done (sprintf "Waiting for %S period" period_name))) + return (`Not_done (sprintf "Waiting for %S period" period_name)) ) let check_understood_protocols state ~chain ~client ~protocol_hash ~expect_clueless_client = Asynchronous_result.bind_on_result - (Tezos_client.successful_client_cmd - state - ~client + (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) + 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 ) + | 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) + | 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 @@ -147,50 +97,37 @@ let run state ~winner_path ~demo_path ~current_hash ~node_exec ~client_exec let default_attempts = 50 in Helpers.clear_root state >>= fun () -> - Helpers.System_dependencies.precheck - state - `Or_fail + 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 + Interactive_test.Pauser.generic state EF.[af "Ready to start"; af "Root path deleted."] >>= fun () -> - let (protocol, baker_0_account, baker_0_balance) = + let protocol, baker_0_account, baker_0_balance = 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 - hash; - time_between_blocks = [1; 0]; - bootstrap_accounts = + ( { d with + 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)); - }, - fst baker, - snd baker ) + if fst baker = n then (n, v) else (n, 1_000L) ) } + , fst baker + , snd baker ) in - Test_scenario.network_with_protocol - ~protocol - ~size - ~base_port - state - ~node_exec - ~client_exec + 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.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"] + @ [ 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)) ]) ; @@ -200,9 +137,7 @@ let run state ~winner_path ~demo_path ~current_hash ~node_exec ~client_exec Tezos_client.of_node ~exec:client_exec (List.nth_exn nodes n) in let baker_0 = - Tezos_client.Keyed.make - (client 0) - ~key_name:"baker-0" + Tezos_client.Keyed.make (client 0) ~key_name:"baker-0" ~secret_key:(Tezos_protocol.Account.private_key baker_0_account) in Tezos_client.Keyed.initialize state baker_0 @@ -210,7 +145,7 @@ let run state ~winner_path ~demo_path ~current_hash ~node_exec ~client_exec let level_counter = Counter_log.create () in let first_bakes = 5 in Loop.n_times first_bakes (fun nth -> - ksprintf (Tezos_client.Keyed.bake state baker_0) "initial-bake %d" nth) + ksprintf (Tezos_client.Keyed.bake state baker_0) "initial-bake %d" nth ) >>= fun () -> let initial_level = first_bakes + 1 in Counter_log.add level_counter "initial_level" initial_level ; @@ -220,53 +155,40 @@ let run state ~winner_path ~demo_path ~current_hash ~node_exec ~client_exec >>= fun () -> let account = Tezos_protocol.Account.of_name "special-baker" in let baker = - Tezos_client.Keyed.make - (client 0) + Tezos_client.Keyed.make (client 0) ~key_name:(Tezos_protocol.Account.name account) ~secret_key:(Tezos_protocol.Account.private_key account) in Tezos_client.Keyed.initialize state baker >>= fun _ -> return baker - | Some uri -> - setup_baking_ledger state ~client:(client 0) uri ) + | 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_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} + {baker_0 with client= winner_client} in let winner_special_baker = let open Tezos_client.Keyed in - {special_baker with client = winner_client} + {special_baker with client= winner_client} in - Interactive_test.Pauser.add_commands - state + Interactive_test.Pauser.add_commands state Interactive_test.Commands. - [ arbitrary_command_on_clients - state - ~command_names:["wc"; "winner-client"] - ?make_admin:None + [ arbitrary_command_on_clients state + ~command_names:["wc"; "winner-client"] ?make_admin:None ~clients:[winner_client] ] ; - Interactive_test.Pauser.generic - state + Interactive_test.Pauser.generic state EF.[wf "You can now try the new-client"] >>= fun () -> - Interactive_test.Pauser.add_commands - state + Interactive_test.Pauser.add_commands state Interactive_test.Commands. - [ arbitrary_command_on_clients - state - ~command_names:["baker"] - ~make_admin + [ arbitrary_command_on_clients state ~command_names:["baker"] ~make_admin ~clients:[special_baker.Tezos_client.Keyed.client] ] ; - transfer - state (* Tezos_client.successful_client_cmd state *) + transfer state (* Tezos_client.successful_client_cmd state *) ~client:(client 0) ~amount:(Int64.div baker_0_balance 2_000_000L) - ~src:"baker-0" - ~dst:special_baker.Tezos_client.Keyed.key_name + ~src:"baker-0" ~dst:special_baker.Tezos_client.Keyed.key_name >>= fun res -> - Console.say - state + Console.say state EF.( desc (wf "Successful transfer baker-0 -> special:") @@ -276,32 +198,20 @@ let run state ~winner_path ~demo_path ~current_hash ~node_exec ~client_exec Loop.n_times after_transfer_bakes (fun nth -> ksprintf (Tezos_client.Keyed.bake state baker_0) - "after-transfer-bake %d" - nth) + "after-transfer-bake %d" nth ) >>= fun () -> Counter_log.add level_counter "after-transfer-bakes" after_transfer_bakes ; - Test_scenario.Queries.wait_for_all_levels_to_be - state - ~attempts:default_attempts - ~seconds:8. - nodes + Test_scenario.Queries.wait_for_all_levels_to_be state + ~attempts:default_attempts ~seconds:8. nodes (`At_least (Counter_log.sum level_counter)) >>= fun () -> Asynchronous_result.map_option with_ledger ~f:(fun _ -> - ledger_prompt_notice state EF.(wf "Registering as delegate.")) + ledger_prompt_notice state EF.(wf "Registering as delegate.") ) >>= fun (_ : unit option) -> - Tezos_client.successful_client_cmd - state - ~client:(client 0) - [ "--wait"; - "none"; - "register"; - "key"; - special_baker.Tezos_client.Keyed.key_name; - "as"; - "delegate"; - "--fee"; - "0.5" ] + Tezos_client.successful_client_cmd state ~client:(client 0) + [ "--wait"; "none"; "register"; "key" + ; special_baker.Tezos_client.Keyed.key_name; "as"; "delegate"; "--fee" + ; "0.5" ] >>= fun _ -> let activation_bakes = let open Tezos_protocol in @@ -310,21 +220,15 @@ let run state ~winner_path ~demo_path ~current_hash ~node_exec ~client_exec Loop.n_times activation_bakes (fun nth -> ksprintf (Tezos_client.Keyed.bake state baker_0) - "Baking after new delegate registered: %d/%d" - nth - activation_bakes + "Baking after new delegate registered: %d/%d" nth activation_bakes >>= fun () -> - Tezos_client.successful_client_cmd - state - ~client:(client 0) + Tezos_client.successful_client_cmd state ~client:(client 0) ["rpc"; "get"; "/chains/main/blocks/head/helpers/baking_rights"] >>= fun res -> - Console.say - state + Console.say state EF.( - desc - (haf "Baking rights") - (markdown_verbatim (String.concat ~sep:"\n" res#out)))) + desc (haf "Baking rights") + (markdown_verbatim (String.concat ~sep:"\n" res#out))) ) >>= fun () -> Counter_log.add level_counter "activation-bakes" activation_bakes ; Tezos_client.Keyed.bake state special_baker "Baked by Special Baker™" @@ -336,22 +240,13 @@ let run state ~winner_path ~demo_path ~current_hash ~node_exec ~client_exec the next one *) 3 * protocol.blocks_per_voting_period) in - bake_until_voting_period - state - ~baker:special_baker - ~attempts - Proposal + bake_until_voting_period state ~baker:special_baker ~attempts `Proposal ~keep_alive_delegate:baker_0.key_name >>= fun extra_bakes_waiting_for_proposal_period -> - Counter_log.add - level_counter - "wait-for-proposal-period" + Counter_log.add level_counter "wait-for-proposal-period" extra_bakes_waiting_for_proposal_period ; - Test_scenario.Queries.wait_for_all_levels_to_be - state - ~attempts:default_attempts - ~seconds:8. - nodes + Test_scenario.Queries.wait_for_all_levels_to_be state + ~attempts:default_attempts ~seconds:8. nodes (`At_least (Counter_log.sum level_counter)) >>= fun () -> let admin_0 = Tezos_admin_client.of_client ~exec:admin_exec (client 0) in @@ -362,188 +257,135 @@ let run state ~winner_path ~demo_path ~current_hash ~node_exec ~client_exec 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" - (Filename.quote path) - (Filename.quote tmpdir) + Running_processes.run_successful_cmdf state "cp -L -R %s %s" + (Filename.quote path) (Filename.quote tmpdir) >>= fun _ -> ( if make_different then - Running_processes.run_successful_cmdf - state - "echo '(* Protocol %s *)' >> %s/main.mli" - name - (Filename.quote tmpdir) + 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 + Interactive_test.Pauser.generic state EF. - [ af "Just injected %s (%s): %s" name path hash; - markdown_verbatim (String.concat ~sep:"\n" res#out) ] + [ af "Just injected %s (%s): %s" name path hash + ; markdown_verbatim (String.concat ~sep:"\n" res#out) ] >>= fun () -> return hash in make_and_inject_protocol "winner" winner_path >>= fun winner_hash -> - make_and_inject_protocol - ~make_different:(winner_path = demo_path) - "demo" + 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 - Interactive_test.Pauser.generic - state + Interactive_test.Pauser.generic state EF. - [ af "Network up"; - desc (haf "Protcols") + [ af "Network up" + ; desc (haf "Protcols") @@ list (List.map after_injections_protocols ~f:(fun p -> - af - "`%s` (%s)" - p + af "`%s` (%s)" p ( if List.mem default_protocols p ~equal:String.equal then "previously known" else match p with - | _ when p = winner_hash -> - "injected winner" - | _ when p = demo_hash -> - "injected demo" - | _ -> - "injected unknown" ))) ] + | _ when p = winner_hash -> "injected winner" + | _ when p = demo_hash -> "injected demo" + | _ -> "injected unknown" ) )) ] >>= fun () -> Asynchronous_result.map_option with_ledger ~f:(fun _ -> - Interactive_test.Pauser.generic - state + Interactive_test.Pauser.generic state EF. - [ af "About to VOTE"; - haf "Please switch to the Wallet app and quit (`q`) this prompt." + [ af "About to VOTE" + ; haf "Please switch to the Wallet app and quit (`q`) this prompt." ] - ~force:true) + ~force:true ) >>= fun (_ : unit option) -> let submit_proposals baker props = Asynchronous_result.map_option with_ledger ~f:(fun _ -> - ledger_prompt_notice - state + ledger_prompt_notice state EF.( - wf - "Submitting proposal%s: %s" + wf "Submitting proposal%s: %s" (if List.length props = 1 then "" else "s") - (String.concat ~sep:", " props))) + (String.concat ~sep:", " props)) ) >>= fun _ -> - Tezos_client.successful_client_cmd - state + Tezos_client.successful_client_cmd state ~client:baker.Tezos_client.Keyed.client (["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 to_submit_first + | false -> submit_proposals special_baker to_submit_first | true -> List_sequential.iter to_submit_first ~f:(fun one -> - submit_proposals special_baker [one]) ) + submit_proposals special_baker [one] ) ) >>= fun () -> - Tezos_client.successful_client_cmd - state - ~client:baker_0.client + Tezos_client.successful_client_cmd state ~client:baker_0.client ["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 + bake_until_voting_period state ~baker:baker_0 + ~attempts:protocol.blocks_per_voting_period `Testing_vote ~keep_alive_delegate:special_baker.key_name >>= fun extra_bakes_waiting_for_testing_vote_period -> - Counter_log.add - level_counter - "wait-for-testing-vote-period" + Counter_log.add level_counter "wait-for-testing-vote-period" extra_bakes_waiting_for_testing_vote_period ; - Test_scenario.Queries.wait_for_all_levels_to_be - state - ~attempts:default_attempts - ~seconds:8. - nodes + Test_scenario.Queries.wait_for_all_levels_to_be state + ~attempts:default_attempts ~seconds:8. nodes (`At_least (Counter_log.sum level_counter)) >>= fun () -> Helpers.wait_for state ~attempts:default_attempts ~seconds:2. (fun nth -> - Tezos_client.rpc - state - ~client:(client 1) - `Get + 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_hash then return (`Not_done - (sprintf - "Waiting for current_proposal_json to be %s (%s)" + (sprintf "Waiting for current_proposal_json to be %s (%s)" winner_hash Ezjsonm.(to_string (wrap current_proposal_json)))) - else return (`Done ())) + else return (`Done ()) ) >>= fun () -> - Tezos_client.successful_client_cmd - state - ~client:baker_0.client + Tezos_client.successful_client_cmd state ~client:baker_0.client ["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_hash)) + ledger_prompt_notice state + EF.(wf "Submitting “Yes” ballot for %S" winner_hash) ) >>= fun (_ : unit option) -> - Tezos_client.successful_client_cmd - state - ~client:special_baker.client + Tezos_client.successful_client_cmd state ~client:special_baker.client ["submit"; "ballot"; "for"; special_baker.key_name; winner_hash; "yay"] >>= fun _ -> - Interactive_test.Pauser.generic - state + Interactive_test.Pauser.generic state EF.[af "Ballots are in (not baked though)"] >>= fun () -> - bake_until_voting_period - state - ~baker:baker_0 + bake_until_voting_period state ~baker:baker_0 ~attempts:(1 + protocol.blocks_per_voting_period) - ~keep_alive_delegate:special_baker.key_name - Testing + ~keep_alive_delegate:special_baker.key_name `Testing >>= fun extra_bakes_waiting_for_testing_period -> - Counter_log.add - level_counter - "wait-for-testing-period" + Counter_log.add level_counter "wait-for-testing-period" extra_bakes_waiting_for_testing_period ; - Test_scenario.Queries.wait_for_all_levels_to_be - state - ~attempts:default_attempts - ~seconds:8. - nodes + Test_scenario.Queries.wait_for_all_levels_to_be state + ~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 + 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 + Interactive_test.Pauser.generic state EF. - [ af "About to bake on the test chain."; - haf + [ af "About to bake on the test chain." + ; haf "Please switch back to the Baking app and quit (`q`) \ this prompt." ] - ~force:true) + ~force:true ) >>= fun (_ : unit option) -> let testing_bakes = 5 in Loop.n_times testing_bakes (fun ith -> @@ -551,39 +393,25 @@ let run state ~winner_path ~demo_path ~current_hash ~node_exec ~client_exec 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)) + 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 + 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 + Interactive_test.Pauser.generic state EF.[wf "Testing period, with proper winner-client, have fun."] >>= fun () -> return () | `Expected_misunderstanding -> - Console.say - state + Console.say state EF.(wf "Winner-Client cannot bake on test chain (expected)") | `Failure_to_understand -> - failf "Winner-Client cannot bake on test chain!") + 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 + Tezos_client.rpc state ~client:(client 1) `Get ~path:"/chains/main/blocks/head/metadata" >>= fun metadata_json -> try @@ -591,8 +419,7 @@ let run state ~winner_path ~demo_path ~current_hash ~node_exec ~client_exec Jqo.field metadata_json ~k:"test_chain_status" |> Jqo.field ~k:"protocol" with - | `String s when s = winner_hash -> - return (`Done ()) + | `String s when s = winner_hash -> return (`Done ()) | other -> return (`Not_done @@ -600,134 +427,94 @@ let run state ~winner_path ~demo_path ~current_hash ~node_exec ~client_exec with e -> return (`Not_done - (sprintf - "Cannot get test-chain protocol: %s → %s" + (sprintf "Cannot get test-chain protocol: %s → %s" (Exn.to_string e) - Ezjsonm.(to_string (wrap metadata_json))))) + Ezjsonm.(to_string (wrap metadata_json)))) ) >>= fun () -> - bake_until_voting_period - state - ~baker:baker_0 + bake_until_voting_period state ~baker:baker_0 ~attempts:(1 + protocol.blocks_per_voting_period) - ~keep_alive_delegate:special_baker.key_name - Promotion_vote + ~keep_alive_delegate:special_baker.key_name `Promotion_vote >>= fun extra_bakes_waiting_for_promotion_period -> - Counter_log.add - level_counter - "wait-for-promotion-period" + Counter_log.add level_counter "wait-for-promotion-period" extra_bakes_waiting_for_promotion_period ; - Test_scenario.Queries.wait_for_all_levels_to_be - state - ~attempts:default_attempts - ~seconds:8. - nodes + Test_scenario.Queries.wait_for_all_levels_to_be state + ~attempts:default_attempts ~seconds:8. nodes (`At_least (Counter_log.sum level_counter)) >>= fun () -> Interactive_test.Pauser.generic state EF.[haf "Before ballots"] >>= fun () -> - Tezos_client.successful_client_cmd - state - ~client:baker_0.client + Tezos_client.successful_client_cmd state ~client:baker_0.client ["submit"; "ballot"; "for"; baker_0.key_name; winner_hash; "yay"] >>= fun _ -> Asynchronous_result.map_option with_ledger ~f:(fun _ -> - Interactive_test.Pauser.generic - state + Interactive_test.Pauser.generic state EF. - [ af "About to cast approval ballot."; - haf + [ 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_hash)) + ledger_prompt_notice state + EF.(wf "Submitting “Yes” ballot for %S" winner_hash) ) >>= fun (_ : unit option) -> - Tezos_client.successful_client_cmd - state - ~client:special_baker.client + Tezos_client.successful_client_cmd state ~client:special_baker.client ["submit"; "ballot"; "for"; special_baker.key_name; winner_hash; "yay"] >>= fun _ -> - Interactive_test.Pauser.generic - state + Interactive_test.Pauser.generic state EF.[af "Final ballot(s) are in (not baked though)"] >>= fun () -> let ballot_bakes = 1 in Loop.n_times ballot_bakes (fun _ -> - Tezos_client.Keyed.bake state baker_0 "Baking the promotion vote ballots") + Tezos_client.Keyed.bake state baker_0 "Baking the promotion vote ballots" + ) >>= fun () -> Counter_log.add level_counter "bake-the-ballots" ballot_bakes ; - Tezos_client.successful_client_cmd - state - ~client:(client 0) + Tezos_client.successful_client_cmd state ~client:(client 0) ["list"; "understood"; "protocols"] >>= fun client_protocols_result -> - Interactive_test.Pauser.generic - state + Interactive_test.Pauser.generic state EF. - [ af "Final ballot(s) are baked in."; - af - "The client `%s` understands the following protocols: %s" + [ af "Final ballot(s) are baked in." + ; af "The client `%s` understands the following protocols: %s" Tezos_executable.( Option.value ~default:(default_binary client_exec) client_exec.binary) (String.concat ~sep:", " client_protocols_result#out) ] >>= fun () -> - Helpers.wait_for - state - ~seconds:0.5 - ~attempts:(1 + protocol.blocks_per_voting_period) - (fun nth -> + Helpers.wait_for state ~seconds:0.5 + ~attempts:(1 + protocol.blocks_per_voting_period) (fun nth -> let client = baker_0.client in - Running_processes.run_successful_cmdf - state - "curl http://localhost:%d/chains/main/blocks/head/metadata" - client.port + Running_processes.run_successful_cmdf state + "curl http://localhost:%d/chains/main/blocks/head/metadata" client.port >>= fun curl_res -> 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_hash -> - return (`Done (nth - 1)) + | `String p when p = winner_hash -> return (`Done (nth - 1)) | other -> - transfer - state - ~client - ~amount:1L + transfer state ~client ~amount:1L ~src:baker_0.Tezos_client.Keyed.key_name ~dst:special_baker.Tezos_client.Keyed.key_name >>= fun _ -> ksprintf (Tezos_client.Keyed.bake state baker_0) - "Baker %s bakes %d/%d waiting for next protocol: %S" - client.id - nth - attempts - winner_hash + "Baker %s bakes %d/%d waiting for next protocol: %S" client.id nth + attempts winner_hash >>= fun () -> return (`Not_done - (sprintf - "Waiting for next_protocol: %S (≠ %s)" - winner_hash - Ezjsonm.(to_string (wrap other))))) + (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" + Counter_log.add level_counter "wait-for-next-protocol" extra_bakes_waiting_for_next_protocol ; - check_understood_protocols - state - ~client:winner_client - ~chain:"main" - ~protocol_hash:winner_hash - ~expect_clueless_client:clueless_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 + Console.say state EF.( wf "As expected, the client does not know about %s" winner_hash) | `Failure_to_understand -> @@ -737,71 +524,53 @@ let run state ~winner_path ~demo_path ~current_hash ~node_exec ~client_exec >>= fun () -> (* This actually depends on the protocol upgrade. *) Asynchronous_result.bind_on_result - (Tezos_client.successful_client_cmd - state - ~client:winner_client + (Tezos_client.successful_client_cmd state ~client:winner_client ["upgrade"; "baking"; "state"]) ~f:(function - | Ok _ -> - return () + | Ok _ -> return () | Error _ -> - Console.say - state + Console.say state EF.( - desc - (shout "Warning") + desc (shout "Warning") (wf "Command `upgrade baking state` failed, but we \ - keep going with the baking."))) + keep going with the baking.")) ) >>= fun () -> Asynchronous_result.map_option with_ledger ~f:(fun _ -> - Interactive_test.Pauser.generic - state + Interactive_test.Pauser.generic state EF. - [ af "About to bake on the new winning protocol."; - haf + [ 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` *)) + (* USB thing is often slower than humans hitting `q` *) ) >>= fun (_ : unit option) -> - Tezos_client.Keyed.bake - state - winner_baker_0 + 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 + Tezos_client.Keyed.bake state winner_special_baker "Second bake on new protocol !!" >>= fun () -> - Counter_log.incr - level_counter + Counter_log.incr level_counter "special-baker-bakes-on-new-protocol" ; - Tezos_client.rpc - state - ~client:winner_client - `Get + 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 () + | `String p when p = winner_hash -> return () | other -> - failf - "Protocol is not `%s` but `%s`" - winner_hash - Ezjsonm.(to_string (wrap other)) )) + failf "Protocol is not `%s` but `%s`" winner_hash + Ezjsonm.(to_string (wrap other)) ) ) >>= fun () -> - Interactive_test.Pauser.generic - state + Interactive_test.Pauser.generic state EF. - [ haf "End of the Voting test: SUCCESS \\o/"; - desc + [ 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)) ] >>= fun () -> return () @@ -809,64 +578,40 @@ let run state ~winner_path ~demo_path ~current_hash ~node_exec ~client_exec let cmd ~pp_error () = let open Cmdliner in let open Term in - Test_command_line.Run_command.make - ~pp_error + Test_command_line.Run_command.make ~pp_error ( pure (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) - state - -> - ( state, - Interactive_test.Pauser.run_test - state - ~pp_error - (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) )) + 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) + state + -> + ( state + , Interactive_test.Pauser.run_test state ~pp_error + (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" + (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.( pure Filename.dirname $ required - (pos - 1 - (some string) - None - (info - [] - ~docv:"LOSER-PROTOCOL-PATH" + (pos 1 (some string) None + (info [] ~docv:"LOSER-PROTOCOL-PATH" ~doc: "The protocol to inject and down-vote, e.g. \ `./src/bin_client/test/proto_test_injection/TEZOS_PROTOCOL` \ @@ -889,28 +634,19 @@ let cmd ~pp_error () = $ Arg.( pure (fun p -> `Hash p) $ value - (opt - (some string) - None - (info - ["current-hash"] + (opt (some string) None + (info ["current-hash"] ~doc:"The hash to advertise as the current protocol."))) $ Arg.( pure (fun p -> `Base_port p) $ value - (opt - int - 46_000 + (opt int 46_000 (info ["base-port"] ~doc:"Base port number to build upon."))) $ Arg.( pure (fun x -> `With_ledger x) $ value - (opt - (some string) - None - (info - ["with-ledger"] - ~docv:"ledger://..." + (opt (some string) None + (info ["with-ledger"] ~docv:"ledger://..." ~doc: "Do the test with a Ledger Nano device as one of the \ bakers/voters."))) @@ -918,43 +654,39 @@ let cmd ~pp_error () = pure (fun x -> `Serialize_proposals x) $ value (flag - (info - ["serialize-proposals"] + (info ["serialize-proposals"] ~doc: "Run the proposals one-by-one instead of all together \ (preferred by the Ledger)."))) $ Test_command_line.cli_state ~name:"voting" () ) (let doc = "Sandbox network with a full round of voting." in let man : Manpage.block list = - [ `S "VOTING TEST"; - `P + [ `S "VOTING TEST" + ; `P "This command provides a test which uses a network sandbox to \ perform a full round of protocol vote and upgrade, including \ voting and baking on the test chain with or without a Ledger Nano \ - device."; - `P "There are two main test behaviors:"; - `P + device."; `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 + 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 + 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 + 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. In this case, the option \ diff --git a/src/bin_sandbox/dune b/src/bin_sandbox/dune index 6b7731425927..484b5a32435d 100644 --- a/src/bin_sandbox/dune +++ b/src/bin_sandbox/dune @@ -1,6 +1,6 @@ (executables (names main) - (libraries tezos-network-sandbox) + (libraries flextesa) (flags (:standard -w -9-27-30-32-40@8 -safe-string))) (alias diff --git a/src/bin_sandbox/main.ml b/src/bin_sandbox/main.ml index 79e992086f8c..42fd2c53b816 100644 --- a/src/bin_sandbox/main.ml +++ b/src/bin_sandbox/main.ml @@ -1,4 +1,4 @@ -open Tezos_network_sandbox +open Flextesa open Internal_pervasives module Small_utilities = struct diff --git a/src/lib_network_sandbox/.ocamlformat b/src/lib_network_sandbox/.ocamlformat deleted file mode 100644 index 9d2a5a5f36ac..000000000000 --- a/src/lib_network_sandbox/.ocamlformat +++ /dev/null @@ -1,11 +0,0 @@ -wrap-fun-args=false -let-binding-spacing=compact -field-space=loose -break-separators=after-and-docked -sequence-style=separator -doc-comments=before -margin=80 -module-item-spacing=sparse -parens-tuple=always -parens-tuple-patterns=always -break-string-literals=newlines-and-wrap diff --git a/src/lib_network_sandbox/dune b/src/lib_network_sandbox/dune deleted file mode 100644 index 78fb620febd9..000000000000 --- a/src/lib_network_sandbox/dune +++ /dev/null @@ -1,16 +0,0 @@ -(library - (name tezos_network_sandbox) - (public_name tezos-network-sandbox) - (flags (:standard -open Tezos_protocol_alpha - -open Tezos_client_alpha)) - (libraries - lwt.unix - cmdliner - easy-format - dum - base - genspio - ezjsonm - tezos-signer-backends.unix - tezos-client-alpha)) - diff --git a/src/lib_network_sandbox/interactive_test.mli b/src/lib_network_sandbox/interactive_test.mli deleted file mode 100644 index 69c1719e339b..000000000000 --- a/src/lib_network_sandbox/interactive_test.mli +++ /dev/null @@ -1,196 +0,0 @@ -(** Tools to manage interactivity in test scenarios. *) - -open Internal_pervasives - -(** Implementations of common {!Console.Prompt.item}. *) -module Commands : sig - val cmdline_fail : - ( 'a, - Format.formatter, - unit, - ('b, [> `Command_line of string]) Asynchronous_result.t ) - format4 -> - 'a - - val no_args : - 'a list -> (unit, [> `Command_line of string]) Asynchronous_result.t - - val flag : string -> Sexplib0.Sexp.t list -> bool - - val unit_loop_no_args : - Easy_format.t -> - string list -> - (unit -> - (unit, [`Command_line of string | `Lwt_exn of exn]) Asynchronous_result.t) -> - Console.Prompt.item - - val du_sh_root : - < application_name : string - ; console : Console.t - ; paths : Paths.t - ; runner : Running_processes.State.t - ; .. > -> - Console.Prompt.item - - val processes : - < application_name : string - ; console : Console.t - ; runner : Running_processes.State.t - ; .. > -> - Console.Prompt.item - - val curl : - ?jq:string -> - < application_name : string - ; console : Console.t - ; paths : Paths.t - ; runner : Running_processes.State.t - ; .. > -> - port:int -> - path:string -> - ( [> `Error | `Success of string list], - [> `Lwt_exn of exn] ) - Asynchronous_result.t - - val curl_unit_display : - ?jq:string -> - < application_name : string - ; console : Console.t - ; paths : Paths.t - ; runner : Running_processes.State.t - ; .. > -> - string list -> - default_port:int -> - path:string -> - doc:string -> - Console.Prompt.item - - val curl_metadata : - < application_name : string - ; console : Console.t - ; paths : Paths.t - ; runner : Running_processes.State.t - ; .. > -> - default_port:int -> - Console.Prompt.item - - val curl_level : - < application_name : string - ; console : Console.t - ; paths : Paths.t - ; runner : Running_processes.State.t - ; .. > -> - default_port:int -> - Console.Prompt.item - - val curl_baking_rights : - < application_name : string - ; console : Console.t - ; paths : Paths.t - ; runner : Running_processes.State.t - ; .. > -> - default_port:int -> - Console.Prompt.item - - val all_levels : - < application_name : string - ; console : Console.t - ; paths : Paths.t - ; runner : Running_processes.State.t - ; .. > -> - nodes:Tezos_node.t list -> - Console.Prompt.item - - val show_process : - < application_name : string - ; console : Console.t - ; paths : Paths.t - ; runner : Running_processes.State.t - ; .. > -> - Console.Prompt.item - - val kill_all : - < runner : Running_processes.State.t ; .. > -> Console.Prompt.item - - val secret_keys : - < application_name : string ; console : Console.t ; .. > -> - protocol:Tezos_protocol.t -> - Console.Prompt.item - - val arbitrary_command_on_clients : - ?make_admin:(Tezos_client.t -> Tezos_admin_client.t) -> - ?command_names:string list -> - < application_name : string - ; console : Console.t - ; paths : Paths.t - ; runner : Running_processes.State.t - ; .. > -> - clients:Tezos_client.t list -> - Console.Prompt.item - - val all_defaults : - < application_name : string - ; console : Console.t - ; paths : Paths.t - ; runner : Running_processes.State.t - ; .. > -> - nodes:Tezos_node.t list -> - Console.Prompt.item list -end - -(** Configurable (through {!Cmdliner.Term.t}) interactivity of - test-scenarios. *) -module Interactivity : sig - type t = [`Full | `None | `On_error | `At_end] - - val pause_on_error : < test_interactivity : t ; .. > -> bool - - val pause_on_success : < test_interactivity : t ; .. > -> bool - - val is_interactive : < test_interactivity : t ; .. > -> bool - - val cli_term : ?default:t -> unit -> t Cmdliner.Term.t -end - -(** A {!Pauser.t} is tool to include optional prompting pauses in - test-scenarios. *) -module Pauser : sig - type t = private { - mutable extra_commands : Console.Prompt.item list; - default_end : [`Sleep of float]; - } - - val make : ?default_end:[`Sleep of float] -> Console.Prompt.item list -> t - - (** Add commands to the current pauser. *) - val add_commands : < pauser : t ; .. > -> Console.Prompt.item list -> unit - - (** Pause the test according to [state#interactivity] (overridden - with [~force:true]), the pause displays the list of - {!Easy_format.t}s and prompts the user for commands (see - {!add_commands}). *) - val generic : - < application_name : string - ; console : Console.t - ; pauser : t - ; test_interactivity : Interactivity.t - ; .. > -> - ?force:bool -> - Easy_format.t list -> - (unit, [> `Lwt_exn of exn]) Asynchronous_result.t - - (** Run a test-scenario and deal with potential errors according - to [state#test_interactivity]. *) - val run_test : - < application_name : string - ; console : Console.t - ; paths : Paths.t - ; pauser : t - ; runner : Running_processes.State.t - ; test_interactivity : Interactivity.t - ; .. > -> - (unit -> (unit, ([> `Lwt_exn of exn] as 'errors)) Asynchronous_result.t) -> - pp_error:(Format.formatter -> 'errors -> unit) -> - unit -> - (unit, 'errors) Asynchronous_result.t -end diff --git a/src/lib_network_sandbox/log_recorder.ml b/src/lib_network_sandbox/log_recorder.ml deleted file mode 100644 index ca82d55ff918..000000000000 --- a/src/lib_network_sandbox/log_recorder.ml +++ /dev/null @@ -1,52 +0,0 @@ -open Internal_pervasives - -module Operations = struct - (* This is likely a temporary module, which will be obsoleted by a - more general framework. *) - type t = { - mutable operations : - [ `Bake of string * string * string list - | `Endorse of string * string * string list - | `Transfer of string * string * string * string list ] - list; - } - - let make () = {operations = []} - - let from_state state : t = state#operations_log - - let show_all state = - let t = from_state state in - Console.Prompt.unit_and_loop - EF.(af "Show all manual operations") - ["ao"; "all-ops"; "all-operations"] - (fun _ -> - Console.say - state - EF.( - desc_list - (haf "Operations:") - (List.rev_map t.operations ~f:(function - | `Transfer (cli, msg, dest, res) -> - desc_list - (haf "Transfer: %S" cli) - [ af "→ %s" msg; - af "dest: %s" dest; - ocaml_string_list res ] - | `Endorse (n, msg, res) -> - desc_list - (haf "Node-endorsed: %S" n) - [af "→ %s" msg; ocaml_string_list res] - | `Bake (n, msg, res) -> - desc_list - (haf "Node-baked: %S" n) - [af "→ %s" msg; ocaml_string_list res])))) - - let bake state ~client ~output msg = - let t = from_state state in - t.operations <- `Bake (client, msg, output) :: t.operations - - let endorse state ~client ~output msg = - let t = from_state state in - t.operations <- `Endorse (client, msg, output) :: t.operations -end diff --git a/src/lib_network_sandbox/test_scenario.mli b/src/lib_network_sandbox/test_scenario.mli deleted file mode 100644 index 90f9121a421a..000000000000 --- a/src/lib_network_sandbox/test_scenario.mli +++ /dev/null @@ -1,143 +0,0 @@ -(** Build and manage Network Sandboxes. *) - -open Internal_pervasives - -module Inconsistency_error : sig - type t = [`Empty_protocol_list | `Too_many_protocols of Tezos_protocol.t list] - - val should_be_one_protocol : - 'a list -> - ( 'a, - [> `Empty_protocol_list | `Too_many_protocols of 'a list] ) - Asynchronous_result.t - - val pp : - Format.formatter -> - [< `Empty_protocol_list | `Too_many_protocols of 'a Base.List.t] -> - unit -end - -(** Build {i static} tezos network topologies. *) -module Topology : sig - type node = Tezos_node.t - - type _ t = private - | Mesh : {size : int} -> node list t - | Bottleneck : { - name : string; - left : 'a network; - right : 'b network; - } - -> ('a * node * 'b) t - | Net_in_the_middle : { - middle : 'm network; - left : 'a network; - right : 'b network; - } - -> ('a * 'm * 'b) t - - and 'a network = {topology : 'a t; name : string} - - val mesh : string -> int -> node list network - - val sub : string -> 'a t -> 'a network - - val bottleneck : - string -> 'a network -> 'b network -> ('a * node * 'b) network - - val node_count : 'a t -> int - - val node_ids : 'a t -> 'a -> string list - - val net_in_the_middle : - string -> 'a network -> 'b network -> 'c network -> ('b * 'a * 'c) network - - val build : - ?external_peer_ports:int list -> - ?protocol:Tezos_protocol.t -> - ?base_port:int -> - exec:Tezos_executable.t -> - 'a network -> - 'a -end - -(** Start networks from (and manipulate) {!Topology.t} values. *) -module Network : sig - type t = private {nodes : Tezos_node.t list} - - val make : Tezos_node.t list -> t - - (** Call ["netstat"] to find TCP ports already in use. *) - val netstat_listening_ports : - < paths : Paths.t ; runner : Running_processes.State.t ; .. > Base_state.t -> - ( (int * [> `Tcp of int * string list]) list, - [> `Lwt_exn of exn | Process_result.Error.t] ) - Asynchronous_result.t - - val start_up : - ?check_ports:bool -> - < Base_state.base - ; paths : Paths.t - ; runner : Running_processes.State.t - ; .. > -> - client_exec:Tezos_executable.t -> - t -> - ( unit, - [> `Empty_protocol_list - | `Lwt_exn of exn - | `Sys_error of string - | Process_result.Error.t - | `Too_many_protocols of Tezos_protocol.t list ] ) - Asynchronous_result.t -end - -(** [network_with_protocol] is a wrapper simply starting-up a - {!Topology.mesh}. *) -val network_with_protocol : - ?external_peer_ports:int list -> - ?base_port:int -> - ?size:int -> - ?protocol:Tezos_protocol.t -> - < paths : Paths.t ; runner : Running_processes.State.t ; .. > Base_state.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 - | `Sys_error of string - | Process_result.Error.t - | `Too_many_protocols of Tezos_protocol.t list ] ) - Asynchronous_result.t - -(** Run queries on running networks. *) -module Queries : sig - (** Get the current chain level for all the nodes, returns {i - node-ID × level } values. *) - val all_levels : - ?chain:string -> - < application_name : string - ; console : Console.t - ; paths : Paths.t - ; runner : Running_processes.State.t - ; .. > -> - nodes:Tezos_node.t list -> - ( (string * [> `Failed | `Level of int | `Null | `Unknown of string]) list, - [> `Lwt_exn of exn] ) - Asynchronous_result.t - - (** Try-sleep-loop waiting for all given nodes to reach a given level. *) - val wait_for_all_levels_to_be : - ?chain:string -> - < application_name : string - ; console : Console.t - ; paths : Paths.t - ; runner : Running_processes.State.t - ; .. > -> - attempts:int -> - seconds:float -> - Tezos_node.t list -> - [< `At_least of int | `Equal_to of int] -> - ( unit, - [> `Lwt_exn of exn | `Waiting_for of string * [`Time_out]] ) - Asynchronous_result.t -end diff --git a/src/lib_network_sandbox/tezos_admin_client.mli b/src/lib_network_sandbox/tezos_admin_client.mli deleted file mode 100644 index 65502e7c3cc2..000000000000 --- a/src/lib_network_sandbox/tezos_admin_client.mli +++ /dev/null @@ -1,48 +0,0 @@ -(** Wrapper around the [tezos-admin-client] application. *) -open Internal_pervasives - -(** [t] is very similar to {!Tezos_client.t}. *) -type t = private {id : string; port : int; exec : Tezos_executable.t} - -val of_client : exec:Tezos_executable.t -> Tezos_client.t -> t - -val of_node : exec:Tezos_executable.t -> Tezos_node.t -> t - -(** Build a [Genspio.EDSL.t] command. *) -val make_command : - t -> < paths : Paths.t ; .. > -> string list -> unit Genspio.EDSL.t - -module Command_error : sig - type t = [`Admin_command_error of string * string list option] - - val failf : - ?args:string list -> - ('a, unit, string, ('b, [> t]) Asynchronous_result.t) format4 -> - 'a - - val pp : Format.formatter -> t -> unit -end - -val successful_command : - t -> - < application_name : string - ; console : Console.t - ; paths : Paths.t - ; runner : Running_processes.State.t - ; .. > -> - string list -> - ( 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_node.mli b/src/lib_network_sandbox/tezos_node.mli deleted file mode 100644 index 8f4567fbf643..000000000000 --- a/src/lib_network_sandbox/tezos_node.mli +++ /dev/null @@ -1,55 +0,0 @@ -type t = private { - id : string; - expected_connections : int; - rpc_port : int; - p2p_port : int; - peers : int list; - exec : Tezos_executable.t; - protocol : Tezos_protocol.t; -} - -val ef : t -> Easy_format.t - -val pp : Format.formatter -> t -> unit - -val make : - exec:Tezos_executable.t -> - ?protocol:Tezos_protocol.t -> - string -> - expected_connections:int -> - rpc_port:int -> - p2p_port:int -> - int list -> - t - -val data_dir : config:< paths : Paths.t ; .. > -> t -> string - -val config_file : config:< paths : Paths.t ; .. > -> t -> string - -val identity_file : config:< paths : Paths.t ; .. > -> t -> string - -val log_output : config:< paths : Paths.t ; .. > -> t -> string - -val exec_path : config:< paths : Paths.t ; .. > -> t -> string - -val node_command : - t -> - config:< paths : Paths.t ; .. > -> - string list -> - string list -> - unit Genspio.Language.t - -val config_options : t -> config:< paths : Paths.t ; .. > -> string list - -val run_command : - t -> config:< paths : Paths.t ; .. > -> unit Genspio.Language.t - -val start_script : - t -> config:< paths : Paths.t ; .. > -> unit Genspio.Language.t - -val process : < paths : Paths.t ; .. > -> t -> Running_processes.Process.t - -val protocol : t -> Tezos_protocol.t - -val connections : - t list -> [`Duplex of t * t | `From_to of t * t | `Missing of t * int] list diff --git a/src/lib_network_sandbox/tezos_protocol.ml b/src/lib_network_sandbox/tezos_protocol.ml deleted file mode 100644 index 80092f40abf9..000000000000 --- a/src/lib_network_sandbox/tezos_protocol.ml +++ /dev/null @@ -1,450 +0,0 @@ -open Internal_pervasives -open Protocol - -module Key = struct - module Of_name = struct - type t = { - name : string; - pkh : Tezos_crypto.Ed25519.Public_key_hash.t; - pk : Tezos_crypto.Ed25519.Public_key.t; - sk : Tezos_crypto.Ed25519.Secret_key.t; - } - - let make name = - let seed = - Bigstring.of_string - (String.concat ~sep:"" (List.init 42 ~f:(fun _ -> name))) - in - let (pkh, pk, sk) = Tezos_crypto.Ed25519.generate_key ~seed () in - {name; pkh; pk; sk} - - let pubkey n = Tezos_crypto.Ed25519.Public_key.to_b58check (make n).pk - - let pubkey_hash n = - Tezos_crypto.Ed25519.Public_key_hash.to_b58check (make n).pkh - - let private_key n = - "unencrypted:" ^ Tezos_crypto.Ed25519.Secret_key.to_b58check (make n).sk - end -end - -module Script = struct - type origin = [`Sandbox_faucet | `String of string] - - let exn_tezos msg = function - | Ok o -> - o - | Error el -> - Format.kasprintf - failwith - "Script-error: %s: %a" - msg - Tezos_error_monad.Error_monad.pp_print_error - el - - let exn_shell msg res = Environment.wrap_error res |> exn_tezos msg - - let parse exprs = - Michelson_v1_parser.((parse_expression exprs |> fst).expanded) - - let code_of_json_exn s = - match Tezos_data_encoding.Data_encoding.Json.from_string s with - | Ok json -> - let repr = - Tezos_data_encoding.Data_encoding.Json.destruct - Script_repr.encoding - json - in - let ( (expr_code : - Michelson_v1_primitives.prim - Tezos_micheline.Micheline.canonical), - _ ) = - Script_repr.(force_decode repr.code) - |> exn_shell "decoding script-repr" - in - let strings_node = - Michelson_v1_primitives.strings_of_prims expr_code - |> Environment.Micheline.root - in - Format.eprintf - ">> %a\n%!" - Tezos_micheline.Micheline_printer.print_expr - (Tezos_micheline.Micheline.map_node - (fun _ -> Tezos_micheline.Micheline_printer.{comment = None}) - (fun x -> x) - strings_node) ; - expr_code - | Error e -> - Format.kasprintf failwith "JSON-of-string: %s" e - - let json_script_repr code storage = - match - Tezos_data_encoding.Data_encoding.Json.construct - Script_repr.encoding - Script_repr.{code = lazy_expr code; storage = lazy_expr storage} - with - | `O _ as o -> - (o : Ezjsonm.t) - | _other -> - Format.kasprintf failwith "JSON-of-script-repr: not a json object" - - let original_json = - (* looks like "./src/bin_client/test/contracts/attic/faucet.tz" *) - {json|{ "code": - [ { "prim": "parameter", - "args": [ { "prim": "key_hash" } ] }, - { "prim": "storage", - "args": [ { "prim": "timestamp" } ] }, - { "prim": "code", - "args": - [ [ [ [ { "prim": "DUP" }, { "prim": "CAR" }, - { "prim": "DIP", "args": [ [ { "prim": "CDR" } ] ] } ] ], - { "prim": "SWAP" }, - { "prim": "PUSH", "args": [ { "prim": "int" }, { "int": "300" } ] }, - { "prim": "ADD", "annots": [ "@FIVE_MINUTES_LATER" ] }, - { "prim": "NOW" }, - [ [ { "prim": "COMPARE" }, { "prim": "GE" } ], - { "prim": "IF", - "args": - [ [], - [ [ { "prim": "UNIT" }, - { "prim": "FAILWITH" } ] ] ] } ], - { "prim": "IMPLICIT_ACCOUNT" }, - { "prim": "PUSH", "args": [ { "prim": "mutez" }, { "int": "1000000" } ] }, - { "prim": "UNIT" }, - { "prim": "TRANSFER_TOKENS" }, - { "prim": "NIL", "args": [ { "prim": "operation" } ] }, - { "prim": "SWAP" }, - { "prim": "CONS" }, - { "prim": "DIP", "args": [ [ { "prim": "NOW" } ] ] }, - { "prim": "PAIR" } ] ] } ], - "storage": { "int": "0" } }|json} - - let faucet_tz = - (* exactly "./src/bin_client/test/contracts/attic/faucet.tz" *) - {tz| -{ parameter key_hash ; - storage timestamp ; - code { UNPAIR ; SWAP ; - PUSH int 300 ; ADD @FIVE_MINUTES_LATER ; - NOW ; ASSERT_CMPGE ; - IMPLICIT_ACCOUNT ; PUSH mutez 1000000 ; UNIT ; TRANSFER_TOKENS ; - NIL operation ; SWAP ; CONS ; DIP { NOW } ; PAIR } } -|tz} - - let print code storage = - let json_repr = json_script_repr code storage in - Format.eprintf "script-repr: %s\n%!" (Ezjsonm.to_string json_repr) ; - () - - let load : origin -> _ = function - | `Sandbox_faucet -> - let code = code_of_json_exn original_json in - json_script_repr code (parse "0") - | `String s -> - json_script_repr (parse s) (parse "0") - - let test () = - let faucet_like = - {mich| {parameter key_hash ; - storage timestamp ; - code { { { DUP ; CAR ; DIP { CDR } } } ; - SWAP ; - PUSH int 300 ; - ADD @FIVE_MINUTES_LATER ; - NOW ; - { { COMPARE ; GE } ; IF {} { { UNIT ; FAILWITH } } } ; - IMPLICIT_ACCOUNT ; - PUSH mutez 1000000 ; - UNIT ; - TRANSFER_TOKENS ; - NIL operation ; - SWAP ; - CONS ; - DIP { NOW } ; - PAIR }} |mich} - in - print (parse faucet_like) (parse "0") ; - let original = code_of_json_exn original_json in - print original (parse "0") ; - (* print (parse faucet_tz) (parse "0") ; *) - () -end - -module Account = struct - type t = - | Of_name of string - | Key_pair of { - name : string; - pubkey : string; - pubkey_hash : string; - private_key : string; - } - - let of_name s = Of_name s - - let of_namef fmt = ksprintf of_name fmt - - let name = function Of_name n -> n | Key_pair k -> k.name - - let key_pair name ~pubkey ~pubkey_hash ~private_key = - Key_pair {name; pubkey; pubkey_hash; private_key} - - let pubkey = function - | Of_name n -> - Key.Of_name.pubkey n - | Key_pair k -> - k.pubkey - - let pubkey_hash = function - | Of_name n -> - Key.Of_name.pubkey_hash n - | Key_pair k -> - k.pubkey_hash - - let private_key = function - | Of_name n -> - Key.Of_name.private_key n - | Key_pair k -> - k.private_key -end - -module Voting_period = struct - type t = Alpha_context.Voting_period.kind = - | Proposal - | Testing_vote - | Testing - | Promotion_vote - - let to_string (p : t) = - match - Tezos_data_encoding.Data_encoding.Json.construct - 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; - dictator : Account.t; - bootstrap_contracts : (Account.t * int * Script.origin) list; - expected_pow : int; - name : string; - (* e.g. alpha *) - hash : string; - time_between_blocks : int list; - blocks_per_roll_snapshot : int; - blocks_per_voting_period : int; - blocks_per_cycle : int; - preserved_cycles : int; - proof_of_work_threshold : int; -} - -let compare a b = String.compare a.id b.id - -let default () = - let dictator = Account.of_name "dictator-default" in - { - id = "default-bootstrap"; - bootstrap_accounts = - List.init 4 ~f:(fun n -> - (Account.of_namef "bootacc-%d" n, 4_000_000_000_000L)); - dictator; - bootstrap_contracts = [(dictator, 10_000_000, `Sandbox_faucet)]; - expected_pow = 1; - name = "alpha"; - hash = "ProtoALphaALphaALphaALphaALphaALphaALphaALphaDdp3zK"; - time_between_blocks = [2; 3]; - blocks_per_roll_snapshot = 4; - blocks_per_voting_period = 16; - blocks_per_cycle = 8; - preserved_cycles = 2; - proof_of_work_threshold = -1; - } - -let protocol_parameters_json t : Ezjsonm.t = - let open Ezjsonm in - let make_account (account, amount) = - strings [Account.pubkey account; sprintf "%Ld" amount] - in - let make_contract (deleg, amount, script) = - dict - [ ("delegate", string (Account.pubkey_hash deleg)); - ("amount", ksprintf string "%d" amount); - ("script", (Script.load script :> Ezjsonm.value)) ] - in - dict - [ ( "bootstrap_accounts", - list make_account (t.bootstrap_accounts @ [(t.dictator, 1L)]) ); - ("bootstrap_contracts", list make_contract t.bootstrap_contracts); - ("time_between_blocks", list (ksprintf string "%d") t.time_between_blocks); - ("blocks_per_roll_snapshot", int t.blocks_per_roll_snapshot); - ("blocks_per_voting_period", int t.blocks_per_voting_period); - ("blocks_per_cycle", int t.blocks_per_cycle); - ("preserved_cycles", int t.preserved_cycles); - ( "proof_of_work_threshold", - ksprintf string "%d" t.proof_of_work_threshold ) ] - -let sandbox {dictator; _} = - let pk = Account.pubkey dictator in - Ezjsonm.to_string (`O [("genesis_pubkey", `String pk)]) - -let protocol_parameters t = - Ezjsonm.to_string ~minify:false (protocol_parameters_json t) - -let expected_pow t = t.expected_pow - -let id t = t.id - -let bootstrap_accounts t = List.map ~f:fst t.bootstrap_accounts - -let dictator_name {dictator; _} = Account.name dictator - -let dictator_secret_key {dictator; _} = Account.private_key dictator - -let make_path config t = Paths.root config // sprintf "protocol-%s" (id t) - -let sandbox_path ~config t = make_path config t // "sandbox.json" - -let protocol_parameters_path ~config t = - make_path config t // "protocol_parameters.json" - -let ensure_script ~config t = - let open Genspio.EDSL in - let file string p = - let path = p ~config t in - ( Filename.basename path, - write_stdout - ~path:(str path) - (feed ~string:(str (string t)) (exec ["cat"])) ) - in - check_sequence - ~verbosity:(`Announce (sprintf "Ensure-protocol-%s" (id t))) - [ ("directory", exec ["mkdir"; "-p"; make_path config t]); - file sandbox sandbox_path; - file protocol_parameters protocol_parameters_path ] - -let ensure t ~config = - match - Sys.command (Genspio.Compile.to_one_liner (ensure_script ~config t)) - with - | 0 -> - return () - | _other -> - Lwt_exception.fail - (Failure "sys.command non-zero") - ~attach:[("location", `String_value "Tezos_protocol.ensure")] - -let cli_term () = - let open Cmdliner in - let open Term in - let def = default () in - let docs = "PROTOCOL OPTIONS" in - pure - (fun remove_default_bas - (`Blocks_per_voting_period blocks_per_voting_period) - (`Protocol_hash hash) - (`Time_between_blocks time_between_blocks) - (`Blocks_per_cycle blocks_per_cycle) - (`Preserved_cycles preserved_cycles) - add_bootstraps - -> - let id = "default-and-command-line" in - let bootstrap_accounts = - add_bootstraps - @ if remove_default_bas then [] else def.bootstrap_accounts - in - { - def with - id; - blocks_per_cycle; - hash; - bootstrap_accounts; - time_between_blocks; - preserved_cycles; - blocks_per_voting_period; - }) - $ Arg.( - value - (flag - (info - ~doc:"Do not create any of the default bootstrap accounts." - ~docs - ["remove-default-bootstrap-accounts"]))) - $ Arg.( - pure (fun x -> `Blocks_per_voting_period x) - $ value - (opt - int - def.blocks_per_voting_period - (info - ~docs - ["blocks-per-voting-period"] - ~doc:"Set the length of voting periods."))) - $ Arg.( - pure (fun x -> `Protocol_hash x) - $ value - (opt - string - def.hash - (info - ["protocol-hash"] - ~docs - ~doc:"Set the (initial) protocol hash."))) - $ Arg.( - pure (fun x -> `Time_between_blocks x) - $ value - (opt - (list ~sep:',' int) - def.time_between_blocks - (info - ["time-between-blocks"] - ~docv:"COMMA-SEPARATED-SECONDS" - ~docs - ~doc: - "Set the time between blocks bootstrap-parameter, e.g. \ - `2,3,2`."))) - $ Arg.( - pure (fun x -> `Blocks_per_cycle x) - $ value - (opt - int - def.blocks_per_cycle - (info - ["blocks-per-cycle"] - ~docv:"NUMBER" - ~docs - ~doc:"Number of blocks per cycle."))) - $ Arg.( - pure (fun x -> `Preserved_cycles x) - $ value - (opt - int - def.preserved_cycles - (info - ["preserved-cycles"] - ~docv:"NUMBER" - ~docs - ~doc: - "Base constant for baking rights (search for \ - `PRESERVED_CYCLES` in the white paper)."))) - $ Arg.( - pure (fun l -> - List.map l ~f:(fun ((name, pubkey, pubkey_hash, private_key), tez) -> - (Account.key_pair name ~pubkey ~pubkey_hash ~private_key, tez))) - $ value - (opt_all - (pair ~sep:'@' (t4 ~sep:',' string string string string) int64) - [] - (info - ["add-bootstrap-account"] - ~docs - ~docv:"NAME,PUBKEY,PUBKEY-HASH,PRIVATE-URI@MUTEZ-AMOUNT" - ~doc: - "Add a custom bootstrap account, e.g. \ - `LedgerBaker,edpku...,tz1YPS...,ledger://crouching-tiger.../ed25519/0'/0'@20_000_000_000`."))) diff --git a/vendors/flextesa-lib/.ocamlformat b/vendors/flextesa-lib/.ocamlformat new file mode 100644 index 000000000000..6bafbd1c4e23 --- /dev/null +++ b/vendors/flextesa-lib/.ocamlformat @@ -0,0 +1 @@ +profile=compact diff --git a/src/lib_network_sandbox/console.ml b/vendors/flextesa-lib/console.ml similarity index 64% rename from src/lib_network_sandbox/console.ml rename to vendors/flextesa-lib/console.ml index 5e91d37e8869..0145fcaffe54 100644 --- a/src/lib_network_sandbox/console.ml +++ b/vendors/flextesa-lib/console.ml @@ -1,50 +1,39 @@ open Internal_pervasives -type t = { - color : bool; - buffer : Buffer.t; - channel : Lwt_io.output_channel; - with_timestamp : bool; - formatter : Format.formatter; -} +type t = + { color: bool + ; buffer: Buffer.t + ; channel: Lwt_io.output_channel + ; with_timestamp: bool + ; formatter: Format.formatter } let make with_timestamp color = let channel = Lwt_io.stderr in let b = Buffer.create 42 in let formatter = - Format.make_formatter (Buffer.add_substring b) (fun () -> ()) - in + Format.make_formatter (Buffer.add_substring b) (fun () -> ()) in let bold = "\027[01m" in let red = "\027[31m" in let reset = "\027[m" in if color then ( let color_of_tag = function - | "prompt" -> - Some bold - | "shout" -> - Some red - | _ -> - None - in + | "prompt" -> Some bold + | "shout" -> Some red + | _ -> None in Format.( - pp_set_formatter_tag_functions - formatter - { - mark_open_tag = (fun _ -> ""); - mark_close_tag = (fun _ -> ""); - print_open_tag = + pp_set_formatter_tag_functions formatter + { mark_open_tag= (fun _ -> "") + ; mark_close_tag= (fun _ -> "") + ; print_open_tag= (fun tag -> match color_of_tag tag with - | Some c -> - fprintf formatter "%s" c - | None -> - ()); - print_close_tag = + | Some c -> fprintf formatter "%s" c + | None -> ()) + ; print_close_tag= (fun tag -> - if color_of_tag tag <> None then fprintf formatter "%s" reset); - } ; + if color_of_tag tag <> None then fprintf formatter "%s" reset) } ; pp_set_tags formatter true) ) ; - {color; buffer = b; channel; formatter; with_timestamp} + {color; buffer= b; channel; formatter; with_timestamp} let pp fmt {color; _} = Format.fprintf fmt "@[<2>{Console:@ color: %b}@]" color @@ -52,29 +41,24 @@ let cli_term () = let guess = let dumb = try match Sys.getenv "TERM" with "dumb" | "" -> true | _ -> false - with Not_found -> true - in + with Not_found -> true in let isatty = try Unix.(isatty stderr) with Unix.Unix_error _ -> false in - if (not dumb) && isatty then true else false - in + if (not dumb) && isatty then true else false in Cmdliner.( Term.( pure make $ Arg.( value (flag - (info - ["with-timestamp"] + (info ["with-timestamp"] ~doc:"Display messages with time-stamps."))) $ Arg.( pure (function `Y -> true | `N -> false | `G -> guess) $ let answers = [("none", `N); ("yes", `Y); ("auto", `G)] in let doc = - sprintf - "Control terminal colors (%s)." - (String.concat ~sep:", " (List.map answers ~f:fst)) - in + sprintf "Control terminal colors (%s)." + (String.concat ~sep:", " (List.map answers ~f:fst)) in value & opt (enum answers) `G & info ["color"] ~doc))) let do_output t = @@ -89,11 +73,9 @@ let sayf (o : _ Base_state.t) (fmt : Format.formatter -> unit -> unit) : if o#console.with_timestamp then let date = Tezos_stdlib_unix.Systime_os.now () - |> Tezos_base.Time.System.to_notation - in + |> Tezos_base.Time.System.to_notation in sprintf "[%s]" date - else "" - in + else "" in let ppf = o#console.formatter in Format.( pp_open_hvbox ppf 2 ; @@ -112,11 +94,9 @@ let say (o : _ Base_state.t) ef : (_, _) Asynchronous_result.t = if o#console.with_timestamp then let date = Tezos_stdlib_unix.Systime_os.now () - |> Tezos_base.Time.System.to_notation - in + |> Tezos_base.Time.System.to_notation in sprintf "[%s]" date - else "" - in + else "" in let msg = EF.(label (ksprintf prompt "%s%s:" o#application_name date) ef) in let fmt = o#console.formatter in Format.( @@ -126,15 +106,14 @@ let say (o : _ Base_state.t) ef : (_, _) Asynchronous_result.t = Lwt_exception.catch (do_output o#console) () module Prompt = struct - type item = { - commands : string list; - doc : EF.t; - action : - Base.Sexp.t list -> - ( [`Help | `Quit | `Loop], - [`Lwt_exn of exn | `Command_line of string] ) - Asynchronous_result.t; - } + type item = + { commands: string list + ; doc: EF.t + ; action: + Base.Sexp.t list + -> ( [`Help | `Quit | `Loop] + , [`Lwt_exn of exn | `Command_line of string] ) + Asynchronous_result.t } let item doc commands action = {commands; doc; action} @@ -151,8 +130,7 @@ module Prompt = struct let command ?(with_defaults = true) state ~commands = let commands = - if with_defaults then default_commands () @ commands else commands - in + if with_defaults then default_commands () @ commands else commands in let rec loop () = say state EF.(af "Please enter command:") >>= fun () -> @@ -166,62 +144,43 @@ module Prompt = struct List.mem m.commands c ~equal:String.equal) with | Some {action; _} -> ( - Asynchronous_result.bind_on_error - (action more) + Asynchronous_result.bind_on_error (action more) ~f:(fun ~result _ -> - say - state + say state EF.( - desc - (shout "Error in action:") + desc (shout "Error in action:") (custom (fun ppf -> - Attached_result.pp - ppf - result (* Error.pp ppf err *) + Attached_result.pp ppf result (* Error.pp ppf err *) ~pp_error:(fun fmt -> function - | `Lwt_exn _ as e -> - Lwt_exception.pp fmt e + | `Lwt_exn _ as e -> Lwt_exception.pp fmt e | `Command_line s -> Format.fprintf fmt "Wrong command line: %s" s)))) >>= fun () -> return `Loop) >>= function - | `Loop -> - loop () + | `Loop -> loop () | `Help -> - say - state + say state EF.( let cmdlist = - list - ~sep:"|" - ~delimiters:("[", "]") + list ~sep:"|" ~delimiters:("[", "]") ~param: - { - default_list with - space_after_separator = false; - space_before_closing = false; - space_after_opening = false; - } - in - label - (haf "Commands:") + { default_list with + space_after_separator= false + ; space_before_closing= false + ; space_after_opening= false } in + label (haf "Commands:") (list (List.map commands ~f:(fun {commands; doc; _} -> label ~param: - { - default_label with - space_after_label = false; - } + {default_label with space_after_label= false} (cmdlist (List.map ~f:(af "%S") commands)) (list [haf "->"; doc]))))) >>= fun () -> loop () - | `Quit -> - return () ) + | `Quit -> return () ) | None -> - say - state + say state EF.( desc (ksprintf shout "Error, unknown command: %S" c) @@ -229,26 +188,20 @@ module Prompt = struct Base.Sexp.pp_hum_indent 4 fmt (List more)))) >>= fun () -> loop () ) | Ok other -> - say - state + say state EF.( desc (shout "Error, cannot understand: ") (custom (fun fmt -> Base.Sexp.pp_hum_indent 4 fmt other))) >>= fun () -> loop () | Error err -> - say - state + say state EF.( - desc - (shout "Error: ") + desc (shout "Error: ") (custom (fun fmt -> - Parsexp.Parse_error.report - fmt - ~filename:"" + Parsexp.Parse_error.report fmt ~filename:"" err))) - >>= fun () -> loop () - in + >>= fun () -> loop () in loop () end @@ -256,24 +209,18 @@ let display_errors_of_command state ?(should_output = false) cmd = let outputs () = List.exists cmd#out ~f:(fun s -> String.strip s <> "") in let success = let unix_success = cmd#status = Lwt_unix.WEXITED 0 in - if should_output then unix_success && outputs () else unix_success - in + if should_output then unix_success && outputs () else unix_success in ( if success then return () else - say - state + say state EF.( let output l = match String.concat ~sep:"\n" l |> String.strip with - | "" -> - af "NONE" - | more -> - markdown_verbatim more - in - desc - (shout "Error:") + | "" -> af "NONE" + | more -> markdown_verbatim more in + desc (shout "Error:") (list - [ haf "Command %s" (Process_result.status_to_string cmd#status); - desc (haf "Stdout:") (output cmd#out); - desc (haf "Stderr:") (output cmd#err) ])) ) + [ haf "Command %s" (Process_result.status_to_string cmd#status) + ; desc (haf "Stdout:") (output cmd#out) + ; desc (haf "Stderr:") (output cmd#err) ])) ) >>= fun () -> return success diff --git a/src/lib_network_sandbox/console.mli b/vendors/flextesa-lib/console.mli similarity index 100% rename from src/lib_network_sandbox/console.mli rename to vendors/flextesa-lib/console.mli diff --git a/vendors/flextesa-lib/dump_files.ml b/vendors/flextesa-lib/dump_files.ml new file mode 100644 index 000000000000..37ce41ac820c --- /dev/null +++ b/vendors/flextesa-lib/dump_files.ml @@ -0,0 +1,29 @@ +open Internal_pervasives +module IFmt = Experiments.More_fmt + +type t = {mutable trees: (string * string * (string * string) list) list} + +let make () = {trees= []} + +let write state ~name ~path files = + let t = state#dump_files in + Running_processes.run_successful_cmdf state "mkdir -p %s" + (Filename.quote path) + >>= fun _ -> + List_sequential.iter files ~f:(fun (p, content) -> + System.write_file state (path // p) ~content) + >>= fun () -> + (* Dbg.e EF.(wf "Adding %s" name) ; *) + t.trees <- (name, path, files) :: t.trees ; + return () + +let pp ppf t = + (* Dbg.e EF.(wf "pp -ing %d" (List.length t.trees)) ; *) + IFmt.( + vertical_box ~indent:2 ppf (fun ppf -> + List.iter t.trees ~f:(fun (msg, path, files) -> + cut ppf () ; + pf ppf "%s setup at `%s`:" msg path ; + List.iter files ~f:(fun (p, c) -> + cut ppf () ; + pf ppf "* `./%s` → `%s`" p c)))) diff --git a/vendors/flextesa-lib/dump_files.mli b/vendors/flextesa-lib/dump_files.mli new file mode 100644 index 000000000000..d849772f6d6c --- /dev/null +++ b/vendors/flextesa-lib/dump_files.mli @@ -0,0 +1,23 @@ +(** Write little file trees, and save them in the state. *) + +open Internal_pervasives + +type t = private + {mutable trees: (string * string * (string * string) list) list} + +val make : unit -> t + +val write : + < application_name: string + ; dump_files: t + ; paths: Paths.t + ; runner: Running_processes.State.t + ; .. > + -> name:string + -> path:string + -> (string * string) list + -> ( unit + , [> `Lwt_exn of exn | `Wrong_status of Process_result.t * string] ) + Asynchronous_result.t + +val pp : Format.formatter -> t -> unit diff --git a/vendors/flextesa-lib/dune b/vendors/flextesa-lib/dune new file mode 100644 index 000000000000..c414c0e03c34 --- /dev/null +++ b/vendors/flextesa-lib/dune @@ -0,0 +1,18 @@ +(library + (name flextesa) + (public_name flextesa) + (flags (:standard -safe-string)) + (libraries + fmt + cohttp-lwt-unix + lwt.unix + cmdliner + easy-format + dum + base + genspio + ezjsonm + tezos-stdlib-unix + tezos-crypto + )) + diff --git a/vendors/flextesa-lib/experiments.ml b/vendors/flextesa-lib/experiments.ml new file mode 100644 index 000000000000..38114790d5c2 --- /dev/null +++ b/vendors/flextesa-lib/experiments.ml @@ -0,0 +1,98 @@ +open Internal_pervasives + +module More_fmt = struct + include Fmt + (** Little experiment for fun … *) + + let vertical_box ?indent ppf f = vbox ?indent (fun ppf () -> f ppf) ppf () + let wrapping_box ?indent ppf f = hvbox ?indent (fun ppf () -> f ppf) ppf () + + let wf ppf fmt = + Format.kasprintf (fun s -> box (fun ppf () -> text ppf s) ppf ()) fmt + + let markdown_verbatim_list ppf l = + vertical_box ~indent:0 ppf (fun ppf -> + cut ppf () ; + string ppf (String.make 45 '`') ; + List.iter l ~f:(fun l -> cut ppf () ; string ppf l) ; + cut ppf () ; + string ppf (String.make 45 '`')) + + let tag tag ppf f = + Format.pp_open_tag ppf tag ; + (f ppf : unit) ; + Format.pp_close_tag ppf () + + let shout = tag "shout" + + let long_string ?(max = 30) ppf s = + match String.sub s ~pos:0 ~len:(max - 2) with + | s -> pf ppf "%S" (s ^ "...") + | exception _ -> pf ppf "%S" s +end + +module Markup_fmt = struct + (** An alternative experiment. *) + + let vertical_box ?indent ppf f = + let open Fmt in + vbox ?indent (fun ppf () -> f ppf) ppf () + + let wrapping_box ?indent ppf f = + let open Fmt in + box ?indent (fun ppf () -> f ppf) ppf () + + type in_par = + [`Text of string | `Highlight of in_par | `Concat of in_par list] + + type t = + [ `Par of in_par + | `Itemize of in_par list + | `Raw of string + | `Verbatim of string list ] + + let par l : t list = + match l with [one] -> [`Par one] | l -> [`Par (`Concat l)] + + let verbatim l = [`Verbatim l] + let verbatim_raw raw = [`Verbatim (String.split ~on:'\n' raw)] + + let verbatim_ezjson json = + verbatim_raw (Ezjsonm.value_to_string ~minify:false json) + + let t s : in_par list = [`Text s] + let tf fmt = Format.kasprintf t fmt + let hl l : in_par list = [`Highlight (`Concat l)] + let concat l = `Concat l + let hlf fmt = Format.kasprintf (fun s -> hl (t s)) fmt + let itemize l : t list = [`Itemize (List.map l ~f:(fun l -> `Concat l))] + + let to_fmt (x : t list) ppf () = + let open Fmt in + let rec pp_in_par ppf = function + | `Text s -> text ppf s + | `Concat l -> List.iter l ~f:(pp_in_par ppf) + | `Highlight s -> + Format.pp_open_tag ppf "prompt" ; + pp_in_par ppf s ; + Format.pp_close_tag ppf () in + vertical_box ppf (fun ppf -> + list ~sep:cut + (fun ppf item -> + match item with + | `Par in_par -> wrapping_box ppf (fun ppf -> pp_in_par ppf in_par) + | `Verbatim sl -> + vertical_box ppf (fun ppf -> + string ppf "`````" ; + List.iter sl ~f:(fun l -> cut ppf () ; string ppf l) ; + cut ppf () ; + string ppf "`````") + | `Itemize l -> + list ~sep:cut + (fun ppf inpar -> + wrapping_box ~indent:2 ppf (fun ppf -> + string ppf "* " ; pp_in_par ppf inpar)) + ppf l + | `Raw s -> string ppf s) + ppf x) +end diff --git a/src/lib_network_sandbox/tezos-network-sandbox.opam b/vendors/flextesa-lib/flextesa.opam similarity index 75% rename from src/lib_network_sandbox/tezos-network-sandbox.opam rename to vendors/flextesa-lib/flextesa.opam index 76340a062601..e56a37545088 100644 --- a/src/lib_network_sandbox/tezos-network-sandbox.opam +++ b/vendors/flextesa-lib/flextesa.opam @@ -1,6 +1,6 @@ opam-version: "2.0" version: "dev" -maintainer: "contact@tezos.com" +maintainer: "seb@mondet.org" authors: [ "Tezos devteam" ] homepage: "https://www.tezos.com/" bug-reports: "https://gitlab.com/tezos/tezos/issues" @@ -13,13 +13,12 @@ depends: [ "genspio" { = "0.0.2" } "dum" "tezos-stdlib-unix" - "tezos-signer-backends" - "tezos-client-alpha" - "tezos-protocol-alpha" "lwt" ] build: [ ["dune" "build" "-p" name "-j" jobs] ["dune" "runtest" "-p" name "-j" jobs] {with-test} ] -synopsis: "Tezos: library to manage network sandboxes" +synopsis: + "Flexible Tezos Sandboxes: library to run various Tezos network-sandboxes" + diff --git a/src/lib_network_sandbox/helpers.ml b/vendors/flextesa-lib/helpers.ml similarity index 74% rename from src/lib_network_sandbox/helpers.ml rename to vendors/flextesa-lib/helpers.ml index d53b9f5c5b62..eff212b42fa7 100644 --- a/src/lib_network_sandbox/helpers.ml +++ b/vendors/flextesa-lib/helpers.ml @@ -14,8 +14,7 @@ let dump_connection = let dump_connections state nodes = let conns = Tezos_node.connections nodes in - say - state + say state (let open EF in desc_list (haf "Connections:") (List.map conns ~f:dump_connection)) @@ -25,53 +24,39 @@ let clear_root state = (fun () -> ksprintf Lwt_unix.system "rm -fr %s" (Filename.quote root)) () >>= function - | Unix.WEXITED 0 -> - return () - | _ -> - System_error.fail "cannot delete root path (%S)" root + | Unix.WEXITED 0 -> return () + | _ -> System_error.fail "cannot delete root path (%S)" root let wait_for state ~attempts ~seconds f = let rec attempt nth = let again () = attempt (nth + 1) in f nth >>= function - | `Done x -> - return x + | `Done x -> return x | `Not_done msg when nth < attempts -> - say - state + say state EF.( - wf - "%s: attempt %d/%d, sleeping %.02f seconds" - msg - nth - attempts + wf "%s: attempt %d/%d, sleeping %.02f seconds" msg nth attempts seconds) >>= fun () -> System.sleep seconds >>= fun () -> again () - | `Not_done msg -> - fail (`Waiting_for (msg, `Time_out)) - in + | `Not_done msg -> fail (`Waiting_for (msg, `Time_out)) in attempt 1 let kill_node state nod = - Running_processes.find_process_by_id - ~only_running:true - state + Running_processes.find_process_by_id ~only_running:true state ~f:(( = ) nod.Tezos_node.id) >>= fun states -> ( match states with - | [one] -> - return one - | _ -> - System_error.fail "Expecting one state for node %s" nod.Tezos_node.id ) + | [one] -> return one + | _ -> System_error.fail "Expecting one state for node %s" nod.Tezos_node.id + ) >>= fun node_state_0 -> Running_processes.kill state node_state_0 let restart_node ~client_exec state nod = Running_processes.start state (Tezos_node.process state nod) >>= fun _ -> let client = Tezos_client.of_node nod ~exec:client_exec in - say - state + say state EF.(wf "Started node %s, waiting for bootstrap …" nod.Tezos_node.id) >>= fun () -> Tezos_client.bootstrapped client ~state @@ -79,25 +64,19 @@ module Counter_log = struct type t = (string * int) list ref let create () = ref [] - let add t s n = t := (s, n) :: !t - let incr t s = add t s 1 - let sum t = List.fold !t ~init:0 ~f:(fun prev (_, s) -> prev + s) let to_table_string t = let total = "**Total:**" in let longest = List.fold !t ~init:total ~f:(fun p (n, _) -> - if String.length p < String.length n then n else p) - in + if String.length p < String.length n then n else p) in List.rev_map ((total, sum t) :: !t) ~f:(fun (cmt, n) -> - sprintf - "| %s %s|% 8d|" - cmt + sprintf "| %s %s|% 8d|" cmt (String.make (String.length longest - String.length cmt + 2) '.') n) |> String.concat ~sep:"\n" @@ -119,39 +98,30 @@ module System_dependencies = struct ?(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 + @ ["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)) + | Unix.WEXITED 0 -> return prev + | _ -> return (`Missing_exec (cmd, result) :: prev)) >>= fun errors_or_warnings -> - List.fold - protocol_paths - ~init:(return 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)) + | 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 + | [], _ -> return () + | more, `Or_fail -> + Console.sayf state Format.( fun ppf () -> pp_print_string ppf "System dependencies failed precheck:" ; @@ -164,12 +134,10 @@ module System_dependencies = struct ( match item with | `Missing_exec (path, _) -> (* pp_open_hovbox ppf 0 ; *) - pp_print_text - ppf + pp_print_text ppf (sprintf "Missing executable: `%s`." path) | `Not_a_protocol_path path -> - pp_print_text - ppf + pp_print_text ppf (sprintf "Not a protocol path: `%s`." path) ) ; pp_close_box ppf () ; pp_print_space ppf ()) ; pp_close_box ppf ()) diff --git a/src/lib_network_sandbox/helpers.mli b/vendors/flextesa-lib/helpers.mli similarity index 100% rename from src/lib_network_sandbox/helpers.mli rename to vendors/flextesa-lib/helpers.mli diff --git a/vendors/flextesa-lib/interactive_mini_network.ml b/vendors/flextesa-lib/interactive_mini_network.ml new file mode 100644 index 000000000000..cad559e892d7 --- /dev/null +++ b/vendors/flextesa-lib/interactive_mini_network.ml @@ -0,0 +1,150 @@ +open Internal_pervasives +open Console + +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) + `Get ~path:"/chains/main/chain_id" + >>= fun chain_id_json -> + let network_id = + match chain_id_json with `String s -> s | _ -> assert false in + 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, baker_exec, endorser_exec)]) + >>= fun (_ : unit option) -> + let accusers = + List.map nodes ~f:(fun node -> + let client = Tezos_client.of_node node ~exec:client_exec in + Tezos_daemon.accuser_of_node ~exec:accuser_exec ~client node) 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: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 + >>= 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 () -> + Prompt.( + command state + ~commands: + Interactive_test.Commands.( + all_defaults state ~nodes + @ [ secret_keys state ~protocol + ; arbitrary_command_on_clients state + ~clients: + (List.map nodes ~f:(Tezos_client.of_node ~exec:client_exec)) + ])) + +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 + bnod + bcli + bak + endo + accu + generate_kiln_config + state + -> + let actual_test = + 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)) + $ 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 `Baker "tezos" + $ Tezos_executable.cli_term `Endorser "tezos" + $ Tezos_executable.cli_term `Accuser "tezos" + $ 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 = + [ `P + "This test builds a small sandbox network, start various daemons, \ + and then gives the user an interactive command prompt to inspect \ + the network." ] in + info "mini-network" ~man ~doc) diff --git a/src/lib_network_sandbox/interactive_test.ml b/vendors/flextesa-lib/interactive_test.ml similarity index 51% rename from src/lib_network_sandbox/interactive_test.ml rename to vendors/flextesa-lib/interactive_test.ml index 5eafa1e188a0..339b9e288cb8 100644 --- a/src/lib_network_sandbox/interactive_test.ml +++ b/vendors/flextesa-lib/interactive_test.ml @@ -5,10 +5,8 @@ module Commands = struct let cmdline_fail fmt = Format.kasprintf (fun s -> fail (`Command_line s)) fmt let no_args = function - | [] -> - return () - | _more -> - cmdline_fail "this command expects no arguments" + | [] -> return () + | _more -> cmdline_fail "this command expects no arguments" let flag f sexps = List.mem sexps (Base.Sexp.Atom f) ~equal:Base.Sexp.equal @@ -18,44 +16,34 @@ module Commands = struct module Sexp_options = struct let option_doc pattern doc = EF.(desc (haf "`%s`:" pattern) doc) - let option_list_doc l = EF.(desc_list (wf "Options:") l) let port_number_doc _ ~default_port = - option_doc - "(port )" + option_doc "(port )" EF.(wf "use port-number (default: %d)" default_port) let port_number state ~default_port sexps = match - List.find_map - sexps + List.find_map sexps ~f: Base.Sexp.( function | List [Atom "port"; Atom p] -> ( try Some (`Ok (Int.of_string p)) with _ -> Some (`Not_an_int p) ) - | List (Atom "port" :: other) -> - Some (`Wrong_option other) - | _other -> - None) + | List (Atom "port" :: other) -> Some (`Wrong_option other) + | _other -> None) with - | None -> - return default_port - | Some (`Ok p) -> - return p + | None -> return default_port + | Some (`Ok p) -> return p | Some ((`Not_an_int _ | `Wrong_option _) as other) -> - say - state + say state EF.( desc (shout "Error parsing port option:") ( match other with | `Not_an_int s -> - af - "This is not an integer: %S, using default: %d" - s + af "This is not an integer: %S, using default: %d" s default_port | `Wrong_option _sexps -> af "Usage (port ), using default: %d" default_port )) @@ -72,14 +60,11 @@ module Commands = struct display_errors_of_command state du >>= function | true -> - say - state + say state EF.( - desc - (haf "Disk-Usage:") + desc (haf "Disk-Usage:") (af "%s" (String.concat ~sep:" " du#out))) - | false -> - return ()) + | false -> return ()) let processes state = Prompt.unit_and_loop @@ -90,64 +75,56 @@ module Commands = struct let all = flag "all" sxp in say state (Running_processes.ef ~all state)) - let curl ?(jq = ".") state ~port ~path = - Running_processes.run_cmdf - state - "curl http://localhost:%d%s | jq %s" - port - path - jq + let curl_rpc state ~port ~path = + Running_processes.run_cmdf state "curl http://localhost:%d/%s" port path >>= fun curl_res -> display_errors_of_command state curl_res ~should_output:true - >>= function - | true -> return (`Success curl_res#out) | false -> return `Error - - let curl_unit_display ?jq state cmd ~default_port ~path ~doc = + >>= fun success -> + if not success then return None + else + ( try + Ezjsonm.value_from_string (String.concat ~sep:"\n" curl_res#out) + |> return + with e -> cmdline_fail "Parsing JSON: %s" (Exn.to_string e) ) + >>= fun json -> return (Some json) + + let do_jq _state ~msg ~f = function + | None -> cmdline_fail "%s: No JSON" msg + | Some json -> ( + try return (f json) + with e -> + cmdline_fail "%s: failed to analyze JSON: %s from %s" msg + (Exn.to_string e) + (Ezjsonm.value_to_string ~minify:false json) ) + + let curl_unit_display ?(jq = fun e -> e) state cmd ~default_port ~path ~doc = Prompt.unit_and_loop EF.( - desc - (af "%s" doc) - (desc_list - (af "Options:") + desc (af "%s" doc) + (desc_list (af "Options:") [Sexp_options.port_number_doc state ~default_port])) cmd (fun sexps -> Sexp_options.port_number state sexps ~default_port >>= fun port -> - curl ?jq state ~port ~path - >>= function - | `Success res -> - say - state - EF.( - desc - (af "Curl-Node :%d" port) - (af "\"%s\"" (String.concat ~sep:"\n" res))) - | `Error -> - return ()) + curl_rpc state ~port ~path + >>= fun json_opt -> + do_jq ~msg:doc state json_opt ~f:jq + >>= fun json -> + say state EF.(desc (af "Curl-Node :%d" port) (ef_json doc json))) let curl_metadata state ~default_port = - curl_unit_display - state - ["m"; "metadata"] - ~default_port + curl_unit_display state ["m"; "metadata"] ~default_port ~path:"/chains/main/blocks/head/metadata" ~doc:"Display `/chains/main/blocks/head/metadata`" let curl_level state ~default_port = - curl_unit_display - state - ["l"; "level"] - ~default_port - ~path:"/chains/main/blocks/head/metadata" - ~doc:"Display block level" - ~jq:".level" + curl_unit_display state ["l"; "level"] ~default_port + ~path:"/chains/main/blocks/head/metadata" ~doc:"Display block level" + ~jq:(Jqo.field ~k:"level") let curl_baking_rights state ~default_port = - curl_unit_display - state - ["bk"; "baking-rights"] - ~default_port + curl_unit_display state ["bk"; "baking-rights"] ~default_port ~path:"/chains/main/blocks/head/helpers/baking_rights" ~doc:"Display baking rights" @@ -158,24 +135,17 @@ module Commands = struct (fun () -> Test_scenario.Queries.all_levels state ~nodes >>= fun results -> - say - state + say state EF.( - desc - (af "Node-levels:") + desc (af "Node-levels:") (list (List.map results ~f:(fun (id, result) -> - desc - (haf "%s" id) + desc (haf "%s" id) ( match result with - | `Failed -> - af "Failed" - | `Level i -> - af "[%d]" i - | `Null -> - af "{Null}" - | `Unknown s -> - af "¿%s?" s )))))) + | `Failed -> af "Failed" + | `Level i -> af "[%d]" i + | `Null -> af "{Null}" + | `Unknown s -> af "¿%s?" s )))))) let show_process state = Prompt.unit_and_loop @@ -201,13 +171,12 @@ module Commands = struct EF.( desc_list (haf "%S (%d)" process.Process.id lwt#pid) - [ desc (af "out: %s" out) (ocaml_string_list tailout#out); - desc (af "err: %s" err) (ocaml_string_list tailerr#out) + [ desc (af "out: %s" out) (ocaml_string_list tailout#out) + ; desc (af "err: %s" err) (ocaml_string_list tailerr#out) ] :: 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 @@ -220,21 +189,18 @@ module Commands = struct EF.(af "Show the protocol's “bootstrap” accounts") ["boa"; "bootstrap-accounts"] (fun () -> - say - state + say state EF.( - desc - (af "Secret Keys:") + desc (af "Secret Keys:") (ocaml_list - (List.map - (Tezos_protocol.bootstrap_accounts protocol) + (List.map (Tezos_protocol.bootstrap_accounts protocol) ~f:(fun acc -> let open Tezos_protocol.Account in ocaml_tuple - [ atom (name acc); - af "Pub:%s" (pubkey acc); - af "Hash:%s" (pubkey_hash acc); - atom (private_key acc) ]))))) + [ atom (name acc) + ; af "Pub:%s" (pubkey acc) + ; af "Hash:%s" (pubkey_hash acc) + ; atom (private_key acc) ]))))) let show_connections state nodes = unit_loop_no_args @@ -247,105 +213,72 @@ module Commands = struct EF.( desc (wf "Show the balances of all known accounts") - (desc_list - (wf "Options") + (desc_list (wf "Options") [Sexp_options.port_number_doc state ~default_port])) ["sb"; "show-balances"] (fun sexps -> Sexp_options.port_number state sexps ~default_port >>= fun port -> - curl state ~port ~path:"/chains/main/blocks/head/context/contracts" - >>= (function - | `Success res -> ( - try - let json = - Ezjsonm.from_string (String.concat ~sep:"\n" res) - in - let contracts = - match json with - | `A sl -> - List.map sl ~f:(function - | `String s -> - s - | _ -> - failwith "Not a string list") - | _ -> - failwith "Not a string list" - in - return contracts - with e -> - say - state - EF.( - desc_list - (shout "Found not contracts!") - [ desc (af "output") (ocaml_string_list res); - desc (af "exn") (exn e) ]) - >>= fun () -> return [] ) - | `Error -> - return []) + curl_rpc state ~port ~path:"/chains/main/blocks/head/context/contracts" + >>= fun json_opt -> + do_jq state ~msg:"Getting contract list" ~f:Jqo.get_strings json_opt >>= fun contracts -> + curl_rpc state ~port ~path:"/chains/main/checkpoint" + >>= fun chkpto -> + do_jq state chkpto ~msg:"Getting checkpoint" + ~f: + Jqo.( + fun json -> + match field ~k:"history_mode" json |> get_string with + | "archive" -> 1 + | _ -> field ~k:"save_point" json |> get_int) + >>= fun save_point -> let balance block contract = let path = - sprintf - "/chains/main/blocks/%s/context/contracts/%s/balance" - block - contract - in - curl state ~port ~path - >>= function - | `Success res -> - return (Some (String.concat ~sep:"" res)) - | `Error -> - return None - in + sprintf "/chains/main/blocks/%s/context/contracts/%s/balance" block + contract in + curl_rpc state ~port ~path + >>= fun jo -> + do_jq state jo ~msg:"Getting balance" ~f:(fun j -> + Jqo.get_string j |> Int.of_string) in List.fold contracts ~init:(return []) ~f:(fun prevm hsh -> prevm >>= fun prev -> - balance "1" hsh + balance (Int.to_string save_point) hsh >>= fun init -> balance "head" hsh >>= fun current -> return ((hsh, init, current) :: prev)) >>= fun results -> - say - state + say state EF.( desc_list - (af "Balances (from :%d)" port) + (af "Balances from levels %d to “head” (port :%d)" save_point + port) (List.map results ~f:(fun (hsh, init, cur) -> - desc - (haf "%S" hsh) - (af - "%s → %s" - (Option.value init ~default:"???") - (Option.value cur ~default:"???")))))) + let tz i = float i /. 1_000_000. in + desc (haf "%s:" hsh) + ( if init = cur then af "%f (unchanged)" (tz cur) + else af "%f → %f" (tz init) (tz cur) ))))) let arbitrary_command_on_clients ?make_admin ?(command_names = ["cc"; "client-command"]) state ~clients = Prompt.unit_and_loop EF.( desc - (wf - "Run a tezos-client command on %s" + (wf "Run a tezos-client command on %s" ( match clients with - | [] -> - "NO CLIENT, so this is useless…" - | [one] -> - sprintf "the %S client." one.Tezos_client.id + | [] -> "NO CLIENT, so this is useless…" + | [one] -> sprintf "the %S client." one.Tezos_client.id | more -> - sprintf - "all the following clients: %s." + sprintf "all the following clients: %s." ( List.map more ~f:(fun c -> c.Tezos_client.id) |> String.concat ~sep:", " ) )) Sexp_options.( option_list_doc - [ option_doc - "(only )" - (wf "Restrict the clients by name"); - option_doc - "(admin)" - (wf - "Use the admin-client instead%s" + [ option_doc "(only )" + (wf "Restrict the clients by name") + ; option_doc "(admin)" + (wf "Use the admin-client instead%s" (match make_admin with None -> " (DISABLED)" | _ -> "")) ])) command_names @@ -357,48 +290,37 @@ module Commands = struct let subset_of_clients = let open Base.Sexp in List.find_map sexps ~f:(function - | List (Atom "only" :: l) -> - Some - (List.map l ~f:(function - | Atom a -> - a - | other -> - ksprintf - failwith - "Option `only` only accepts a list of names: %s" - (to_string_hum other))) - | _ -> - None) + | List (Atom "only" :: l) -> + Some + (List.map l ~f:(function + | Atom a -> a + | other -> + ksprintf failwith + "Option `only` only accepts a list of names: %s" + (to_string_hum other))) + | _ -> None) |> function - | None -> - clients + | None -> clients | Some more -> List.filter clients ~f:(fun c -> - List.mem more c.Tezos_client.id ~equal:String.equal) - in + List.mem more c.Tezos_client.id ~equal:String.equal) in let use_admin = match make_admin with - | None -> - `Client + | None -> `Client | Some of_client -> if - List.exists - sexps + List.exists sexps ~f: Base.Sexp.( function List [Atom "admin"] -> true | _ -> false) then `Admin of_client - else `Client - in + else `Client in List.fold ~init:(return []) subset_of_clients ~f:(fun prevm client -> prevm >>= fun prev -> - Running_processes.run_cmdf - state - "sh -c %s" + Running_processes.run_cmdf state "sh -c %s" ( ( match use_admin with - | `Client -> - Tezos_client.client_command client ~state args + | `Client -> Tezos_client.client_command client ~state args | `Admin mkadm -> Tezos_admin_client.make_command (mkadm client) state args ) @@ -406,43 +328,30 @@ module Commands = struct >>= fun res -> display_errors_of_command state res >>= function - | true -> - return ((client, String.concat ~sep:"\n" res#out) :: prev) - | false -> - return prev) + | true -> return ((client, String.concat ~sep:"\n" res#out) :: prev) + | false -> return prev) >>= fun results -> let different_results = List.dedup_and_sort results ~compare:(fun (_, a) (_, b) -> - String.compare a b) - in - say - state + String.compare a b) in + say state EF.( - desc_list - (af "Done") - [ desc - (haf "Command:") + desc_list (af "Done") + [ desc (haf "Command:") (ocaml_string_list ( ( match use_admin with - | `Client -> - "" - | `Admin _ -> - "" ) - :: args )); - desc - (haf "Results") + | `Client -> "" + | `Admin _ -> "" ) + :: args )) + ; desc (haf "Results") (list (List.map different_results ~f:(fun (_, res) -> let clients = List.filter_map results ~f:(function - | (c, r) when res = r -> - Some c.Tezos_client.id - | _ -> - None) - in + | c, r when res = r -> Some c.Tezos_client.id + | _ -> None) in desc - (haf - "Client%s %s:" + (haf "Client%s %s:" ( if List.length subset_of_clients = 1 then "" else "s" ) (String.concat ~sep:", " clients)) @@ -450,100 +359,75 @@ module Commands = struct let all_defaults state ~nodes = let default_port = (List.hd_exn nodes).Tezos_node.rpc_port in - [ du_sh_root state; - processes state; - show_connections state nodes; - curl_level state ~default_port; - balances state ~default_port; - curl_metadata state ~default_port; - curl_baking_rights state ~default_port; - all_levels state ~nodes; - show_process state; - kill_all state ] + [ du_sh_root state; processes state + ; show_connections state nodes + ; curl_level state ~default_port + ; balances state ~default_port + ; curl_metadata state ~default_port + ; curl_baking_rights state ~default_port + ; all_levels state ~nodes; show_process state; kill_all state ] end module Interactivity = struct type t = [`Full | `None | `On_error | `At_end] - let is_interactive (state : < test_interactivity : t ; .. >) = + let is_interactive (state : < test_interactivity: t ; .. >) = state#test_interactivity = `Full let pause_on_error state = match state#test_interactivity with - | `Full | `On_error | `At_end -> - true - | `None -> - false + | `Full | `On_error | `At_end -> true + | `None -> false let pause_on_success state = match state#test_interactivity with - | `Full | `At_end -> - true - | `None | `On_error -> - false + | `Full | `At_end -> true + | `None | `On_error -> false let cli_term ?(default : t = `None) () = let open Cmdliner in Term.( pure (fun interactive pause_end pause_error -> match (interactive, pause_end, pause_error) with - | (true, _, _) -> - `Full - | (false, true, _) -> - `At_end - | (false, false, true) -> - `On_error - | (false, false, false) -> - `None) + | true, _, _ -> `Full + | false, true, _ -> `At_end + | false, false, true -> `On_error + | false, false, false -> `None) $ Arg.( value - & opt - bool + & opt bool ( match default with - | `None | `On_error | `At_end -> - false - | `Full -> - true ) + | `None | `On_error | `At_end -> false + | `Full -> true ) & info ["interactive"] ~doc:"Add all pauses with command prompts.") $ Arg.( value - & opt - bool + & opt bool ( match default with - | `None | `On_error -> - false - | `At_end | `Full -> - true ) - & info - ["pause-at-end"] + | `None | `On_error -> false + | `At_end | `Full -> true ) + & info ["pause-at-end"] ~doc:"Add a pause with a command prompt at the end of the test.") $ Arg.( value - & opt - bool + & opt bool ( match default with - | `None -> - false - | `At_end | `Full | `On_error -> - true ) - & info - ["pause-on-error"] + | `None -> false + | `At_end | `Full | `On_error -> true ) + & info ["pause-on-error"] ~doc: "Add a pause with a command prompt at the end of the test, \ only in case of test failure.")) end module Pauser = struct - type t = { - mutable extra_commands : Prompt.item list; - default_end : [`Sleep of float]; - } + type t = + {mutable extra_commands: Prompt.item list; default_end: [`Sleep of float]} - let make ?(default_end = `Sleep 2.) extra_commands = + let make ?(default_end = `Sleep 0.5) extra_commands = {extra_commands; default_end} let commands state = state#pauser.extra_commands - let default_end state = state#pauser.default_end let add_commands state cl = @@ -551,12 +435,11 @@ module Pauser = struct let generic state ?(force = false) msgs = let do_pause = Interactivity.is_interactive state || force in - say - state + say state EF.( desc (if do_pause then haf "Pause" else haf "Not pausing") - (list ~param:{default_list with space_before_separator = false} msgs)) + (list ~param:{default_list with space_before_separator= false} msgs)) >>= fun () -> if do_pause then Prompt.(command state ~commands:(commands state)) else return () @@ -568,43 +451,71 @@ module Pauser = struct Running_processes.kill_all state >>= fun () -> say state EF.(af "Waiting for processes to all die.") - >>= fun () -> Running_processes.wait_all state - in + >>= fun () -> Running_processes.wait_all state in Sys.catch_break false ; let cond = Lwt_condition.create () in - let _ = + let () = Lwt_unix.on_signal Sys.sigint (fun i -> - Printf.eprintf "SIGINTED (%d)\n%!" i ; - Lwt_condition.broadcast cond `Sigint) - in + Printf.eprintf + "\nReceived signal SIGINT (%d), type `q` to quit prompts.\n\n%!" i ; + Lwt_condition.broadcast cond "INT") + |> ignore ; + Lwt_unix.on_signal Sys.sigterm (fun i -> + Printf.eprintf + "\nReceived signal SIGTERM (%d), type `q` to quit prompts.\n\n%!" i ; + Lwt_condition.broadcast cond "TERM") + |> ignore in let wait () = Lwt_exception.catch Lwt_condition.wait cond - >>= fun `Sigint -> Lwt_exception.fail (Failure "Interrupted") - in + >>= fun sig_name -> Lwt_exception.fail (Failure sig_name) in Dbg.e EF.(wf "Running test %s on %s" state#application_name (Paths.root state)) ; - Asynchronous_result.bind_on_error - ( (try Lwt.pick [f (); wait ()] with e -> fail (`Lwt_exn e)) - >>= fun () -> - ( match (Interactivity.pause_on_success state, default_end state) with - | (true, _) -> - generic state ~force:true EF.[af "Scenario done; pausing"] - | (false, `Sleep n) -> - say state EF.(wf "Test done, sleeping %.02f seconds" n) - >>= fun () -> System.sleep n ) - >>= fun () -> finish () ) - ~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" - (fun ppf c -> Attached_result.pp ppf c ~pp_error) - result) ] + let rec protect procedure = + Asynchronous_result.bind_on_error + ( (try Lwt.pick [procedure (); wait ()] with e -> fail (`Lwt_exn e)) >>= fun () -> - finish () >>= fun () -> fail error_value ~attach:result.attachments) + ( match (Interactivity.pause_on_success state, default_end state) with + | true, _ -> generic state ~force:true EF.[af "Scenario done; pausing"] + | false, `Sleep n -> + say state EF.(wf "Test done, sleeping %.02f seconds" n) + >>= fun () -> System.sleep n ) + >>= fun () -> finish () ) + ~f:(fun ~result error_value -> + ( match error_value with + | `Lwt_exn (Failure sigterm) when sigterm = "TERM" -> + Console.say state + EF.( + desc (shout "Received SIGTERM") + (wf + "Will not pause because it's the wrong thing to do; \ + killing everything and quitting.")) + | `Lwt_exn End_of_file -> + Console.say state + EF.( + desc + (shout "Received End-of-File (Ctrl-D?)") + (wf + "Cannot pause because interactivity broken; killing \ + everything and quitting.")) + | _ when Interactivity.pause_on_error state -> + protect (fun () -> + generic state ~force:true + EF. + [ haf + "Last pause before the test will Kill 'Em All and \ + Quit." + ; desc (shout "Error:") + (af "%a" + (fun ppf c -> Attached_result.pp ppf c ~pp_error) + result) ]) + | _ -> + Console.say state + EF.( + desc + (shout "Dying of Exception") + (wf "Killing everything and quitting now.")) ) + >>= fun () -> + finish () >>= fun () -> fail error_value ~attach:result.attachments) + in + protect f end diff --git a/vendors/flextesa-lib/interactive_test.mli b/vendors/flextesa-lib/interactive_test.mli new file mode 100644 index 000000000000..3c935eee5a9b --- /dev/null +++ b/vendors/flextesa-lib/interactive_test.mli @@ -0,0 +1,200 @@ +(** Tools to manage interactivity in test scenarios. *) + +open Internal_pervasives + +(** Implementations of common {!Console.Prompt.item}. *) +module Commands : sig + val cmdline_fail : + ( 'a + , Format.formatter + , unit + , ('b, [> `Command_line of string]) Asynchronous_result.t ) + format4 + -> 'a + + val no_args : + 'a list -> (unit, [> `Command_line of string]) Asynchronous_result.t + + val flag : string -> Sexplib0.Sexp.t list -> bool + + val unit_loop_no_args : + Easy_format.t + -> string list + -> ( unit + -> ( unit + , [`Command_line of string | `Lwt_exn of exn] ) + Asynchronous_result.t) + -> Console.Prompt.item + + val du_sh_root : + < application_name: string + ; console: Console.t + ; paths: Paths.t + ; runner: Running_processes.State.t + ; .. > + -> Console.Prompt.item + + val processes : + < application_name: string + ; console: Console.t + ; runner: Running_processes.State.t + ; .. > + -> Console.Prompt.item + + val curl_rpc : + < application_name: string + ; console: Console.t + ; paths: Paths.t + ; runner: Running_processes.State.t + ; .. > + -> port:int + -> path:string + -> ( Ezjsonm.value option + , [> `Command_line of string | `Lwt_exn of exn] ) + Asynchronous_result.t + + val do_jq : + < application_name: string ; console: Console.t ; paths: Paths.t ; .. > + -> msg:string + -> f:(Ezjsonm.value -> 'b) + -> Ezjsonm.value option + -> ('b, [> `Command_line of string]) Asynchronous_result.t + + val curl_unit_display : + ?jq:(Ezjsonm.value -> Ezjsonm.value) + -> < application_name: string + ; console: Console.t + ; paths: Paths.t + ; runner: Running_processes.State.t + ; .. > + -> string list + -> default_port:int + -> path:string + -> doc:string + -> Console.Prompt.item + + val curl_metadata : + < application_name: string + ; console: Console.t + ; paths: Paths.t + ; runner: Running_processes.State.t + ; .. > + -> default_port:int + -> Console.Prompt.item + + val curl_level : + < application_name: string + ; console: Console.t + ; paths: Paths.t + ; runner: Running_processes.State.t + ; .. > + -> default_port:int + -> Console.Prompt.item + + val curl_baking_rights : + < application_name: string + ; console: Console.t + ; paths: Paths.t + ; runner: Running_processes.State.t + ; .. > + -> default_port:int + -> Console.Prompt.item + + val all_levels : + < application_name: string + ; console: Console.t + ; paths: Paths.t + ; runner: Running_processes.State.t + ; .. > + -> nodes:Tezos_node.t list + -> Console.Prompt.item + + val show_process : + < application_name: string + ; console: Console.t + ; paths: Paths.t + ; runner: Running_processes.State.t + ; .. > + -> Console.Prompt.item + + val kill_all : + < runner: Running_processes.State.t ; .. > -> Console.Prompt.item + + val secret_keys : + < application_name: string ; console: Console.t ; .. > + -> protocol:Tezos_protocol.t + -> Console.Prompt.item + + val arbitrary_command_on_clients : + ?make_admin:(Tezos_client.t -> Tezos_admin_client.t) + -> ?command_names:string list + -> < application_name: string + ; console: Console.t + ; paths: Paths.t + ; runner: Running_processes.State.t + ; .. > + -> clients:Tezos_client.t list + -> Console.Prompt.item + + val all_defaults : + < application_name: string + ; console: Console.t + ; paths: Paths.t + ; runner: Running_processes.State.t + ; .. > + -> nodes:Tezos_node.t list + -> Console.Prompt.item list +end + +(** Configurable (through {!Cmdliner.Term.t}) interactivity of + test-scenarios. *) +module Interactivity : sig + type t = [`Full | `None | `On_error | `At_end] + + val pause_on_error : < test_interactivity: t ; .. > -> bool + val pause_on_success : < test_interactivity: t ; .. > -> bool + val is_interactive : < test_interactivity: t ; .. > -> bool + val cli_term : ?default:t -> unit -> t Cmdliner.Term.t +end + +(** A {!Pauser.t} is tool to include optional prompting pauses in + test-scenarios. *) +module Pauser : sig + type t = private + { mutable extra_commands: Console.Prompt.item list + ; default_end: [`Sleep of float] } + + val make : ?default_end:[`Sleep of float] -> Console.Prompt.item list -> t + + val add_commands : < pauser: t ; .. > -> Console.Prompt.item list -> unit + (** Add commands to the current pauser. *) + + val generic : + < application_name: string + ; console: Console.t + ; pauser: t + ; test_interactivity: Interactivity.t + ; .. > + -> ?force:bool + -> Easy_format.t list + -> (unit, [> `Lwt_exn of exn]) Asynchronous_result.t + (** Pause the test according to [state#interactivity] (overridden + with [~force:true]), the pause displays the list of + {!Easy_format.t}s and prompts the user for commands (see + {!add_commands}). *) + + val run_test : + < application_name: string + ; console: Console.t + ; paths: Paths.t + ; pauser: t + ; runner: Running_processes.State.t + ; test_interactivity: Interactivity.t + ; .. > + -> (unit -> (unit, ([> `Lwt_exn of exn] as 'errors)) Asynchronous_result.t) + -> pp_error:(Format.formatter -> 'errors -> unit) + -> unit + -> (unit, 'errors) Asynchronous_result.t + (** Run a test-scenario and deal with potential errors according + to [state#test_interactivity]. *) +end diff --git a/src/lib_network_sandbox/internal_pervasives.ml b/vendors/flextesa-lib/internal_pervasives.ml similarity index 70% rename from src/lib_network_sandbox/internal_pervasives.ml rename to vendors/flextesa-lib/internal_pervasives.ml index b5d3607df8e7..ef6eb300d2e8 100644 --- a/src/lib_network_sandbox/internal_pervasives.ml +++ b/vendors/flextesa-lib/internal_pervasives.ml @@ -10,8 +10,7 @@ module Float = Base.Float module Exn = Base.Exn let ( // ) = Filename.concat - -let (ksprintf, sprintf) = Printf.(ksprintf, sprintf) +let ksprintf, sprintf = Printf.(ksprintf, sprintf) (** Wrapper around the [EasyFormat] library to use for console display. *) module EF = struct @@ -20,13 +19,9 @@ module EF = struct open Easy_format let default_list = list - let default_atom = atom - let default_label = label - let atom ?(param = default_atom) s = Atom (s, param) - let label ?(param = label) a b = Label ((a, param), b) let list ?(delimiters = ("", "")) ?(sep = "") ?(param = default_list) l = @@ -35,30 +30,19 @@ module EF = struct let ocaml_list = list ~delimiters:("[", "]") ~sep:";" let ocaml_tuple = - list - ~delimiters:("(", ")") - ~sep:"," + list ~delimiters:("(", ")") ~sep:"," ~param: - { - default_list with - space_after_opening = false; - space_before_closing = false; - } - - let shout = atom ~param:{atom_style = Some "shout"} - - let prompt = atom ~param:{atom_style = Some "prompt"} - - let highlight = atom ~param:{atom_style = Some "prompt"} + { default_list with + space_after_opening= false + ; space_before_closing= false } + let shout = atom ~param:{atom_style= Some "shout"} + let prompt = atom ~param:{atom_style= Some "prompt"} + let highlight = atom ~param:{atom_style= Some "prompt"} let custom pr = Custom pr - let pr f = custom (fun ppf -> f (Format.fprintf ppf)) - let desc_list s l = label s (list ~sep:"," l) - let desc s v = label s v - let af ?param fmt = Format.kasprintf (atom ?param) fmt let wrap s = @@ -67,13 +51,9 @@ module EF = struct |> List.map ~f:atom |> list let wf fmt = Format.kasprintf wrap fmt - let haf fmt = Format.kasprintf highlight fmt - let opt f = function None -> atom "-" | Some o -> f o - let ocaml_string_list l = ocaml_list (ListLabels.map l ~f:(af "%S")) - let exn e = wf "%a" Exn.pp e let markdown_verbatim ?(guard_length = 80) s = @@ -81,34 +61,28 @@ module EF = struct af "\n%s\n%s\n%s@." guard s guard let ef_json msg json = - desc (haf "%s" msg) (markdown_verbatim Ezjsonm.(to_string (wrap json))) + desc (haf "%s" msg) + (markdown_verbatim Ezjsonm.(to_string ~minify:false (wrap json))) end (** Debug-display module (non-cooperative output to [stderr]). *) module Dbg = struct let e ef = EF.( - list - ~delimiters:("") - ~sep:"" + list ~delimiters:("") ~sep:"" ~param: - { - default_list with - separator_style = Some "debug"; - align_closing = true; - space_after_opening = true; - space_before_closing = true; - } + { default_list with + separator_style= Some "debug" + ; align_closing= true + ; space_after_opening= true + ; space_before_closing= true } [ef] |> Easy_format.Pretty.to_stderr) ; Printf.eprintf "\n%!" let i (e : EF.t) = ignore e - let f f = e (EF.pr f) - let any v = Dum.to_eformat v - let pp_any fmt v = Dum.to_formatter fmt v end @@ -117,15 +91,12 @@ module Attached_result = struct type content = [`Text of string | `String_value of string | `Verbatim of string list] - type ('ok, 'error) t = { - result : ('ok, 'error) result; - attachments : (string * content) list; - } + 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 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 @@ -148,8 +119,7 @@ module Attached_result = struct Option.iter pp_error ~f:(fun pp -> pp ppf e) ; pp_close_box ppf () ) ; ( match attachments with - | [] -> - () + | [] -> () | more -> pp_open_vbox ppf 4 ; List.iter more ~f:(fun (k, v) -> @@ -158,10 +128,8 @@ module Attached_result = struct 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 + | `Text s -> pp_print_text ppf s + | `String_value s -> fprintf ppf "%S" s | `Verbatim lines -> pp_open_vbox ppf 0 ; pp_print_cut ppf () ; @@ -197,79 +165,70 @@ module Asynchronous_result = struct let open Lwt.Infix in o >>= function - | {result = Ok o; attachments = attach} -> + | {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 + 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 = + ('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 -> + | {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 = List.dedup_and_sort ~compare (attachments @ attach); - } + { result + ; attachments= List.dedup_and_sort ~compare (attachments @ attach) } let transform_error o ~f = 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} + | {result= Ok _; _} as o -> Lwt.return o + | {result= Error e; attachments} -> + Lwt.return {result= Error (f e); attachments} let enrich : attachment:(string * content) list -> 'a -> ('b, 'c) t = fun ~attachment x -> bind_on_error x ~f:(fun ~result _ -> Lwt.return Attached_result. - {result with attachments = result.attachments @ attachment}) + {result with attachments= result.attachments @ attachment}) let bind_all : - ('ok, 'error) t -> - f:(('ok, 'error) Attached_result.t -> ('ok2, 'error2) t) -> - ('ok2, 'error2) t = + ('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) result -> ('ok2, 'error2) t) -> - ('ok2, 'error2) t = + ('ok, 'error) t + -> f:(('ok, 'error) result -> ('ok2, 'error2) t) + -> ('ok2, 'error2) t = fun o ~f -> let open Lwt.Infix in o - >>= fun {result; attachments = attach} -> + >>= fun {result; attachments= attach} -> f result >>= fun {result; attachments} -> - Lwt.return {result; attachments = attachments @ attach} + Lwt.return {result; attachments= attachments @ attach} (** The module opened everywhere. *) module Std = struct - let ( >>= ) = bind - - let return = return - - let fail = fail + let ( >>= ) = bind let return = return let fail = fail end open Std @@ -292,29 +251,24 @@ module Asynchronous_result = struct let map_option o ~f = match o with - | None -> - return None - | Some s -> - f s >>= fun o -> return (Some o) + | None -> return None + | Some s -> f s >>= fun o -> return (Some o) module Loop = struct let n_times times f = let rec loop n = match n with - | n when n <= 0 -> - return () - | n -> - f (1 + times - n) >>= fun () -> loop (n - 1) - in + | n when n <= 0 -> return () + | n -> f (1 + times - n) >>= fun () -> loop (n - 1) in loop times end module Stream = struct let fold : - 'elt Lwt_stream.t -> - f:('b -> 'elt -> ('b, 'error) t) -> - init:'b -> - ('b, 'error) t = + '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 @@ -322,17 +276,14 @@ module Asynchronous_result = struct Lwt_stream.fold_s (fun elt prevm -> match prevm.result with - | Ok x -> - f x elt + | Ok x -> f x elt | Error _ -> error := Some prevm ; Lwt.fail Not_found) - stream - (Attached_result.ok init)) + stream (Attached_result.ok init)) (fun e -> match !error with - | Some res -> - Lwt.return res + | Some res -> Lwt.return res | None -> (* `f` threw a forbidden exception! *) Lwt.fail e) @@ -340,10 +291,8 @@ module Asynchronous_result = struct let run_application r = match Lwt_main.run (r () : (_, _) t) with - | {result = Ok (); _} -> - exit 0 - | {result = Error (`Die ret); _} -> - exit ret + | {result= Ok (); _} -> exit 0 + | {result= Error (`Die ret); _} -> exit ret end include Asynchronous_result.Std @@ -366,7 +315,6 @@ end module System_error = struct let fail ?attach fmt = ksprintf (fun e -> fail ?attach (`Sys_error e)) fmt - let pp fmt (`Sys_error e) = Format.fprintf fmt "System-error:@ %s" e end @@ -374,21 +322,17 @@ end external processes. *) module Process_result = struct type t = - < err : string list ; out : string list ; status : Unix.process_status > + < err: string list ; out: string list ; status: Unix.process_status > let status_to_string s = Lwt_unix.( match s with - | WEXITED n -> - sprintf "exited with %d" n - | WSIGNALED n -> - sprintf "was signaled: %d" n - | WSTOPPED n -> - sprintf "was stopped: %d" n) + | WEXITED n -> sprintf "exited with %d" n + | WSIGNALED n -> sprintf "was signaled: %d" n + | WSTOPPED n -> sprintf "was stopped: %d" n) module Error = struct type output = t - type t = [`Wrong_status of output * string] let wrong_status (res : output) msgf = @@ -397,9 +341,7 @@ module Process_result = struct let pp fmt = function | (`Wrong_status (res, msg) : [< t]) -> Format.( - fprintf - fmt - "Process-error, wrong status:@ '%s':@ %s" + fprintf fmt "Process-error, wrong status:@ '%s':@ %s" (status_to_string res#status) msg ; fprintf fmt "@.```out@." ; @@ -420,8 +362,7 @@ end (structural) type, this module just defines the [application_name] method. *) module Base_state = struct - type base = < application_name : string > - + type base = < application_name: string > type 'a t = 'a constraint 'a = < base ; .. > end @@ -446,38 +387,30 @@ end (** WIP [jq]-like manipulation in pure OCaml. *) module Jqo = struct let of_string s = Ezjsonm.from_string s - let to_string j = Ezjsonm.(to_string (wrap j)) + let of_lines l = Ezjsonm.value_from_string (String.concat ~sep:"\n" l) let field ~k = function - | `O l -> - List.Assoc.find_exn l ~equal:String.equal k - | other -> - ksprintf failwith "Jqo.field (%S) in %s" k (to_string other) + | `O l -> List.Assoc.find_exn l ~equal:String.equal k + | other -> ksprintf failwith "Jqo.field (%S) in %s" k (to_string other) let list_find ~f = function | `O l -> List.find_map_exn ~f:(fun (_, j) -> if f j then Some j else None) l - | `A l -> - List.find_exn ~f l - | other -> - ksprintf failwith "Jqo.list_find in %s" (to_string other) + | `A l -> List.find_exn ~f l + | other -> ksprintf failwith "Jqo.list_find in %s" (to_string other) let list_exists ~f o = match list_find o ~f with _ -> true | exception _ -> false let remove_field o ~name = match o with - | `O l -> - `O (List.filter l ~f:(fun (k, _) -> k <> name)) + | `O l -> `O (List.filter l ~f:(fun (k, _) -> k <> name)) | other -> - ksprintf - failwith - "Jqo.remove_field %S: No an object: %s" - name + ksprintf failwith "Jqo.remove_field %S: No an object: %s" name (to_string other) let get_string = Ezjsonm.get_string - + let get_strings = Ezjsonm.get_strings let get_int = Ezjsonm.get_int end diff --git a/src/lib_network_sandbox/kiln.ml b/vendors/flextesa-lib/kiln.ml similarity index 67% rename from src/lib_network_sandbox/kiln.ml rename to vendors/flextesa-lib/kiln.ml index e7e613f79a39..6e3c3d55e730 100644 --- a/src/lib_network_sandbox/kiln.ml +++ b/vendors/flextesa-lib/kiln.ml @@ -1,7 +1,7 @@ open Internal_pervasives module Configuration_directory = struct - type t = {path : string; clean : bool; p2p_port : int} + type t = {path: string; clean: bool; p2p_port: int} let generate state ?(protocol_execs = []) t ~peers ~sandbox_json ~nodes ~bakers ~network_string ~node_exec ~client_exec = @@ -9,55 +9,40 @@ module Configuration_directory = struct should be fixed soon. *) let {path; clean; p2p_port} = t in ( if clean then - Running_processes.run_cmdf - state - "rm -fr %s ; mkdir -p %s ; chmod -R 777 %s" - path - path - path + Running_processes.run_cmdf state + "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") + System.write_file state ~perm:0o777 (path // "loggers") ~content: Ezjsonm.( `A [ dict - [ ("logger", dict [("Stderr", dict [])]); - ( "filters", - dict [("SQL", string "Error"); ("", string "Info")] ) ] ] + [ ("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 + 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)]) ] + [ ("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 + 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 + if Filename.is_relative path then pwd // path else path in + System.write_file state ~perm:0o777 (path // "kiln-node-custom-args") ~content: (sprintf @@ -69,47 +54,32 @@ module Configuration_directory = struct (List.length peers - 1) sandbox_json) >>= fun () -> - System.write_file - state - ~perm:0o777 - (path // "nodes") + System.write_file state ~perm:0o777 (path // "nodes") ~content:(String.concat ~sep:"," nodes) >>= fun () -> - System.write_file - state - ~perm:0o777 - (path // "bakers") + 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") + System.write_file state ~perm:0o777 (path // "network") ~content:network_string >>= fun () -> - System.write_file - state - ~perm:0o777 + System.write_file state ~perm:0o777 (path // "enable-obsidian-node") ~content:(sprintf "%b" false) >>= fun () -> - System.write_file - state - ~perm:0o777 - (path // "binary-paths") + System.write_file state ~perm:0o777 (path // "binary-paths") ~content: Ezjsonm.( let absolutize exec = let path = Tezos_executable.get exec in - absolutize path - in + absolutize path in dict - [ ("node-path", string (absolutize node_exec)); - ("client-path", string (absolutize client_exec)); - ( "baker-endorser-paths", - list + [ ("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 ) ] diff --git a/src/lib_network_sandbox/kiln.mli b/vendors/flextesa-lib/kiln.mli similarity index 100% rename from src/lib_network_sandbox/kiln.mli rename to vendors/flextesa-lib/kiln.mli diff --git a/vendors/flextesa-lib/liquidity.ml b/vendors/flextesa-lib/liquidity.ml new file mode 100644 index 000000000000..05257ee05a47 --- /dev/null +++ b/vendors/flextesa-lib/liquidity.ml @@ -0,0 +1,346 @@ +open Internal_pervasives +module MFmt = Experiments.Markup_fmt + +let failf ?attach fmt = + ksprintf (fun s -> fail ?attach (`Scenario_error s)) fmt + +module Data = struct + type t = Fmt of (Format.formatter -> unit) + + let to_string = function + | Fmt f -> Format.asprintf "%a" (fun ppf () -> f ppf) () + + let pp ppf (Fmt f) = + let open Fmt in + box (fun ppf () -> f ppf) ppf () + + let rawf fmt = + Format.kasprintf (fun s -> Fmt (fun ppf -> Fmt.string ppf s)) fmt + + let fmt f = Fmt f + let address s = rawf "%s" s + + let list_like ~sep ~delimiter l = + Fmt + Fmt.( + fun ppf -> + delimiter + (fun ppf () -> list ~sep (fun ppf (Fmt f) -> f ppf) ppf l) + ppf ()) + + let tuple l = list_like ~sep:Fmt.comma ~delimiter:Fmt.parens l + let int i = Fmt (fun ppf -> Fmt.int ppf i) + let string = rawf "%S" + let nat d = rawf "%dp" d + + let tez (`Mutez d) = + let million = 1_000_000. in + rawf "%ftz" (float d /. million) + + let semi_colon = Fmt.(fun ppf () -> string ppf ";" ; sp ppf ()) + let list l = list_like ~sep:semi_colon ~delimiter:Fmt.brackets l + + let set l = + list_like ~sep:semi_colon l + ~delimiter:Fmt.(fun x ppf -> pf ppf "@[<6>(Set [%a]@])" x) + + let empty_set = set [] + let key_hash s = rawf "%s" s + let key s = rawf "%s" s + let account_key a = Tezos_protocol.Account.pubkey a |> key + let account_key_hash a = Tezos_protocol.Account.pubkey_hash a |> key_hash + let signature s = rawf "%s" s + let bytes s = rawf "0x%s" s + let some s = fmt (fun ppf -> Fmt.pf ppf "@[<5>(Some %a)@]" pp s) + let none = rawf "None" + let typed_none t = rawf "(None : %s)" t + + let record l = + list_like ~sep:semi_colon ~delimiter:Fmt.braces + (List.map l ~f:(fun (k, v) -> + fmt Fmt.(fun ppf -> pf ppf "@[<2>%s =@ %a@]" k pp v))) +end + +module Contract = struct + type t = {name: string; paths: string list; main_name: string option} + + let make ?(library = []) ?main_name name ~path = + {name; paths= library @ [path]; main_name} + + let build_dir state t = + Paths.root state // sprintf "liquidity-build-%s" t.name + + let ensure_build_dir state t = + let dir = build_dir state t in + Running_processes.run_successful_cmdf state "mkdir -p %s" + (Filename.quote dir) + >>= fun _ -> return dir + + let base_liquidity_command _state t = + sprintf "liquidity %s %s" + (List.map t.paths ~f:Filename.quote |> String.concat ~sep:" ") + (Option.value_map t.main_name ~default:"" ~f:(sprintf "--main %s")) + + let michelson state t = + let f = build_dir state t // sprintf "%s.tz" t.name in + ensure_build_dir state t + >>= fun _ -> + Running_processes.run_successful_cmdf state "%s --no-annot -o %s" + (base_liquidity_command state t) + (Filename.quote f) + >>= fun _ -> return f + + let storage_initialization state t ~tezos_node ~storage = + ensure_build_dir state t + >>= fun dir -> + let out = dir // sprintf "%s-initial-storage.tz" t.name in + Running_processes.run_successful_cmdf state + "%s -o %s --tezos-node %s --init-storage %s" + (base_liquidity_command state t) + (Filename.quote out) + (Filename.quote tezos_node) + ( List.map storage ~f:(fun item -> Filename.quote (Data.to_string item)) + |> String.concat ~sep:" " ) + >>= fun _ -> System.read_file state out >>= fun content -> return content + + let arguments state t ~entry_point ~data = + Running_processes.run_successful_cmdf state "%s --data %s %s" + (base_liquidity_command state t) + (Filename.quote entry_point) + (Filename.quote (Data.to_string data)) + >>= fun res -> return (String.concat ~sep:" " res#out) + + let cmdliner_term ~prefix ~name () = + let contract_name = name in + let open Cmdliner in + let open Term in + let flag_name s = sprintf "%s-%s" prefix s in + Arg.( + pure (fun path main_name library -> + make ~library ?main_name ~path contract_name) + $ required + (opt (some non_dir_file) None + (info [flag_name "path"] + ~doc: + (sprintf "Path to the liquidity %s contract." contract_name))) + $ value + (opt (some string) None + (info [flag_name "main"] + ~doc: + (sprintf "Name of “main” contract for %s." contract_name))) + $ value + (opt + (list ~sep:',' non_dir_file) + [] + (info [flag_name "library"] + ~doc: + (sprintf + "Paths to extra liquidity %s contract-library files." + contract_name)))) +end + +module On_chain = struct + let tezos_client_keyed_originate_contract ?(force = false) + ?(transferring = 0) ?(burn_cap = 0.5) state keyed ~name ~source ~storage + = + let client = keyed.Tezos_client.Keyed.client in + Tezos_client.successful_client_cmd state ~client + ( [ "--wait"; "none"; "originate"; "contract"; name; "for"; keyed.key_name + ; "transferring"; Int.to_string transferring; "from"; keyed.key_name + ; "running"; source; "--init"; storage; "--burn-cap" + ; Float.to_string burn_cap ] + @ if force then ["--force"] else [] ) + + let build_and_deploy ?(burn_cap = 10.1) state contract ~keyed_client ~storage + ~balance = + let name = contract.Contract.name in + let tezos_node = + sprintf "http://localhost:%d" keyed_client.Tezos_client.Keyed.client.port + in + Contract.michelson state contract + >>= fun michetz -> + Contract.storage_initialization state contract ~tezos_node + ~storage:(List.map storage ~f:snd) + >>= fun init -> + tezos_client_keyed_originate_contract state keyed_client ~name + ~transferring:balance ~source:michetz ~storage:init ~burn_cap ~force:true + >>= fun _ -> + Tezos_client.Keyed.bake state keyed_client (sprintf "%s origination" name) + >>= fun () -> + Tezos_client.successful_client_cmd state + ~client:keyed_client.Tezos_client.Keyed.client + ["show"; "known"; "contract"; name] + >>= fun res -> + let address = String.strip (String.concat ~sep:"" res#out) in + Console.sayf state + MFmt.( + par (t "Deployed " @ hlf "“%s”" name) + @ itemize [tf "Script: `%s`" michetz; tf "Address: `%s`" address] + @ par (tf "Storage:") + @ itemize + (List.map storage ~f:(fun (name, data) -> + tf "%s:@ %a" name Data.pp data)) + |> to_fmt) + >>= fun () -> return address + + (* This should go to flextesa soon... *) + let silent_client_cmd state ~client args = + Running_processes.run_cmdf state "sh -c %s" + ( Tezos_client.client_command client ~state args + |> Genspio.Compile.to_one_liner |> Filename.quote ) + >>= fun res -> + let success = res#status = Lwt_unix.WEXITED 0 in + return (success, res) + + let call ?msg ?(should = `Be_ok) ?(transferring = 0) ?(burn_cap = 0.3) state + contract ~keyed_client ~entry_point ~data = + Contract.arguments state contract ~entry_point ~data + >>= fun low_level_arg -> + silent_client_cmd state ~client:keyed_client.Tezos_client.Keyed.client + [ "--wait"; "none"; "transfer"; Int.to_string transferring; "from" + ; keyed_client.key_name; "to"; contract.name; "--burn-cap" + ; Float.to_string burn_cap; "--arg"; low_level_arg ] + >>= fun (succeeds, res) -> + ( match succeeds with + | false -> ( + match should with + | `Fail -> return (`Expected `Failure) + | `Script_failwith_re re -> + let intersting_part = + List.drop_while res#err ~f:(fun line -> + String.is_prefix line ~prefix:"script reached FAILWITH") + |> String.concat ~sep:" " in + if Re.execp re intersting_part then return (`Expected `Failure) + else return (`Failed `With_error_does_not_match) + | `Command_stderr_re re -> + if Re.execp re (String.concat ~sep:"\n" res#err) then + return (`Expected `Failure) + else return (`Failed `With_error_does_not_match) + | `Be_ok -> return (`Failed `Not_ok) ) + | true when should = `Be_ok -> + silent_client_cmd state ~client:keyed_client.client + [ "bake"; "for"; keyed_client.key_name; "--force" + ; "--minimal-timestamp" ] + >>= fun (_bake, _) -> return (`Expected `Ok) + | true (* should is no ok *) -> return (`Failed `Unexpected_ok) ) + >>= fun test_status -> + let test_full_name = + sprintf "%s#%s%s" contract.name entry_point + (Option.value_map msg ~default:"" ~f:(sprintf " (%s)")) in + Console.sayf state + MFmt.( + let details = + match test_status with + | `Expected _ -> [] + | `Failed _ -> + par (tf "Data:") + @ verbatim [Data.to_string data] + @ par (tf "Std-out:") + @ verbatim res#out + @ par (tf "Std-err:") + @ verbatim res#err in + par (tf "Test-call %s" test_full_name) + @ itemize + [ ( match test_status with + | `Expected exp -> + hlf "Success: %s" + ( match exp with + | `Ok -> "op-baked" + | `Failure -> "expected-failure" ) + | `Failed reason -> + hlf "FAILURE: %s" + ( match reason with + | `Not_ok -> "Not-OK" + | `Unexpected_ok -> "Should-have-failed" + | `With_error_does_not_match -> + "Error-message-does-not-match" ) ) ] + @ details + |> to_fmt) + >>= fun () -> + match test_status with + | `Expected _ -> return res + | `Failed _ -> failf "Test failed: %s" test_full_name + + let key_with_type_json key = + let open Ezjsonm in + match key with + | `Nat n -> + ( dict [("int", `String (Int.to_string n))] + , dict [("prim", `String "nat")] ) + + let big_map_get state ~client ~address ~key = + let post_json = + let open Ezjsonm in + let k, t = key_with_type_json key in + dict [("key", k); ("type", t)] |> to_string ~minify:false in + Tezos_client.rpc state ~client (`Post post_json) + ~path: + (sprintf "/chains/main/blocks/head/context/contracts/%s/big_map_get" + address) + >>= fun json -> + return + (object + method post = post_json + + method result = json + end) + + let show_contract_command state ~client ~name ~address ~pp_error = + Console.Prompt.unit_and_loop + EF.(wf "Show status of the contract %s." address) + [sprintf "show-%s" name] + (fun _sexps -> + Asynchronous_result.transform_error + ~f:(fun e -> + Format.kasprintf + (fun s -> `Command_line s) + "show-contract: %a" pp_error e) + ( List.fold ["storage"; "balance"] ~init:(return []) + ~f:(fun pm endpoint -> + pm + >>= fun l -> + Tezos_client.rpc state ~client `Get + ~path: + (sprintf "/chains/main/blocks/head/context/contracts/%s/%s" + address endpoint) + >>= fun json -> + return + EF.( + desc (wf "/%s" endpoint) + (markdown_verbatim + (Ezjsonm.value_to_string ~minify:false json)) + :: l)) + >>= fun l -> + Console.say state + EF.( + desc + (haf "Contract %s@%s" name address) + (list ~sep:"" ~delimiters:("", "") l)) )) + + let big_map_get_command state ~names ~thing ~client ~name ~address + ~key_of_string ~pp_error = + Console.Prompt.unit_and_loop + EF.( + wf "Get %s from the big-map of the contract %s@%s." thing name address) + names + (fun sexps -> + Asynchronous_result.transform_error + ~f:(fun e -> + Format.kasprintf + (fun s -> `Command_line s) + "%s: %a" (List.hd_exn names) pp_error e) + ( match sexps with + | [Sexplib.Sexp.Atom s] -> + key_of_string s + >>= fun key -> + big_map_get state ~client ~address ~key + >>= fun getthing -> + Console.sayf state + MFmt.( + par (tf "Posted:") + @ verbatim_raw getthing#post + @ par (tf "Got:") + @ verbatim_ezjson getthing#result + |> to_fmt) + | _ -> failf "Wrong s-exp command line" )) +end diff --git a/vendors/flextesa-lib/liquidity.mli b/vendors/flextesa-lib/liquidity.mli new file mode 100644 index 000000000000..fa322c385c37 --- /dev/null +++ b/vendors/flextesa-lib/liquidity.mli @@ -0,0 +1,196 @@ +open Internal_pervasives + +module Data : sig + type t + + val to_string : t -> string + val rawf : ('a, Format.formatter, unit, t) format4 -> 'a + val empty_set : t + val address : string -> t + val tuple : t list -> t + val int : int -> t + val string : string -> t + val nat : int -> t + val tez : [`Mutez of int] -> t + val list : t list -> t + val set : t list -> t + val key_hash : string -> t + val key : string -> t + val account_key : Tezos_protocol.Account.t -> t + val account_key_hash : Tezos_protocol.Account.t -> t + val signature : string -> t + val bytes : string -> t + val some : t -> t + val none : t + val typed_none : string -> t + val record : (string * t) list -> t +end + +module Contract : sig + type t = private {name: string; paths: string list; main_name: string option} + + val make : + ?library:string list -> ?main_name:string -> string -> path:string -> t + + val build_dir : < paths: Paths.t ; .. > -> t -> string + + val ensure_build_dir : + < paths: Paths.t ; runner: Running_processes.State.t ; .. > Base_state.t + -> t + -> ( string + , [> `Lwt_exn of exn | `Wrong_status of Process_result.t * string] ) + Asynchronous_result.t + + val base_liquidity_command : 'a -> t -> string + + val michelson : + < paths: Paths.t ; runner: Running_processes.State.t ; .. > Base_state.t + -> t + -> ( string + , [> `Lwt_exn of exn | `Wrong_status of Process_result.t * string] ) + Asynchronous_result.t + + val storage_initialization : + < application_name: string + ; paths: Paths.t + ; runner: Running_processes.State.t + ; .. > + -> t + -> tezos_node:string + -> storage:Data.t list + -> ( string + , [> `Lwt_exn of exn | `Wrong_status of Process_result.t * string] ) + Asynchronous_result.t + + val arguments : + < paths: Paths.t ; runner: Running_processes.State.t ; .. > Base_state.t + -> t + -> entry_point:string + -> data:Data.t + -> ( string + , [> `Lwt_exn of exn | `Wrong_status of Process_result.t * string] ) + Asynchronous_result.t + + val cmdliner_term : prefix:string -> name:string -> unit -> t Cmdliner.Term.t +end + +module On_chain : sig + val tezos_client_keyed_originate_contract : + ?force:bool + -> ?transferring:int + -> ?burn_cap:float + -> < application_name: string + ; console: Console.t + ; paths: Paths.t + ; runner: Running_processes.State.t + ; .. > + -> Tezos_client.Keyed.t + -> name:string + -> source:string + -> storage:string + -> ( < err: string list ; out: string list ; status: Unix.process_status > + , [> `Client_command_error of string * string list option + | `Lwt_exn of exn ] ) + Asynchronous_result.t + + val build_and_deploy : + ?burn_cap:float + -> < application_name: string + ; console: Console.t + ; operations_log: Log_recorder.Operations.t + ; paths: Paths.t + ; runner: Running_processes.State.t + ; .. > + -> Contract.t + -> keyed_client:Tezos_client.Keyed.t + -> storage:(string * Data.t) list + -> balance:int + -> ( string + , [> `Client_command_error of string * string list option + | `Lwt_exn of exn + | `Wrong_status of Process_result.t * string ] ) + Asynchronous_result.t + + val silent_client_cmd : + < paths: Paths.t ; runner: Running_processes.State.t ; .. > Base_state.t + -> client:Tezos_client.t + -> string list + -> (bool * Process_result.t, [> `Lwt_exn of exn]) Asynchronous_result.t + + val call : + ?msg:string + -> ?should:[ `Be_ok + | `Fail + | `Script_failwith_re of Re.re + | `Command_stderr_re of Re.re ] + -> ?transferring:int + -> ?burn_cap:float + -> < application_name: string + ; console: Console.t + ; paths: Paths.t + ; runner: Running_processes.State.t + ; .. > + -> Contract.t + -> keyed_client:Tezos_client.Keyed.t + -> entry_point:string + -> data:Data.t + -> ( Process_result.t + , [> `Lwt_exn of exn + | `Scenario_error of string + | `Wrong_status of Process_result.t * string ] ) + Asynchronous_result.t + + val key_with_type_json : [< `Nat of int] -> [> Ezjsonm.t] * [> Ezjsonm.t] + + val big_map_get : + < application_name: string + ; console: Console.t + ; paths: Paths.t + ; runner: Running_processes.State.t + ; .. > + -> client:Tezos_client.t + -> address:string + -> key:[< `Nat of int] + -> ( < post: string ; result: Ezjsonm.value > + , [> `Client_command_error of string * string list option + | `Lwt_exn of exn ] ) + Asynchronous_result.t + + val show_contract_command : + < application_name: string + ; console: Console.t + ; paths: Paths.t + ; runner: Running_processes.State.t + ; .. > + -> client:Tezos_client.t + -> name:string + -> address:string + -> pp_error:( Format.formatter + -> [> `Client_command_error of string * string list option + | `Lwt_exn of exn ] + -> unit) + -> Console.Prompt.item + + val big_map_get_command : + < application_name: string + ; console: Console.t + ; paths: Paths.t + ; runner: Running_processes.State.t + ; .. > + -> names:string list + -> thing:string + -> client:Tezos_client.t + -> name:string + -> address:string + -> key_of_string:( string + -> ( [< `Nat of int] + , ([> `Client_command_error of + string * string list option + | `Lwt_exn of exn + | `Scenario_error of string ] + as + 'a) ) + Asynchronous_result.t) + -> pp_error:(Format.formatter -> 'a -> unit) + -> Console.Prompt.item +end diff --git a/vendors/flextesa-lib/log_recorder.ml b/vendors/flextesa-lib/log_recorder.ml new file mode 100644 index 000000000000..460af9643ebe --- /dev/null +++ b/vendors/flextesa-lib/log_recorder.ml @@ -0,0 +1,45 @@ +open Internal_pervasives + +module Operations = struct + (* This is likely a temporary module, which will be obsoleted by a + more general framework. *) + type t = + { mutable operations: + [ `Bake of string * string * string list + | `Endorse of string * string * string list + | `Transfer of string * string * string * string list ] + list } + + let make () = {operations= []} + let from_state state : t = state#operations_log + + let show_all state = + let t = from_state state in + Console.Prompt.unit_and_loop + EF.(af "Show all manual operations") + ["ao"; "all-ops"; "all-operations"] + (fun _ -> + Console.say state + EF.( + desc_list (haf "Operations:") + (List.rev_map t.operations ~f:(function + | `Transfer (cli, msg, dest, res) -> + desc_list (haf "Transfer: %S" cli) + [ af "→ %s" msg; af "dest: %s" dest + ; ocaml_string_list res ] + | `Endorse (n, msg, res) -> + desc_list + (haf "Node-endorsed: %S" n) + [af "→ %s" msg; ocaml_string_list res] + | `Bake (n, msg, res) -> + desc_list (haf "Node-baked: %S" n) + [af "→ %s" msg; ocaml_string_list res])))) + + let bake state ~client ~output msg = + let t = from_state state in + t.operations <- `Bake (client, msg, output) :: t.operations + + let endorse state ~client ~output msg = + let t = from_state state in + t.operations <- `Endorse (client, msg, output) :: t.operations +end diff --git a/src/lib_network_sandbox/paths.ml b/vendors/flextesa-lib/paths.ml similarity index 100% rename from src/lib_network_sandbox/paths.ml rename to vendors/flextesa-lib/paths.ml diff --git a/src/lib_network_sandbox/paths.mli b/vendors/flextesa-lib/paths.mli similarity index 100% rename from src/lib_network_sandbox/paths.mli rename to vendors/flextesa-lib/paths.mli diff --git a/src/lib_network_sandbox/running_processes.ml b/vendors/flextesa-lib/running_processes.ml similarity index 71% rename from src/lib_network_sandbox/running_processes.ml rename to vendors/flextesa-lib/running_processes.ml index 8460c499283a..34403cb3737f 100644 --- a/src/lib_network_sandbox/running_processes.ml +++ b/vendors/flextesa-lib/running_processes.ml @@ -4,23 +4,15 @@ module Process = struct type kind = [`Process_group | `Docker of string | `Process_group_script of string] - type t = { - id : string; - binary : string option; - command : string list; - kind : kind; - } + type t = {id: string; binary: string option; command: string list; kind: kind} let make_in_session ?binary id kind command = - {id; binary; command = "setsid" :: command; kind} + {id; binary; command= "setsid" :: command; kind} let genspio id script = let script_content = - Format.asprintf - "%a" - Genspio.Compile.To_slow_flow.Script.pp_posix - (Genspio.Compile.To_slow_flow.compile script) - in + Format.asprintf "%a" Genspio.Compile.To_slow_flow.Script.pp_posix + (Genspio.Compile.To_slow_flow.compile script) in let command = ["sh"] in make_in_session id (`Process_group_script script_content) command @@ -29,13 +21,12 @@ module Process = struct let command = ["docker"; "run"; "--name"; name; "--rm"] @ options @ [image] @ args in - {id; binary = None; command; kind = `Docker name} + {id; binary= None; command; kind= `Docker name} end module State = struct - type process_state = {process : Process.t; lwt : Lwt_process.process_none} - - type t = {processes : (string, process_state) Hashtbl.t} + type process_state = {process: Process.t; lwt: Lwt_process.process_none} + type t = {processes: (string, process_state) Hashtbl.t} let pp fmt {processes} = let open Format in @@ -43,8 +34,7 @@ module State = struct Hashtbl.iter (fun s {lwt; _} -> fprintf fmt "%S:%d" s lwt#pid) processes ; fprintf fmt "]@]" - let make () = {processes = Hashtbl.create 42} - + let make () = {processes= Hashtbl.create 42} let processes o = (o#runner : t).processes let add_process o process lwt = @@ -62,41 +52,31 @@ open Process let output_path t process which = let sanitize = - String.map ~f:(function '\'' | '/' | '"' -> '_' | other -> other) - in + String.map ~f:(function '\'' | '/' | '"' -> '_' | other -> other) in Paths.root t // ( "output" // sanitize process.Process.id // match which with - | `Stdout -> - "stdout.log" - | `Stderr -> - "stderr.log" - | `Meta -> - "meta.log" - | `Script -> - "script.sh" ) + | `Stdout -> "stdout.log" + | `Stderr -> "stderr.log" + | `Meta -> "meta.log" + | `Script -> "script.sh" ) let ef_procesess state processes = EF.( - desc_list - (af "Processes") + desc_list (af "Processes") (List.map processes ~f:(fun {process; lwt} -> - desc_list - (af "P:%s" process.id) - [ desc (af "out") (atom (output_path state process `Stdout)); - desc (af "err") (atom (output_path state process `Stderr)); - desc (af "pid") (af "%d" lwt#pid) ]))) + desc_list (af "P:%s" process.id) + [ desc (af "out") (atom (output_path state process `Stdout)) + ; desc (af "err") (atom (output_path state process `Stderr)) + ; desc (af "pid") (af "%d" lwt#pid) ]))) let unix_status_to_string (p : Unix.process_status) = match p with - | Unix.WEXITED i -> - sprintf "exited:%d" i - | Unix.WSIGNALED i -> - sprintf "signaled:%d" i - | Unix.WSTOPPED i -> - sprintf "stopped:%d" i + | Unix.WEXITED i -> sprintf "exited:%d" i + | Unix.WSIGNALED i -> sprintf "signaled:%d" i + | Unix.WSTOPPED i -> sprintf "stopped:%d" i let ef_lwt_state = let open Lwt_process in @@ -109,30 +89,22 @@ let ef ?(all = false) state = Hashtbl.fold (fun _ {process; lwt} prev -> match (all, lwt#state) with - | (true, _) | (false, Lwt_process.Running) -> - ( process.id, - list - ~delimiters:("{", "}") - [ haf "%s:" process.id; - desc (af "pid:") (af "%d" lwt#pid); - desc (af "state:") (ef_lwt_state lwt#state); - desc - (af "kind:") + | true, _ | false, Lwt_process.Running -> + ( process.id + , list ~delimiters:("{", "}") + [ haf "%s:" process.id + ; desc (af "pid:") (af "%d" lwt#pid) + ; desc (af "state:") (ef_lwt_state lwt#state) + ; desc (af "kind:") ( match process.kind with - | `Docker n -> - af "docker:%s" n - | `Process_group -> - af "process-group" - | `Process_group_script _ -> - af "shell-script" ) ] ) + | `Docker n -> af "docker:%s" n + | `Process_group -> af "process-group" + | `Process_group_script _ -> af "shell-script" ) ] ) :: prev - | (_, _) -> - prev) - (State.processes state) - [] + | _, _ -> prev) + (State.processes state) [] |> List.sort ~compare:(fun (a, _) (b, _) -> String.compare a b) - |> List.map ~f:snd - in + |> List.map ~f:snd in label (af "Processes:") (list all_procs)) let start t process = @@ -144,8 +116,7 @@ let start t process = ~attach:[("open_file", `String_value f)] Lwt.Infix.( fun () -> - Tezos_stdlib_unix.Lwt_utils_unix.create_dir - ~perm:0o700 + Tezos_stdlib_unix.Lwt_utils_unix.create_dir ~perm:0o700 (Filename.dirname f) >>= fun () -> Lwt_unix.file_exists f @@ -155,15 +126,13 @@ let start t process = >>= fun () -> Lwt_unix.( openfile f [O_CREAT; O_WRONLY; O_APPEND] 0o600 >|= unix_file_descr)) - () - in + () in open_file (output_path t process `Stdout) >>= fun stdout -> open_file (output_path t process `Stderr) >>= fun stderr -> ( match process.kind with - | `Process_group | `Docker _ -> - return process.command + | `Process_group | `Docker _ -> return process.command | `Process_group_script s -> let path = output_path t process `Script in System.write_file t path ~content:s @@ -171,32 +140,26 @@ let start t process = >>= fun actual_command -> Lwt_exception.catch (fun () -> - Lwt_io.with_file - ~mode:Lwt_io.output + Lwt_io.with_file ~mode:Lwt_io.output ~flags:Unix.[O_CREAT; O_WRONLY; O_APPEND] (output_path t process `Meta) (fun chan -> let msg = let sep = String.make 80 '=' in - sprintf - "\n%s\nDate: %s\nStarting: %s\nCmd: [%s]\n%s\n" - sep - date + sprintf "\n%s\nDate: %s\nStarting: %s\nCmd: [%s]\n%s\n" sep date process.Process.id ( List.map actual_command ~f:(sprintf "%S") |> String.concat ~sep:"; " ) - sep - in + sep in Lwt_io.write chan msg)) () >>= fun () -> let proc = - Lwt_process.open_process_none - ~stdout:(`FD_move stdout) + Lwt_process.open_process_none ~stdout:(`FD_move stdout) ~stderr:(`FD_move stderr) (Option.value ~default:"" process.binary, Array.of_list actual_command) in - State.add_process t process proc >>= fun () -> return {process; lwt = proc} + State.add_process t process proc >>= fun () -> return {process; lwt= proc} let start_full t process = let proc_full = @@ -206,7 +169,7 @@ let start_full t process = let proc = (proc_full :> Lwt_process.process_none) in State.add_process t process proc >>= fun () -> - return {process; lwt = proc} + return {process; lwt= proc} >>= fun proc_state -> return (proc_state, proc_full) let wait _t {lwt; _} = @@ -221,18 +184,15 @@ let kill _t {lwt; process} = let signal = Sys.sigterm in let pid = ~-(lwt#pid) (* Assumes “in session” *) in ( try Unix.kill pid signal with - | Unix.Unix_error (Unix.ESRCH, _, _) -> - () - | e -> - raise e ) ; + | Unix.Unix_error (Unix.ESRCH, _, _) -> () + | e -> raise e ) ; Lwt.return ()) () | `Docker name -> ( Lwt_exception.catch Lwt_unix.system (sprintf "docker kill %s" name) >>= fun status -> match status with - | Lwt_unix.WEXITED 0 -> - return () + | Lwt_unix.WEXITED 0 -> return () | other -> (* Likely already dead *) Dbg.e @@ -240,8 +200,8 @@ let kill _t {lwt; process} = desc (shout "docker kill failed") (list - [ af "docker-container: %s" name; - af "status: %s" (unix_status_to_string other) ])) ; + [ af "docker-container: %s" name + ; af "status: %s" (unix_status_to_string other) ])) ; return () ) let wait_all t = @@ -260,7 +220,7 @@ let find_process_by_id ?(only_running = false) t ~f = State.all_processes t >>= fun all -> return - (List.filter all ~f:(fun {process = {id; _}; lwt} -> + (List.filter all ~f:(fun {process= {id; _}; lwt} -> if only_running && not (lwt#state = Lwt_process.Running) then false else f id)) @@ -268,10 +228,7 @@ let cmds = ref 0 let fresh_id _state prefix ~seed = incr cmds ; - sprintf - "%s-%05d-%s-%08d" - prefix - !cmds + sprintf "%s-%05d-%s-%08d" prefix !cmds Digest.(string seed |> to_hex) Random.(int 10_000_000) @@ -285,8 +242,7 @@ let run_cmdf state fmt = let stream = Lwt_io.read_lines inchan in Lwt_stream.to_list stream >>= fun l -> Lwt_io.close inchan >>= fun () -> return l) - () - in + () in ksprintf (fun s -> let id = fresh_id state "cmd" ~seed:s in @@ -326,8 +282,7 @@ let run_successful_cmdf state fmt = (fun cmd -> run_cmdf state "%s" cmd >>= fun res -> - Process_result.Error.fail_if_non_zero - res + Process_result.Error.fail_if_non_zero res (sprintf "Shell command: %S" cmd) >>= fun () -> return res) fmt diff --git a/src/lib_network_sandbox/running_processes.mli b/vendors/flextesa-lib/running_processes.mli similarity index 100% rename from src/lib_network_sandbox/running_processes.mli rename to vendors/flextesa-lib/running_processes.mli diff --git a/vendors/flextesa-lib/test_api.ml b/vendors/flextesa-lib/test_api.ml new file mode 100644 index 000000000000..51f9ad1ad560 --- /dev/null +++ b/vendors/flextesa-lib/test_api.ml @@ -0,0 +1,107 @@ +open Internal_pervasives +module IFmt = Experiments.More_fmt + +let failf ?attach fmt = + ksprintf (fun s -> fail ?attach (`Scenario_error s)) fmt + +type display_policy = [`All | `Lines of int | `No | `On_error of display_policy] + +let call ?comment ?(expect = `Status `OK) ?(show_body = `All) + ?(show_response = `On_error `All) ?(how = `Get) state ~api_prefix ~path = + let http_method, body = + let json_body json = + Some (Cohttp_lwt.Body.of_string (Ezjsonm.to_string ~minify:false json)) + in + match how with + | `Get -> (`GET, None) + | `Post_json json -> (`POST, json_body json) + | `Delete_json json -> (`DELETE, json_body json) in + let make_body b = + let json = + try Ok (Ezjsonm.value_from_string b) with + | Ezjsonm.Parse_error (_, s) -> Error (sprintf "Error: %s" s) + | e -> Error (sprintf "???: %s" (Exn.to_string e)) in + let lines = + String.split_lines + ( match json with + | Ok j -> Ezjsonm.value_to_string ~minify:false j + | Error _ -> b ) in + (json, lines) in + Lwt_exception.catch + Lwt.( + fun () -> + Cohttp_lwt_unix.Client.call http_method ?body + ~headers:(Cohttp.Header.init_with "content-type" "application/json") + (Uri.of_string (api_prefix // path)) + >>= fun (r, bod) -> + Cohttp_lwt.Body.to_string bod >>= fun bl -> return (r, make_body bl)) + () + >>= fun (coresp, cobody) -> + ( match expect with + | `Status status when Cohttp.Response.status coresp = status -> return `Ok + | `Status status -> + return + (`Failed + (sprintf "API call %s did not return `%s` but `%s`" path + (Cohttp.Code.string_of_status status) + (Cohttp.Response.status coresp |> Cohttp.Code.string_of_status))) + | `Anything -> return `Ok ) + >>= fun test_status -> + Console.sayf state + IFmt.( + let pp_body ?just_lines ppf (json, lines) = + cut ppf () ; + pf ppf "* Body (%d lines, %s)" (List.length lines) + (match json with Ok _ -> "valid JSON" | Error s -> s) ; + if List.length lines > 0 then ( + pf ppf ":" ; + cut ppf () ; + vertical_box ppf ~indent:0 (fun ppf -> + cut ppf () ; + string ppf (String.make 60 '`') ; + List.iter + ( match just_lines with + | None -> lines + | Some n -> List.take lines n ) + ~f:(fun l -> cut ppf () ; string ppf l) ; + ( match just_lines with + | Some n when n < List.length lines -> + cut ppf () ; string ppf "° ° °" + | _ -> () ) ; + cut ppf () ; + string ppf (String.make 60 '`')) ) in + let pp_response ppf () = + cut ppf () ; + pf ppf "* Response:" ; + cut ppf () ; + Sexplib0.Sexp.pp_hum_indent 4 ppf (Cohttp.Response.sexp_of_t coresp) + in + let rec un_option_show f = function + | `On_error _ when test_status = `Ok -> () + | `On_error l -> un_option_show f l + | `No -> () + | `All -> f None + | `Lines l -> f (Some l) in + fun ppf () -> + vertical_box ppf (fun ppf -> + pf ppf "# Called %s /%s → %s `%s`:" + (Cohttp.Code.string_of_method http_method) + path + (if test_status = `Ok then "Expected" else "UNEXPECTED") + (Cohttp.Response.status coresp |> Cohttp.Code.string_of_status) ; + Option.iter comment ~f:(fun c -> + cut ppf () ; string ppf "* " ; c ppf) ; + un_option_show (fun _ -> pp_response ppf ()) show_response ; + un_option_show + (fun just_lines -> pp_body ?just_lines ppf cobody) + show_body)) + >>= fun () -> + match test_status with + | `Ok -> + return + (object + method body_lines = snd cobody + + method body_json = fst cobody + end) + | `Failed s -> failf "%s" s diff --git a/vendors/flextesa-lib/test_api.mli b/vendors/flextesa-lib/test_api.mli new file mode 100644 index 000000000000..2f1b5e973c36 --- /dev/null +++ b/vendors/flextesa-lib/test_api.mli @@ -0,0 +1,18 @@ +(** Test APIs by hitting endpoints. *) + +open Internal_pervasives + +type display_policy = [`All | `Lines of int | `No | `On_error of display_policy] + +val call : + ?comment:(Format.formatter -> unit) + -> ?expect:[< `Anything | `Status of Cohttp.Code.status_code > `Status] + -> ?show_body:display_policy + -> ?show_response:display_policy + -> ?how:[`Get | `Post_json of Ezjsonm.t | `Delete_json of Ezjsonm.t] + -> < console: Console.t ; .. > Base_state.t + -> api_prefix:string + -> path:string + -> ( < body_json: (Ezjsonm.value, string) result ; body_lines: string list > + , [> `Lwt_exn of exn | `Scenario_error of string] ) + Asynchronous_result.t diff --git a/src/lib_network_sandbox/test_command_line.ml b/vendors/flextesa-lib/test_command_line.ml similarity index 99% rename from src/lib_network_sandbox/test_command_line.ml rename to vendors/flextesa-lib/test_command_line.ml index 088b481c1d4f..f0d71bcf7c18 100644 --- a/src/lib_network_sandbox/test_command_line.ml +++ b/vendors/flextesa-lib/test_command_line.ml @@ -41,8 +41,7 @@ let cli_state ?default_interactivity ?(disable_interactivity = false) ~name () method pauser = pauser method operations_log = ops - end - in + end in let open Cmdliner in Term.( pure state $ Console.cli_term () diff --git a/src/lib_network_sandbox/test_command_line.mli b/vendors/flextesa-lib/test_command_line.mli similarity index 100% rename from src/lib_network_sandbox/test_command_line.mli rename to vendors/flextesa-lib/test_command_line.mli diff --git a/src/lib_network_sandbox/test_scenario.ml b/vendors/flextesa-lib/test_scenario.ml similarity index 60% rename from src/lib_network_sandbox/test_scenario.ml rename to vendors/flextesa-lib/test_scenario.ml index 4e05243be75e..9474b08e377b 100644 --- a/src/lib_network_sandbox/test_scenario.ml +++ b/vendors/flextesa-lib/test_scenario.ml @@ -4,58 +4,41 @@ module Inconsistency_error = struct type t = [`Empty_protocol_list | `Too_many_protocols of Tezos_protocol.t list] let should_be_one_protocol = function - | [one] -> - return one - | [] -> - fail `Empty_protocol_list - | more -> - fail (`Too_many_protocols more) + | [one] -> return one + | [] -> fail `Empty_protocol_list + | more -> fail (`Too_many_protocols more) let pp fmt err = - Format.fprintf - fmt - "Wrong number of protocols in network: %d" + Format.fprintf fmt "Wrong number of protocols in network: %d" ( match err with - | `Empty_protocol_list -> - 0 - | `Too_many_protocols p -> - List.length p ) + | `Empty_protocol_list -> 0 + | `Too_many_protocols p -> List.length p ) end module Topology = struct type node = Tezos_node.t type _ t = - | Mesh : {size : int} -> node list t - | Bottleneck : { - name : string; - left : 'a network; - right : 'b network; - } + | Mesh : {size: int} -> node list t + | Bottleneck : + {name: string; left: 'a network; right: 'b network} -> ('a * node * 'b) t - | Net_in_the_middle : { - middle : 'm network; - left : 'a network; - right : 'b network; - } + | Net_in_the_middle : + {middle: 'm network; left: 'a network; right: 'b network} -> ('a * 'm * 'b) t - and 'a network = {topology : 'a t; name : string} + and 'a network = {topology: 'a t; name: string} let make name topology = {name; topology} - let mesh name size = Mesh {size} |> make name - let sub = make - let bottleneck name left right = Bottleneck {name; left; right} |> make name let net_in_the_middle name middle left right = Net_in_the_middle {middle; left; right} |> make name let rec node_count : type a. a t -> int = function - | Mesh {size} -> - size + | Mesh {size} -> size | Bottleneck {left; right; _} -> 1 + node_count left.topology + node_count right.topology | Net_in_the_middle {left; right; middle} -> @@ -65,12 +48,11 @@ module Topology = struct let rec node_ids : type a. a t -> a -> string list = fun topo res -> match (topo, res) with - | (Mesh _, l) -> - List.map l ~f:(fun nod -> nod.Tezos_node.id) - | (Bottleneck {left; right; _}, (l, i, r)) -> + | Mesh _, l -> List.map l ~f:(fun nod -> nod.Tezos_node.id) + | Bottleneck {left; right; _}, (l, i, r) -> (i.Tezos_node.id :: node_ids left.topology l) @ node_ids right.topology r - | (Net_in_the_middle {left; right; middle}, (l, i, r)) -> + | Net_in_the_middle {left; right; middle}, (l, i, r) -> node_ids middle.topology i @ node_ids left.topology l @ node_ids right.topology r @@ -79,8 +61,7 @@ module Topology = struct let make_ith i = sprintf "%s%03d" prefix i in let continue a = node_names ~prefix:(prefix ^ name) a in match topology with - | Mesh {size} -> - List.init size ~f:make_ith + | Mesh {size} -> List.init size ~f:make_ith | Bottleneck {name; left; right} -> (sprintf "%s%s" prefix name :: continue left) @ continue right | Net_in_the_middle {left; right; middle} -> @@ -92,42 +73,28 @@ module Topology = struct let next_port = ref (base_port + (base_port mod 2)) in let rpc name = match List.find !all_ports ~f:(fun (n, _) -> n = name) with - | Some (_, p) -> - p + | Some (_, p) -> p | None -> let p = !next_port in all_ports := (name, p) :: !all_ports ; next_port := !next_port + 2 ; - p - in + p in let p2p n = rpc n + 1 in let node peers id = let rpc_port = rpc id in let p2p_port = p2p id in let expected_connections = - List.length peers + List.length external_peer_ports - in + 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 + if p <> id then Some (p2p p) else None) in + Tezos_node.make ?protocol ~exec id ~expected_connections ~rpc_port ~p2p_port - (external_peer_ports @ peers) - in + (external_peer_ports @ peers) in let dbgp prefx names = - Printf.eprintf - "%s:\n %s\n%!" - prefx - (String.concat - ~sep:"\n " - (List.map names ~f:(fun n -> sprintf "%s:%d" n (p2p n)))) - in + Printf.eprintf "%s:\n %s\n%!" prefx + (String.concat ~sep:"\n " + (List.map names ~f:(fun n -> sprintf "%s:%d" n (p2p n)))) in let rec make : type a. ?extra_peers:string list -> prefix:string -> a network -> a = fun ?(extra_peers = []) ~prefix network -> @@ -142,45 +109,36 @@ module Topology = struct let intermediate_node = let peers = node_ids left.topology left_nodes - @ node_ids right.topology right_nodes - in - node peers intermediate - in + @ node_ids right.topology right_nodes in + node peers intermediate in (left_nodes, intermediate_node, right_nodes) | Net_in_the_middle {middle; left; right} -> - let middle_names = - node_names ~prefix:(prefix ^ middle.name) middle - in + let middle_names = node_names ~prefix:(prefix ^ middle.name) middle in dbgp "Mid-name" middle_names ; let left_nodes = - make ~extra_peers:(extra_peers @ middle_names) left - in + make ~extra_peers:(extra_peers @ middle_names) left in let right_nodes = - make ~extra_peers:(extra_peers @ middle_names) right - in + make ~extra_peers:(extra_peers @ middle_names) right in let intermediate_nodes = let peers = node_ids left.topology left_nodes - @ node_ids right.topology right_nodes - in + @ node_ids right.topology right_nodes in dbgp "peers" peers ; dbgp "extr-peers" extra_peers ; dbgp "left-names" (node_names ~prefix:(prefix ^ left.name) left) ; dbgp "right-names" (node_names ~prefix:(prefix ^ right.name) right) ; - make ~extra_peers:(peers @ extra_peers) middle - in + make ~extra_peers:(peers @ extra_peers) middle in (left_nodes, intermediate_nodes, right_nodes) | Mesh _ -> let all = node_names ~prefix network in dbgp "mesh-names" all ; let nodes = List.map all ~f:(fun n -> node (all @ extra_peers) n) in - nodes - in + nodes in make ~prefix:"" network end module Network = struct - type t = {nodes : Tezos_node.t list} + type t = {nodes: Tezos_node.t list} let make nodes = {nodes} @@ -196,23 +154,17 @@ module Network = struct |> List.filter_map ~f:(fun s -> match String.strip s with "" -> None | s -> Some s) with - | ("tcp" | "tcp6") :: _ as row -> - Some (`Tcp (idx, row)) - | _ -> - Some (`Wrong (idx, line))) - in + | ("tcp" | "tcp6") :: _ as row -> Some (`Tcp (idx, row)) + | _ -> Some (`Wrong (idx, line))) in return rows let all_listening_ports rows = List.filter_map rows ~f:(function - | `Tcp (_, _ :: _ :: _ :: addr :: _) as row -> ( - match String.split addr ~on:':' with - | [_; port] -> ( - try Some (Int.of_string port, row) with _ -> None ) - | _ -> - None ) - | _ -> - None) + | `Tcp (_, _ :: _ :: _ :: addr :: _) as row -> ( + match String.split addr ~on:':' with + | [_; port] -> ( try Some (Int.of_string port, row) with _ -> None ) + | _ -> None ) + | _ -> None) let netstat_listening_ports state = netstat state @@ -224,36 +176,23 @@ module Network = struct ( if check_ports then netstat_listening_ports state >>= fun all_used -> - let taken port = - List.find all_used ~f:(fun (p, _) -> Int.equal p port) - in - List_sequential.iter - nodes + let taken port = List.find all_used ~f:(fun (p, _) -> Int.equal p port) in + List_sequential.iter nodes ~f:(fun {Tezos_node.id; rpc_port; p2p_port; _} -> let fail s (p, `Tcp (_, row)) = - System_error.fail - "Node: %S's %s port %d already in use {%s}" - id - s + System_error.fail "Node: %S's %s port %d already in use {%s}" id s p - (String.concat ~sep:"|" row) - in - let time_wait (_, `Tcp (_, row)) = - List.last row = Some "TIME_WAIT" - in + (String.concat ~sep:"|" row) in + let time_wait (_, `Tcp (_, row)) = List.last row = Some "TIME_WAIT" in match (taken rpc_port, taken p2p_port) with - | (None, None) -> - return () - | (Some p, _) -> - if time_wait p then return () else fail "RPC" p - | (_, Some p) -> - if time_wait p then return () else fail "P2P" p) + | None, None -> return () + | Some p, _ -> if time_wait p then return () else fail "RPC" p + | _, Some p -> if time_wait p then return () else fail "P2P" p) else return () ) >>= fun () -> let protocols = List.map ~f:Tezos_node.protocol nodes - |> List.dedup_and_sort ~compare:Tezos_protocol.compare - in + |> List.dedup_and_sort ~compare:Tezos_protocol.compare in Inconsistency_error.should_be_one_protocol protocols >>= fun protocol -> Tezos_protocol.ensure protocol ~config:state @@ -280,17 +219,11 @@ end 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 - ?external_peer_ports - (Topology.mesh "N" size) - in + Topology.build ?base_port ?protocol ~exec:node_exec ?external_peer_ports + (Topology.mesh "N" size) in let protocols = List.map ~f:Tezos_node.protocol nodes - |> List.dedup_and_sort ~compare:Tezos_protocol.compare - in + |> List.dedup_and_sort ~compare:Tezos_protocol.compare in Inconsistency_error.should_be_one_protocol protocols >>= fun protocol -> Network.start_up state ~client_exec (Network.make nodes) @@ -298,33 +231,25 @@ let network_with_protocol ?external_peer_ports ?base_port ?(size = 5) ?protocol module Queries = struct let all_levels ?(chain = "main") state ~nodes = - List.fold - nodes - ~init:(return []) + 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/%s/blocks/head/metadata | jq \ - .level.level" - rpc_port + Running_processes.run_cmdf state + "curl http://localhost:%d/chains/%s/blocks/head/metadata" rpc_port chain - >>= fun lvl -> - Console.display_errors_of_command state lvl ~should_output:true - >>= function - | true -> - let res = String.concat ~sep:"\n" lvl#out in - let parsed = - match Int.of_string res with - | i -> - `Level i - | exception _ -> ( - match res with "null" -> `Null | unknown -> `Unknown unknown ) - in - return ((id, parsed) :: prev) - | false -> - return ((id, `Failed) :: prev)) + >>= fun metadata -> + Console.display_errors_of_command state metadata ~should_output:true + >>= (function + | true -> ( + try + `Level + ( Jqo.of_lines metadata#out |> Jqo.field ~k:"level" + |> Jqo.field ~k:"level" |> Jqo.get_int ) + |> return + with _ -> return `Failed ) + | false -> return `Failed) + >>= fun res -> return ((id, res) :: prev)) >>= fun results -> let sorted = List.sort results ~compare:(fun (a, _) (b, _) -> String.compare a b) @@ -334,46 +259,27 @@ module Queries = struct let wait_for_all_levels_to_be ?chain state ~attempts ~seconds nodes level = let check_level = match level with - | `Equal_to l -> - ( = ) l - | `At_least l -> - fun x -> x >= l - in + | `Equal_to l -> ( = ) l + | `At_least l -> fun x -> x >= l in let level_string = match level with - | `Equal_to l -> - sprintf "= %d" l - | `At_least l -> - sprintf "≥ %d" l - in + | `Equal_to l -> sprintf "= %d" l + | `At_least l -> sprintf "≥ %d" l in let msg ids = let show_node (id, res) = - sprintf - "%s (%s)" - id + sprintf "%s (%s)" id ( match res with - | `Failed -> - "failed" - | `Level l -> - sprintf "%d" l - | `Null -> - "null" - | `Unknown s -> - sprintf "¿¿ %S ??" s ) - in - sprintf - "Waiting for %s to reach level %s" + | `Failed -> "failed" + | `Level l -> sprintf "%d" l + | `Null -> "null" + | `Unknown s -> sprintf "¿¿ %S ??" s ) in + sprintf "Waiting for %s to reach level %s" (String.concat (List.map ~f:show_node ids) ~sep:", ") - level_string - in - Console.say - state + level_string in + Console.say state EF.( - wf - "Checking for all levels to be %s (nodes: %s%s)" - level_string - (String.concat - ~sep:", " + 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))) (Option.value_map chain ~default:"" ~f:(sprintf ", chain: %s"))) >>= fun () -> @@ -382,14 +288,9 @@ module Queries = struct >>= fun results -> let not_readys = List.filter_map results ~f:(function - | (_, `Level n) when check_level n -> - None - | (id, res) -> - Some (id, res)) - in + | _, `Level n when check_level n -> None + | id, res -> Some (id, res)) in match not_readys with - | [] -> - return (`Done ()) - | ids -> - return (`Not_done (msg ids))) + | [] -> return (`Done ()) + | ids -> return (`Not_done (msg ids))) end diff --git a/vendors/flextesa-lib/test_scenario.mli b/vendors/flextesa-lib/test_scenario.mli new file mode 100644 index 000000000000..65988b5e2113 --- /dev/null +++ b/vendors/flextesa-lib/test_scenario.mli @@ -0,0 +1,136 @@ +(** Build and manage Network Sandboxes. *) + +open Internal_pervasives + +module Inconsistency_error : sig + type t = [`Empty_protocol_list | `Too_many_protocols of Tezos_protocol.t list] + + val should_be_one_protocol : + 'a list + -> ( 'a + , [> `Empty_protocol_list | `Too_many_protocols of 'a list] ) + Asynchronous_result.t + + val pp : + Format.formatter + -> [< `Empty_protocol_list | `Too_many_protocols of 'a Base.List.t] + -> unit +end + +(** Build {i static} tezos network topologies. *) +module Topology : sig + type node = Tezos_node.t + + type _ t = private + | Mesh : {size: int} -> node list t + | Bottleneck : + {name: string; left: 'a network; right: 'b network} + -> ('a * node * 'b) t + | Net_in_the_middle : + {middle: 'm network; left: 'a network; right: 'b network} + -> ('a * 'm * 'b) t + + and 'a network = {topology: 'a t; name: string} + + val mesh : string -> int -> node list network + val sub : string -> 'a t -> 'a network + + val bottleneck : + string -> 'a network -> 'b network -> ('a * node * 'b) network + + val node_count : 'a t -> int + val node_ids : 'a t -> 'a -> string list + + val net_in_the_middle : + string -> 'a network -> 'b network -> 'c network -> ('b * 'a * 'c) network + + val build : + ?external_peer_ports:int list + -> ?protocol:Tezos_protocol.t + -> ?base_port:int + -> exec:Tezos_executable.t + -> 'a network + -> 'a +end + +(** Start networks from (and manipulate) {!Topology.t} values. *) +module Network : sig + type t = private {nodes: Tezos_node.t list} + + val make : Tezos_node.t list -> t + + val netstat_listening_ports : + < paths: Paths.t ; runner: Running_processes.State.t ; .. > Base_state.t + -> ( (int * [> `Tcp of int * string list]) list + , [> `Lwt_exn of exn | Process_result.Error.t] ) + Asynchronous_result.t + (** Call ["netstat"] to find TCP ports already in use. *) + + val start_up : + ?check_ports:bool + -> < Base_state.base + ; paths: Paths.t + ; runner: Running_processes.State.t + ; .. > + -> client_exec:Tezos_executable.t + -> t + -> ( unit + , [> `Empty_protocol_list + | `Lwt_exn of exn + | `Sys_error of string + | Process_result.Error.t + | `Too_many_protocols of Tezos_protocol.t list ] ) + Asynchronous_result.t +end + +val network_with_protocol : + ?external_peer_ports:int list + -> ?base_port:int + -> ?size:int + -> ?protocol:Tezos_protocol.t + -> < paths: Paths.t ; runner: Running_processes.State.t ; .. > Base_state.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 + | `Sys_error of string + | Process_result.Error.t + | `Too_many_protocols of Tezos_protocol.t list ] ) + Asynchronous_result.t +(** [network_with_protocol] is a wrapper simply starting-up a + {!Topology.mesh}. *) + +(** Run queries on running networks. *) +module Queries : sig + val all_levels : + ?chain:string + -> < application_name: string + ; console: Console.t + ; paths: Paths.t + ; runner: Running_processes.State.t + ; .. > + -> nodes:Tezos_node.t list + -> ( (string * [> `Failed | `Level of int | `Null | `Unknown of string]) + list + , [> `Lwt_exn of exn] ) + Asynchronous_result.t + (** Get the current chain level for all the nodes, returns {i + node-ID × level } values. *) + + val wait_for_all_levels_to_be : + ?chain:string + -> < application_name: string + ; console: Console.t + ; paths: Paths.t + ; runner: Running_processes.State.t + ; .. > + -> attempts:int + -> seconds:float + -> Tezos_node.t list + -> [< `At_least of int | `Equal_to of int] + -> ( unit + , [> `Lwt_exn of exn | `Waiting_for of string * [`Time_out]] ) + Asynchronous_result.t + (** Try-sleep-loop waiting for all given nodes to reach a given level. *) +end diff --git a/src/lib_network_sandbox/tezos_admin_client.ml b/vendors/flextesa-lib/tezos_admin_client.ml similarity index 77% rename from src/lib_network_sandbox/tezos_admin_client.ml rename to vendors/flextesa-lib/tezos_admin_client.ml index 3c46f8f753f9..030fa3bfc50b 100644 --- a/src/lib_network_sandbox/tezos_admin_client.ml +++ b/vendors/flextesa-lib/tezos_admin_client.ml @@ -1,6 +1,6 @@ open Internal_pervasives -type t = {id : string; port : int; exec : 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 @@ -16,8 +16,7 @@ let of_node ~exec n = let make_command t state args = let open Tezos_executable.Make_cli in - Tezos_executable.call - t.exec + Tezos_executable.call t.exec ~path:(base_dir t ~state // "exec-admin") (optf "port" "%d" t.port @ opt "base-dir" (base_dir ~state t) @ args) @@ -28,29 +27,22 @@ module Command_error = struct ksprintf (fun s -> fail (`Admin_command_error (s, args) : [> t])) fmt let pp fmt (`Admin_command_error (msg, args) : t) = - Format.fprintf - fmt - "Admin-command-error:@ %s%s" - msg + Format.fprintf fmt "Admin-command-error:@ %s%s" msg (Option.value_map args ~default:"" ~f:(fun l -> - sprintf - " (args: %s)" + sprintf " (args: %s)" (List.map ~f:(sprintf "%S") l |> String.concat ~sep:", "))) end open Command_error let successful_command admin state args = - Running_processes.run_cmdf - state - "sh -c %s" + Running_processes.run_cmdf state "sh -c %s" ( make_command admin state args |> Genspio.Compile.to_one_liner |> Filename.quote ) >>= fun res -> Console.display_errors_of_command state res >>= function - | true -> - return res + | true -> return res | false -> failf ~args "Admin-command failure: %s" (String.concat ~sep:" " args) @@ -60,10 +52,8 @@ let inject_protocol admin state ~path = String.concat ~sep:" " res#out |> String.split ~on:' ' |> List.map ~f:String.strip |> (function - | _ :: _ :: hash :: _ when hash.[0] = 'P' -> - return hash + | _ :: _ :: hash :: _ when hash.[0] = 'P' -> return hash | _ -> - failf - "inject protocol: cannot parse hash of protocol: %s" + 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/vendors/flextesa-lib/tezos_admin_client.mli b/vendors/flextesa-lib/tezos_admin_client.mli new file mode 100644 index 000000000000..2bf7bcf18cad --- /dev/null +++ b/vendors/flextesa-lib/tezos_admin_client.mli @@ -0,0 +1,47 @@ +open Internal_pervasives +(** Wrapper around the [tezos-admin-client] application. *) + +type t = private {id: string; port: int; exec: Tezos_executable.t} +(** [t] is very similar to {!Tezos_client.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 +(** Build a [Genspio.EDSL.t] command. *) + +module Command_error : sig + type t = [`Admin_command_error of string * string list option] + + val failf : + ?args:string list + -> ('a, unit, string, ('b, [> t]) Asynchronous_result.t) format4 + -> 'a + + val pp : Format.formatter -> t -> unit +end + +val successful_command : + t + -> < application_name: string + ; console: Console.t + ; paths: Paths.t + ; runner: Running_processes.State.t + ; .. > + -> string list + -> ( 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/vendors/flextesa-lib/tezos_client.ml similarity index 63% rename from src/lib_network_sandbox/tezos_client.ml rename to vendors/flextesa-lib/tezos_client.ml index e6a9198e6955..ff0594542d51 100644 --- a/src/lib_network_sandbox/tezos_client.ml +++ b/vendors/flextesa-lib/tezos_client.ml @@ -1,10 +1,9 @@ open Internal_pervasives -type t = {id : string; port : int; exec : 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 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 @@ -16,24 +15,20 @@ let base_dir t ~state = Paths.root state // sprintf "Client-base-%s" t.id open Tezos_executable.Make_cli let client_command t ~state args = - Tezos_executable.call - t.exec + Tezos_executable.call t.exec ~path:(base_dir t ~state // "exec-client") (optf "port" "%d" t.port @ opt "base-dir" (base_dir ~state t) @ args) let bootstrapped_script t ~state = let open Genspio.EDSL in let cmd = - loop_until_true - ~attempts:5 - ~sleep:1 + loop_until_true ~attempts:5 ~sleep:1 ~on_failed_attempt:(fun _ -> eprintf (str "Bootstrap attempt failed\\n") []) - (succeeds (client_command t ~state ["bootstrapped"])) - in + (succeeds (client_command t ~state ["bootstrapped"])) in seq - [ exec ["mkdir"; "-p"; base_dir ~state t]; - if_seq cmd ~t:[eprintf (str "Node Bootstrapped\\n") []] ] + [ exec ["mkdir"; "-p"; base_dir ~state t] + ; if_seq cmd ~t:[eprintf (str "Node Bootstrapped\\n") []] ] let bootstrapped t ~state = let genspio = bootstrapped_script t ~state in @@ -45,67 +40,50 @@ let import_secret_key_script t ~state name key = let activate_protocol_script t ~state protocol = let open Genspio.EDSL in - check_sequence - ~verbosity:(`Announce "activating-protocol") - [ ( "add-activator-key", - import_secret_key_script - t - ~state + check_sequence ~verbosity:(`Announce "activating-protocol") + [ ( "add-activator-key" + , import_secret_key_script t ~state (Tezos_protocol.dictator_name protocol) - (Tezos_protocol.dictator_secret_key protocol) ); - ( "activate-protocol", - ensure - "activate-alpha-only-once" + (Tezos_protocol.dictator_secret_key protocol) ) + ; ( "activate-protocol" + , ensure "activate-alpha-only-once" ~condition: (greps_to (str protocol.Tezos_protocol.hash) - (client_command - t - ~state + (client_command t ~state ["rpc"; "get"; "/chains/main/blocks/head/metadata"])) ~how: - [ ( "activate", - client_command t ~state @@ opt "block" "genesis" - @ [ "activate"; - "protocol"; - protocol.Tezos_protocol.hash; - "with"; - "fitness"; - sprintf "%d" protocol.Tezos_protocol.expected_pow; - "and"; - "key"; - Tezos_protocol.dictator_name protocol; - "and"; - "parameters"; - Tezos_protocol.protocol_parameters_path - ~config:state + [ ( "activate" + , client_command t ~state @@ opt "block" "genesis" + @ [ "activate"; "protocol"; protocol.Tezos_protocol.hash; "with" + ; "fitness" + ; sprintf "%d" protocol.Tezos_protocol.expected_pow + ; "and"; "key" + ; Tezos_protocol.dictator_name protocol + ; "and"; "parameters" + ; Tezos_protocol.protocol_parameters_path ~config:state protocol ] ) ] ) ] let import_secret_key t ~state name key = - Running_processes.run_genspio - state + Running_processes.run_genspio state (sprintf "client-%s-import-key-%s-as-%s" t.id name key) (import_secret_key_script t ~state name key) >>= fun _ -> return () let register_as_delegate t ~state keyname = - Running_processes.run_genspio - state + Running_processes.run_genspio state (sprintf "client-%s-register-as-delegate-for-%s" t.id keyname) Genspio.EDSL.( if_seq ( succeeds - @@ client_command - t - ~state + @@ client_command t ~state ["register"; "key"; keyname; "as"; "delegate"] ) ~t:[say "SUCCESS: Registering %s as delegate" [str keyname]] ~e:[say "FAILURE: Registering %s as delegate" [str keyname]]) >>= fun _ -> return () let activate_protocol t ~state protocol = - Running_processes.run_genspio - state + Running_processes.run_genspio state (sprintf "activate_protocol-%s-%s" t.id protocol.Tezos_protocol.id) (activate_protocol_script t ~state protocol) >>= fun _ -> return () @@ -117,13 +95,9 @@ module Command_error = struct ksprintf (fun s -> fail (`Client_command_error (s, args) : [> t])) fmt let pp fmt (`Client_command_error (msg, args) : t) = - Format.fprintf - fmt - "Client-command-error:@ %s%s" - msg + Format.fprintf fmt "Client-command-error:@ %s%s" msg (Option.value_map args ~default:"" ~f:(fun l -> - sprintf - " (args: %s)" + sprintf " (args: %s)" (List.map ~f:(sprintf "%S") l |> String.concat ~sep:", "))) end @@ -131,9 +105,7 @@ open Command_error open Console let client_cmd state ~client args = - Running_processes.run_cmdf - state - "sh -c %s" + Running_processes.run_cmdf state "sh -c %s" ( client_command client ~state args |> Genspio.Compile.to_one_liner |> Filename.quote ) >>= fun res -> @@ -144,19 +116,15 @@ let successful_client_cmd state ~client args = client_cmd state ~client args >>= fun (success, res) -> match success with - | true -> - return res + | true -> return res | false -> failf ~args "Client-command failure: %s" (String.concat ~sep:" " args) let rpc state ~client meth ~path = let args = match meth with - | `Get -> - ["rpc"; "get"; path] - | `Post s -> - ["rpc"; "post"; path; "with"; s] - in + | `Get -> ["rpc"; "get"; path] + | `Post s -> ["rpc"; "post"; path; "with"; s] in successful_client_cmd state ~client args >>= fun res -> let output = String.concat ~sep:"\n" res#out in @@ -168,36 +136,30 @@ let rpc state ~client meth ~path = Ezjsonm.from_string (sprintf "[ %s ]" output) |> function `A [one] -> return one | _ -> raise e with e -> - say - state + say state EF.( list - [ desc (shout "Output:") (markdown_verbatim output); - desc - (shout "Error:") + [ desc (shout "Output:") (markdown_verbatim output) + ; desc (shout "Error:") (markdown_verbatim (String.concat ~sep:"\n" res#err)) ]) >>= fun () -> failf ~args "RPC failure cannot parse json: %s" Exn.(to_string e) ) let find_applied_in_mempool state ~client ~f = - successful_client_cmd - state - ~client + successful_client_cmd state ~client ["rpc"; "get"; "/chains/main/mempool/pending_operations"] >>= fun res -> try let json = Jqo.of_string (String.concat ~sep:"\n" res#out) in let found = Jqo.field ~k:"applied" json |> Jqo.list_find ~f in - say - state + say state EF.( desc (af "piece of mempool found (client %s):" client.id) (markdown_verbatim (Ezjsonm.to_string json))) >>= fun () -> return (Some found) with e -> - say - state + say state EF.(desc (shout "not found in mempool") (af "%s" (Exn.to_string e))) >>= fun () -> return None @@ -208,9 +170,7 @@ let mempool_has_operation state ~client ~kind = >>= fun found_or_not -> return (found_or_not <> None) let block_has_operation state ~client ~level ~kind = - successful_client_cmd - state - ~client + successful_client_cmd state ~client ["rpc"; "get"; sprintf "/chains/main/blocks/%d/operations" level] >>= fun res -> try @@ -220,22 +180,16 @@ let block_has_operation state ~client ~level ~kind = Jqo.list_exists olist ~f:(fun o -> Jqo.field o ~k:"contents" |> Jqo.list_exists ~f:(fun op -> - Jqo.field op ~k:"kind" = `String kind))) - in - say - state + Jqo.field op ~k:"kind" = `String kind))) in + say state EF.( desc - (af - "looking for %S in block %d: %sfound" - kind - level + (af "looking for %S in block %d: %sfound" kind level (if found then "" else "not ")) (af "%s" (Ezjsonm.to_string json))) >>= fun () -> return found with e -> - say - state + say state EF.( desc (ksprintf shout "Operation %S not found in block" kind) @@ -244,10 +198,8 @@ let block_has_operation state ~client ~level ~kind = let get_block_header state ~client block = let path = - sprintf - "/chains/main/blocks/%s/header" - (match block with `Head -> "head" | `Level i -> Int.to_string i) - in + sprintf "/chains/main/blocks/%s/header" + (match block with `Head -> "head" | `Level i -> Int.to_string i) in rpc state ~client `Get ~path let list_known_addresses state ~client = @@ -257,51 +209,32 @@ let list_known_addresses state ~client = Re.( compile (seq - [ group (rep1 (alt [alnum; char '_'])); - str ": "; - group (rep1 alnum); - alt [space; eol; eos] ])) - in + [ group (rep1 (alt [alnum; char '_'])) + ; str ": " + ; group (rep1 alnum) + ; alt [space; eol; eos] ])) in return - (List.filter_map - res#out + (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))) + | 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} + 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 ] + 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" ] + 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 @@ -312,30 +245,24 @@ module Ledger = struct 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 + [ 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 = + { 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); - } + 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) + uri (Exn.to_string e) (String.concat ~sep:"\n" res#out) let show_ledger state ~client ~uri = @@ -355,35 +282,23 @@ module Ledger = struct match List.find known_addresses ~f:(fun (_, pkh) -> pkh = pubkey_hash) with - | None -> - "" - | Some (alias, _) -> - alias - in + | None -> "" + | Some (alias, _) -> alias in return - (Tezos_protocol.Account.key_pair - name - ~pubkey - ~pubkey_hash + (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) + 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 + successful_client_cmd state ~client ["deauthorize"; "ledger"; "baking"; "for"; uri] >>= fun _ -> return () let get_authorized_key state ~client ~uri = - successful_client_cmd - state - ~client + successful_client_cmd state ~client ["get"; "ledger"; "authorized"; "path"; "for"; uri] >>= fun res -> let re_uri = @@ -394,121 +309,84 @@ module Ledger = struct return Re.( match exec_opt re_none out with - | Some _ -> - None - | None -> - Some (Group.get (exec re_uri out) 1)) + | 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} + type t = {client: client; key_name: string; secret_key: string} let make client ~key_name ~secret_key = {client; key_name; secret_key} let initialize state {client; key_name; secret_key} = - successful_client_cmd - state - ~client + successful_client_cmd state ~client ["import"; "secret"; "key"; key_name; secret_key; "--force"] 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 + Option.value_map chain ~default:[] ~f:(fun c -> ["--chain"; c]) in + successful_client_cmd state ~client:baker.client ( chain_arg @ ["bake"; "for"; baker.key_name; "--force"; "--minimal-timestamp"] ) >>= fun res -> - Log_recorder.Operations.bake - state - ~client:baker.client.id - ~output:res#out + Log_recorder.Operations.bake state ~client:baker.client.id ~output:res#out msg ; - say - state + say state EF.( desc (af "Successful bake (%s: %s):" baker.client.id msg) (ocaml_string_list res#out)) let endorse state baker msg = - successful_client_cmd - state - ~client:baker.client + successful_client_cmd state ~client:baker.client ["endorse"; "for"; baker.key_name] >>= fun res -> - Log_recorder.Operations.endorse - state - ~client:baker.client.id - ~output:res#out - msg ; - say - state + Log_recorder.Operations.endorse state ~client:baker.client.id + ~output:res#out msg ; + say state EF.( desc (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 + 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" + rpc state ~client ~path:"/chains/main/blocks/head/helpers/forge/operations" (`Post (Ezjsonm.to_string json)) >>= fun res -> - let operation_bytes = - match res with `String s -> s | _ -> assert false - in + let operation_bytes = match res with `String s -> s | _ -> assert false in let bytes_to_sign = "0x03" ^ operation_bytes in - successful_client_cmd - state - ~client + successful_client_cmd state ~client ["sign"; "bytes"; bytes_to_sign; "for"; key_name] >>= fun sign_res -> let to_decode = List.hd_exn sign_res#out |> String.chop_prefix_exn ~prefix:"Signature:" - |> String.strip - in + |> String.strip in say state EF.(desc (shout "TO DECODE:") (af "%S" to_decode)) >>= fun () -> let decoded = - Option.value_exn - ~message:"base58 dec" + Option.value_exn ~message:"base58 dec" (Tezos_crypto.Base58.safe_decode to_decode) - |> Hex.of_string ?ignore:None |> Hex.show - in + |> Hex.of_string ?ignore:None |> Hex.show in say state EF.(desc (shout "DECODED:") (af "%S" decoded)) >>= fun () -> let actual_signature = - String.chop_prefix_exn ~prefix:"09f5cd8612" decoded - in - say - state + String.chop_prefix_exn ~prefix:"09f5cd8612" decoded in + say state EF.( - desc_list - (af "Injecting Operation") - [ ef_json "Injecting" (json :> Ezjsonm.value); - desc - (haf "op:") - (af "%d: %S" (String.length operation_bytes) operation_bytes); - desc - (haf "sign:") + desc_list (af "Injecting Operation") + [ ef_json "Injecting" (json :> Ezjsonm.value) + ; desc (haf "op:") + (af "%d: %S" (String.length operation_bytes) operation_bytes) + ; desc (haf "sign:") (af "%d: %S" (String.length actual_signature) actual_signature) ]) >>= fun () -> - rpc - state - ~client - ~path:"/injection/operation?chain=main" + rpc state ~client ~path:"/injection/operation?chain=main" (`Post (sprintf "\"%s%s\"" operation_bytes actual_signature)) end diff --git a/src/lib_network_sandbox/tezos_client.mli b/vendors/flextesa-lib/tezos_client.mli similarity index 100% rename from src/lib_network_sandbox/tezos_client.mli rename to vendors/flextesa-lib/tezos_client.mli index 86eed73168e4..9cabb6eb8789 100644 --- a/src/lib_network_sandbox/tezos_client.mli +++ b/vendors/flextesa-lib/tezos_client.mli @@ -1,5 +1,5 @@ -(** Wrapper around the main ["tezos-client"] application. *) open Internal_pervasives +(** Wrapper around the main ["tezos-client"] application. *) type t = {id : string; port : int; exec : Tezos_executable.t} diff --git a/src/lib_network_sandbox/tezos_daemon.ml b/vendors/flextesa-lib/tezos_daemon.ml similarity index 99% rename from src/lib_network_sandbox/tezos_daemon.ml rename to vendors/flextesa-lib/tezos_daemon.ml index 452587583690..bad58025e9db 100644 --- a/src/lib_network_sandbox/tezos_daemon.ml +++ b/vendors/flextesa-lib/tezos_daemon.ml @@ -42,8 +42,7 @@ let to_script (t : t) ~state = (arg_to_string t.args) t.node.Tezos_node.rpc_port (Option.value_map t.name_tag ~default:"" ~f:(sprintf "-%s")) ) - args - in + args in match t.args with | Baker key -> let node_path = Tezos_node.data_dir ~config:state t.node in diff --git a/src/lib_network_sandbox/tezos_daemon.mli b/vendors/flextesa-lib/tezos_daemon.mli similarity index 100% rename from src/lib_network_sandbox/tezos_daemon.mli rename to vendors/flextesa-lib/tezos_daemon.mli diff --git a/src/lib_network_sandbox/tezos_executable.ml b/vendors/flextesa-lib/tezos_executable.ml similarity index 50% rename from src/lib_network_sandbox/tezos_executable.ml rename to vendors/flextesa-lib/tezos_executable.ml index 755d766039a5..0343e844aee6 100644 --- a/src/lib_network_sandbox/tezos_executable.ml +++ b/vendors/flextesa-lib/tezos_executable.ml @@ -2,81 +2,64 @@ open Internal_pervasives module Make_cli = struct let flag name = [sprintf "--%s" name] - let opt name s = [sprintf "--%s" name; s] - let optf name fmt = ksprintf (opt name) fmt end module Unix_files_sink = struct - type t = {matches : string list option; level_at_least : string} + type t = {matches: string list option; level_at_least: string} - let all_notices = {matches = None; level_at_least = "notice"} - - let all_info = {matches = None; level_at_least = "info"} + let all_notices = {matches= None; level_at_least= "notice"} + let all_info = {matches= None; level_at_least= "info"} end type kind = [`Node | `Baker | `Endorser | `Accuser | `Client | `Admin] -type t = { - kind : kind; - binary : string option; - unix_files_sink : Unix_files_sink.t option; - environment : (string * string) list; -} +type t = + { kind: kind + ; binary: string option + ; unix_files_sink: Unix_files_sink.t option + ; environment: (string * string) list } let make ?binary ?unix_files_sink ?(environment = []) (kind : [< kind]) = {kind; binary; unix_files_sink; environment} let kind_string (kind : [< kind]) = match kind with - | `Accuser -> - "accuser-alpha" - | `Baker -> - "baker-alpha" - | `Endorser -> - "endorser-alpha" - | `Node -> - "node" - | `Client -> - "client" - | `Admin -> - "admin-client" + | `Accuser -> "accuser-alpha" + | `Baker -> "baker-alpha" + | `Endorser -> "endorser-alpha" + | `Node -> "node" + | `Client -> "client" + | `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 ~path args = let open Genspio.EDSL in seq ( Option.value_map t.unix_files_sink ~default:[] ~f:(function - | {matches = None; level_at_least} -> - [ setenv - ~var:(str "TEZOS_EVENTS_CONFIG") - (ksprintf - str - "unix-files://%s?level-at-least=%s" - (path // "events") - level_at_least) ] - | _other -> - assert false) - @ [ exec ["mkdir"; "-p"; path]; - write_stdout + | {matches= None; level_at_least} -> + [ setenv + ~var:(str "TEZOS_EVENTS_CONFIG") + (ksprintf str "unix-files://%s?level-at-least=%s" + (path // "events") level_at_least) ] + | _other -> assert false) + @ [ exec ["mkdir"; "-p"; path] + ; write_stdout ~path:(path // "last-cmd" |> str) - (printf (str "ARGS: %s\\n") [str (String.concat ~sep:" " args)]); - exec (get t :: args) ] ) + (printf (str "ARGS: %s\\n") [str (String.concat ~sep:" " args)]) + ; exec (get t :: args) ] ) let cli_term kind prefix = let open Cmdliner in let open Term in pure (fun binary -> - { - kind; - binary; - unix_files_sink = Some Unix_files_sink.all_info; - environment = []; - }) + { kind + ; binary + ; unix_files_sink= Some Unix_files_sink.all_info + ; environment= [] }) $ Arg.( value & opt (some string) None diff --git a/src/lib_network_sandbox/tezos_executable.mli b/vendors/flextesa-lib/tezos_executable.mli similarity index 82% rename from src/lib_network_sandbox/tezos_executable.mli rename to vendors/flextesa-lib/tezos_executable.mli index 1554e7c3b693..569c93b5b8cf 100644 --- a/src/lib_network_sandbox/tezos_executable.mli +++ b/vendors/flextesa-lib/tezos_executable.mli @@ -5,57 +5,53 @@ ["tezos-*"] applications. *) module Make_cli : sig val flag : string -> string list - val opt : string -> string -> string list - val optf : string -> ('a, unit, string, string list) format4 -> 'a end (** Manipulate the ["TEZOS_EVENTS_CONFIG"] environment variable. *) module Unix_files_sink : sig - type t = private {matches : string list option; level_at_least : string} + type t = private {matches: string list option; level_at_least: string} val all_notices : t - val all_info : t end -(** The type [kind] is used to distinguish ['a t] executables. *) type kind = [`Node | `Baker | `Endorser | `Accuser | `Client | `Admin] +(** The type [kind] is used to distinguish ['a t] executables. *) +type t = private + { kind: kind + ; binary: string option + ; unix_files_sink: Unix_files_sink.t option + ; environment: (string * string) list } (** The wrapper of the tezos-executable. *) -type t = private { - kind : kind; - binary : string option; - unix_files_sink : Unix_files_sink.t option; - environment : (string * string) list; -} -(** Create a ["tezos-node"] executable. *) val make : - ?binary:string -> - ?unix_files_sink:Unix_files_sink.t -> - ?environment:(string * string) list -> - kind -> - t + ?binary:string + -> ?unix_files_sink:Unix_files_sink.t + -> ?environment:(string * string) list + -> kind + -> t +(** Create a ["tezos-node"] executable. *) -(** Convert a [kind] to a [string]. *) val kind_string : kind -> string +(** Convert a [kind] to a [string]. *) +val default_binary : t -> string (** Get the path/name of the default binary for a given kind, e.g., ["tezos-admin-client"]. *) -val default_binary : t -> string -(** The path to the executable. *) 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 call : t -> path:string -> string list -> unit Genspio.EDSL.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"]). *) -val cli_term : kind -> string -> t Cmdliner.Term.t diff --git a/src/lib_network_sandbox/tezos_node.ml b/vendors/flextesa-lib/tezos_node.ml similarity index 51% rename from src/lib_network_sandbox/tezos_node.ml rename to vendors/flextesa-lib/tezos_node.ml index 4ed82e4f47d3..9dc93d5abfd3 100644 --- a/src/lib_network_sandbox/tezos_node.ml +++ b/vendors/flextesa-lib/tezos_node.ml @@ -1,23 +1,21 @@ open Internal_pervasives -type t = { - id : string; - expected_connections : int; - rpc_port : int; - p2p_port : int; - (* Ports: *) - peers : int list; - exec : Tezos_executable.t; - protocol : Tezos_protocol.t; -} +type t = + { id: string + ; expected_connections: int + ; rpc_port: int + ; p2p_port: int + ; (* Ports: *) + peers: int list + ; exec: Tezos_executable.t + ; protocol: Tezos_protocol.t } let ef t = EF.( - desc_list - (af "Node:%S" t.id) - [ desc (af "rpc") (af ":%d" t.rpc_port); - desc (af "p2p") (af ":%d" t.p2p_port); - desc_list (af "peers") (List.map t.peers ~f:(af ":%d")) ]) + desc_list (af "Node:%S" t.id) + [ desc (af "rpc") (af ":%d" t.rpc_port) + ; desc (af "p2p") (af ":%d" t.p2p_port) + ; desc_list (af "peers") (List.map t.peers ~f:(af ":%d")) ]) let pp fmt t = Easy_format.Pretty.to_formatter fmt (ef t) @@ -29,38 +27,49 @@ let make_path p ~config t = Paths.root config // sprintf "node-%s" t.id // p (* Data-dir should not exist OR be fully functional. *) let data_dir ~config t = make_path "data-dir" ~config t - let config_file ~config t = data_dir ~config t // "config.json" - let identity_file ~config t = data_dir ~config t // "identity.json" - let log_output ~config t = make_path "node-output.log" ~config t - let exec_path ~config t = make_path ~config "exec" t +module Config_file = struct + (* + This module pruposedly avoids using the node's modules because we + want the sandbox to be able to configure ≥ 1 versions of the + node. + *) + let of_node state t = + let open Ezjsonm in + dict + [ ("data-dir", data_dir ~config:state t |> string) + ; ( "rpc" + , dict [("listen-addrs", strings [sprintf "0.0.0.0:%d" t.rpc_port])] ) + ; ( "p2p" + , dict + [ ( "expected-proof-of-work" + , int (Tezos_protocol.expected_pow t.protocol) ) + ; ("listen-addr", ksprintf string "0.0.0.0:%d" t.p2p_port) + ; ( "limits" + , dict + [ ("maintenance-idle-time", int 3) + ; ("swap-linger", int 2) + ; ("connection-timeout", int 2) ] ) ] ) + ; ("log", dict [("output", string (log_output ~config:state t))]) ] + |> to_string ~minify:false +end + open Tezos_executable.Make_cli let node_command t ~config cmd options = - Tezos_executable.call - t.exec - ~path:(exec_path t ~config) + Tezos_executable.call t.exec ~path:(exec_path t ~config) ( cmd @ opt "config-file" (config_file ~config t) @ opt "data-dir" (data_dir ~config t) @ options ) -let config_options t ~config = - opt "log-output" (log_output ~config t) - @ optf "rpc-addr" "0.0.0.0:%d" t.rpc_port - @ optf "net-addr" "0.0.0.0:%d" t.p2p_port - @ optf "expected-pow" "%d" (Tezos_protocol.expected_pow t.protocol) - let run_command t ~config = let peers = List.concat_map t.peers ~f:(optf "peer" "127.0.0.1:%d") in - node_command - t - ~config - ["run"] + node_command t ~config ["run"] ( flag "private-mode" @ flag "no-bootstrap-peers" @ peers @ optf "bootstrap-threshold" "0" @ optf "connections" "%d" t.expected_connections @@ -69,38 +78,22 @@ let run_command t ~config = let start_script t ~config = let open Genspio.EDSL in let gen_id = - node_command - t - ~config - [ "identity"; - "generate"; - sprintf "%d" (Tezos_protocol.expected_pow t.protocol) ] - [] - in + node_command t ~config + [ "identity"; "generate" + ; sprintf "%d" (Tezos_protocol.expected_pow t.protocol) ] + [] in let tmp_config = tmp_file (config_file t ~config) in - check_sequence - ~verbosity:`Output_all - [ (let opts = config_options t ~config in - ( "config-init", - if_seq - (file_exists (str (config_file t ~config))) - ~t:[node_command t ~config ["config"; "reset"] opts] - ~e:[node_command t ~config ["config"; "init"] opts] )); - ( "update-config", - seq - [ write_stdout - ~path:tmp_config#path - (exec - [ "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", - ensure - "node-id" + check_sequence ~verbosity:`Output_all + [ ("reset-config", node_command t ~config ["config"; "reset"] []) + ; ( "write-config" + , seq + [ tmp_config#set (Config_file.of_node config t |> str) + ; call [str "mv"; tmp_config#path; str (config_file t ~config)] ] ) + ; ( "ensure-identity" + , ensure "node-id" ~condition:(file_exists (str (identity_file t ~config))) - ~how:[("gen-id", gen_id)] ); - ("start", run_command t ~config) ] + ~how:[("gen-id", gen_id)] ) + ; ("start", run_command t ~config) ] let process config t = Running_processes.Process.genspio t.id (start_script t ~config) @@ -118,14 +111,10 @@ let connections node_list = let compare a b = match (a, b) with - | (`Duplex (a, b), `Duplex (c, d)) when a = d && b = c -> - 0 - | (`Duplex _, _) -> - -1 - | (_, `Duplex _) -> - 1 - | (_, _) -> - Caml.Pervasives.compare a b + | `Duplex (a, b), `Duplex (c, d) when a = d && b = c -> 0 + | `Duplex _, _ -> -1 + | _, `Duplex _ -> 1 + | _, _ -> Caml.Pervasives.compare a b end in let module Connection_set = Set.Make (Connection) in let res = ref Connection_set.empty in @@ -135,20 +124,15 @@ let connections node_list = match List.find node_list ~f:(fun {p2p_port; _} -> p2p_port = p2p) with - | None -> - `Unknown p2p - | Some n -> - `Peer n) - in + | None -> `Unknown p2p + | Some n -> `Peer n) in List.iter peer_nodes ~f:(fun peer_opt -> let conn = match peer_opt with - | `Unknown p2p -> - `Missing (node, p2p) + | `Unknown p2p -> `Missing (node, p2p) | `Peer peer -> if List.mem peer.peers node.p2p_port ~equal:Int.equal then `Duplex (node, peer) - else `From_to (node, peer) - in + else `From_to (node, peer) in res := Connection_set.add conn !res)) ; Connection_set.elements !res diff --git a/vendors/flextesa-lib/tezos_node.mli b/vendors/flextesa-lib/tezos_node.mli new file mode 100644 index 000000000000..52c20178747b --- /dev/null +++ b/vendors/flextesa-lib/tezos_node.mli @@ -0,0 +1,46 @@ +type t = private + { id: string + ; expected_connections: int + ; rpc_port: int + ; p2p_port: int + ; peers: int list + ; exec: Tezos_executable.t + ; protocol: Tezos_protocol.t } + +val ef : t -> Easy_format.t +val pp : Format.formatter -> t -> unit + +val make : + exec:Tezos_executable.t + -> ?protocol:Tezos_protocol.t + -> string + -> expected_connections:int + -> rpc_port:int + -> p2p_port:int + -> int list + -> t + +val data_dir : config:< paths: Paths.t ; .. > -> t -> string +val config_file : config:< paths: Paths.t ; .. > -> t -> string +val identity_file : config:< paths: Paths.t ; .. > -> t -> string +val log_output : config:< paths: Paths.t ; .. > -> t -> string +val exec_path : config:< paths: Paths.t ; .. > -> t -> string + +val node_command : + t + -> config:< paths: Paths.t ; .. > + -> string list + -> string list + -> unit Genspio.Language.t + +val run_command : + t -> config:< paths: Paths.t ; .. > -> unit Genspio.Language.t + +val start_script : + t -> config:< paths: Paths.t ; .. > -> unit Genspio.Language.t + +val process : < paths: Paths.t ; .. > -> t -> Running_processes.Process.t +val protocol : t -> Tezos_protocol.t + +val connections : + t list -> [`Duplex of t * t | `From_to of t * t | `Missing of t * int] list diff --git a/vendors/flextesa-lib/tezos_protocol.ml b/vendors/flextesa-lib/tezos_protocol.ml new file mode 100644 index 000000000000..9d7174f12ad8 --- /dev/null +++ b/vendors/flextesa-lib/tezos_protocol.ml @@ -0,0 +1,243 @@ +open Internal_pervasives + +module Key = struct + module Of_name = struct + type t = + { name: string + ; pkh: Tezos_crypto.Ed25519.Public_key_hash.t + ; pk: Tezos_crypto.Ed25519.Public_key.t + ; sk: Tezos_crypto.Ed25519.Secret_key.t } + + let make name = + let seed = + Tezos_stdlib.MBytes.of_string + (String.concat ~sep:"" (List.init 42 ~f:(fun _ -> name))) in + let pkh, pk, sk = Tezos_crypto.Ed25519.generate_key ~seed () in + {name; pkh; pk; sk} + + let pubkey n = Tezos_crypto.Ed25519.Public_key.to_b58check (make n).pk + + let pubkey_hash n = + Tezos_crypto.Ed25519.Public_key_hash.to_b58check (make n).pkh + + let private_key n = + "unencrypted:" ^ Tezos_crypto.Ed25519.Secret_key.to_b58check (make n).sk + end +end + +module Account = struct + type t = + | Of_name of string + | Key_pair of + {name: string; pubkey: string; pubkey_hash: string; private_key: string} + + let of_name s = Of_name s + let of_namef fmt = ksprintf of_name fmt + let name = function Of_name n -> n | Key_pair k -> k.name + + let key_pair name ~pubkey ~pubkey_hash ~private_key = + Key_pair {name; pubkey; pubkey_hash; private_key} + + let pubkey = function + | Of_name n -> Key.Of_name.pubkey n + | Key_pair k -> k.pubkey + + let pubkey_hash = function + | Of_name n -> Key.Of_name.pubkey_hash n + | Key_pair k -> k.pubkey_hash + + let private_key = function + | Of_name n -> Key.Of_name.private_key n + | Key_pair k -> k.private_key +end + +module Voting_period = struct + type t = [`Proposal | `Testing_vote | `Testing | `Promotion_vote] + + let to_string (p : t) = + (* This has to mimic: src/proto_alpha/lib_protocol/voting_period_repr.ml *) + match p with + | `Promotion_vote -> "promotion_vote" + | `Testing_vote -> "testing_vote" + | `Proposal -> "proposal" + | `Testing -> "testing" +end + +type t = + { id: string + ; bootstrap_accounts: (Account.t * Int64.t) list + ; dictator: Account.t + (* ; bootstrap_contracts: (Account.t * int * Script.origin) list *) + ; expected_pow: int + ; name: string (* e.g. alpha *) + ; hash: string + ; time_between_blocks: int list + ; blocks_per_roll_snapshot: int + ; blocks_per_voting_period: int + ; blocks_per_cycle: int + ; preserved_cycles: int + ; proof_of_work_threshold: int } + +let compare a b = String.compare a.id b.id + +let default () = + let dictator = Account.of_name "dictator-default" in + { id= "default-bootstrap" + ; bootstrap_accounts= + List.init 4 ~f:(fun n -> + (Account.of_namef "bootacc-%d" n, 4_000_000_000_000L)) + ; dictator + (* ; bootstrap_contracts= [(dictator, 10_000_000, `Sandbox_faucet)] *) + ; expected_pow= 1 + ; name= "alpha" + ; hash= "ProtoALphaALphaALphaALphaALphaALphaALphaALphaDdp3zK" + ; time_between_blocks= [2; 3] + ; blocks_per_roll_snapshot= 4 + ; blocks_per_voting_period= 16 + ; blocks_per_cycle= 8 + ; preserved_cycles= 2 + ; proof_of_work_threshold= -1 } + +let protocol_parameters_json t : Ezjsonm.t = + let open Ezjsonm in + let make_account (account, amount) = + strings [Account.pubkey account; sprintf "%Ld" amount] in + (* let make_contract (deleg, amount, script) = dict + [ ("delegate", string (Account.pubkey_hash deleg)) + ; ("amount", ksprintf string "%d" amount) + ; ("script", (Script.load script :> Ezjsonm.value)) ] in + *) + dict + [ ( "bootstrap_accounts" + , list make_account (t.bootstrap_accounts @ [(t.dictator, 10_000_000L)]) + ) + (* ; ("bootstrap_contracts", list make_contract t.bootstrap_contracts) *) + ; ("time_between_blocks", list (ksprintf string "%d") t.time_between_blocks) + ; ("blocks_per_roll_snapshot", int t.blocks_per_roll_snapshot) + ; ("blocks_per_voting_period", int t.blocks_per_voting_period) + ; ("blocks_per_cycle", int t.blocks_per_cycle) + ; ("preserved_cycles", int t.preserved_cycles) + ; ( "proof_of_work_threshold" + , ksprintf string "%d" t.proof_of_work_threshold ) ] + +let sandbox {dictator; _} = + let pk = Account.pubkey dictator in + Ezjsonm.to_string (`O [("genesis_pubkey", `String pk)]) + +let protocol_parameters t = + Ezjsonm.to_string ~minify:false (protocol_parameters_json t) + +let expected_pow t = t.expected_pow +let id t = t.id +let bootstrap_accounts t = List.map ~f:fst t.bootstrap_accounts +let dictator_name {dictator; _} = Account.name dictator +let dictator_secret_key {dictator; _} = Account.private_key dictator +let make_path config t = Paths.root config // sprintf "protocol-%s" (id t) +let sandbox_path ~config t = make_path config t // "sandbox.json" + +let protocol_parameters_path ~config t = + make_path config t // "protocol_parameters.json" + +let ensure_script ~config t = + let open Genspio.EDSL in + let file string p = + let path = p ~config t in + ( Filename.basename path + , write_stdout ~path:(str path) + (feed ~string:(str (string t)) (exec ["cat"])) ) in + check_sequence + ~verbosity:(`Announce (sprintf "Ensure-protocol-%s" (id t))) + [ ("directory", exec ["mkdir"; "-p"; make_path config t]) + ; file sandbox sandbox_path + ; file protocol_parameters protocol_parameters_path ] + +let ensure t ~config = + match + Sys.command (Genspio.Compile.to_one_liner (ensure_script ~config t)) + with + | 0 -> return () + | _other -> + Lwt_exception.fail (Failure "sys.command non-zero") + ~attach:[("location", `String_value "Tezos_protocol.ensure")] + +let cli_term () = + let open Cmdliner in + let open Term in + let def = default () in + let docs = "PROTOCOL OPTIONS" in + pure + (fun remove_default_bas + (`Blocks_per_voting_period blocks_per_voting_period) + (`Protocol_hash hash) + (`Time_between_blocks time_between_blocks) + (`Blocks_per_cycle blocks_per_cycle) + (`Preserved_cycles preserved_cycles) + add_bootstraps + -> + let id = "default-and-command-line" in + let bootstrap_accounts = + add_bootstraps + @ if remove_default_bas then [] else def.bootstrap_accounts in + { def with + id + ; blocks_per_cycle + ; hash + ; bootstrap_accounts + ; time_between_blocks + ; preserved_cycles + ; blocks_per_voting_period }) + $ Arg.( + value + (flag + (info ~doc:"Do not create any of the default bootstrap accounts." + ~docs + ["remove-default-bootstrap-accounts"]))) + $ Arg.( + pure (fun x -> `Blocks_per_voting_period x) + $ value + (opt int def.blocks_per_voting_period + (info ~docs + ["blocks-per-voting-period"] + ~doc:"Set the length of voting periods."))) + $ Arg.( + pure (fun x -> `Protocol_hash x) + $ value + (opt string def.hash + (info ["protocol-hash"] ~docs + ~doc:"Set the (initial) protocol hash."))) + $ Arg.( + pure (fun x -> `Time_between_blocks x) + $ value + (opt (list ~sep:',' int) def.time_between_blocks + (info ["time-between-blocks"] ~docv:"COMMA-SEPARATED-SECONDS" + ~docs + ~doc: + "Set the time between blocks bootstrap-parameter, e.g. \ + `2,3,2`."))) + $ Arg.( + pure (fun x -> `Blocks_per_cycle x) + $ value + (opt int def.blocks_per_cycle + (info ["blocks-per-cycle"] ~docv:"NUMBER" ~docs + ~doc:"Number of blocks per cycle."))) + $ Arg.( + pure (fun x -> `Preserved_cycles x) + $ value + (opt int def.preserved_cycles + (info ["preserved-cycles"] ~docv:"NUMBER" ~docs + ~doc: + "Base constant for baking rights (search for \ + `PRESERVED_CYCLES` in the white paper)."))) + $ Arg.( + pure (fun l -> + List.map l ~f:(fun ((name, pubkey, pubkey_hash, private_key), tez) -> + (Account.key_pair name ~pubkey ~pubkey_hash ~private_key, tez))) + $ value + (opt_all + (pair ~sep:'@' (t4 ~sep:',' string string string string) int64) + [] + (info ["add-bootstrap-account"] ~docs + ~docv:"NAME,PUBKEY,PUBKEY-HASH,PRIVATE-URI@MUTEZ-AMOUNT" + ~doc: + "Add a custom bootstrap account, e.g. \ + `LedgerBaker,edpku...,tz1YPS...,ledger://crouching-tiger.../ed25519/0'/0'@20_000_000_000`."))) diff --git a/src/lib_network_sandbox/tezos_protocol.mli b/vendors/flextesa-lib/tezos_protocol.mli similarity index 51% rename from src/lib_network_sandbox/tezos_protocol.mli rename to vendors/flextesa-lib/tezos_protocol.mli index f5d059e84194..aa2e1266c2dd 100644 --- a/src/lib_network_sandbox/tezos_protocol.mli +++ b/vendors/flextesa-lib/tezos_protocol.mli @@ -1,7 +1,6 @@ (** Create and manipulate bootstrap-parameters and accounts. *) open Internal_pervasives -open Protocol (** Manipulate public/private key pairs. *) module Key : sig @@ -9,125 +8,77 @@ module Key : sig given strings. *) module Of_name : sig val pubkey : string -> string - val pubkey_hash : string -> string - val private_key : string -> string end end -(** Create and transform Michelson programs. *) -module Script : sig - type origin = [`Sandbox_faucet | `String of string] - - val parse : string -> Alpha_context.Script.expr - - val code_of_json_exn : - string -> Michelson_v1_primitives.prim Tezos_micheline.Micheline.canonical - - val json_script_repr : Script_repr.expr -> Script_repr.expr -> Ezjsonm.t - - val original_json : string - - val faucet_tz : string - - val print : Script_repr.expr -> Script_repr.expr -> unit - - val load : origin -> Ezjsonm.t - - val test : unit -> unit -end - (** An account is a named key-pair. *) module Account : sig type t = private | Of_name of string - | Key_pair of { - name : string; - pubkey : string; - pubkey_hash : string; - private_key : string; - } + | Key_pair of + {name: string; pubkey: string; pubkey_hash: string; private_key: string} val of_name : string -> t - val of_namef : ('a, unit, string, t) format4 -> 'a val key_pair : string -> pubkey:string -> pubkey_hash:string -> private_key:string -> t val name : t -> string - val pubkey : t -> string - val pubkey_hash : t -> string - val private_key : t -> string end module Voting_period : sig - type t = Alpha_context.Voting_period.kind = - | Proposal - | Testing_vote - | Testing - | Promotion_vote + type t = [`Proposal | `Testing_vote | `Testing | `Promotion_vote] val to_string : t -> string end +type t = + { id: string + ; bootstrap_accounts: (Account.t * Int64.t) list + ; dictator: Account.t + (* ; bootstrap_contracts: (Account.t * int * Script.origin) list *) + ; expected_pow: int + ; name: string + ; hash: string + ; time_between_blocks: int list + ; blocks_per_roll_snapshot: int + ; blocks_per_voting_period: int + ; blocks_per_cycle: int + ; preserved_cycles: int + ; proof_of_work_threshold: int } (** [t] wraps bootstrap parameters for sandboxed protocols. *) -type t = { - id : string; - bootstrap_accounts : (Account.t * Int64.t) list; - dictator : Account.t; - bootstrap_contracts : (Account.t * int * Script.origin) list; - expected_pow : int; - name : string; - hash : string; - time_between_blocks : int list; - blocks_per_roll_snapshot : int; - blocks_per_voting_period : int; - blocks_per_cycle : int; - preserved_cycles : int; - proof_of_work_threshold : int; -} val compare : t -> t -> int - val default : unit -> t - val protocol_parameters_json : t -> Ezjsonm.t - val sandbox : t -> string - val protocol_parameters : t -> string - val expected_pow : t -> int - val id : t -> string - val bootstrap_accounts : t -> Account.t list - val dictator_name : t -> string - val dictator_secret_key : t -> string +val sandbox_path : config:< paths: Paths.t ; .. > -> t -> string +val protocol_parameters_path : config:< paths: Paths.t ; .. > -> t -> string -val sandbox_path : config:< paths : Paths.t ; .. > -> t -> string - -val protocol_parameters_path : config:< paths : Paths.t ; .. > -> t -> string - +val ensure_script : + config:< paths: Paths.t ; .. > -> t -> unit Genspio.Language.t (** Build a {!Genspio.EDSL.t} script which generates the bootstrap-parameters JSON file. *) -val ensure_script : - config:< paths : Paths.t ; .. > -> t -> unit Genspio.Language.t +val ensure : + t + -> config:< paths: Paths.t ; .. > + -> (unit, [> `Lwt_exn of exn]) Asynchronous_result.t (** Run the script created by [ensure_script], i.e. create the JSON bootstrap parameters. *) -val ensure : - t -> - config:< paths : Paths.t ; .. > -> - (unit, [> `Lwt_exn of exn]) Asynchronous_result.t +val cli_term : unit -> t Cmdliner.Term.t (** Create a [Cmdliner] term which configures protocol-parameters (e.g. options like ["--time-between-blocks"]). *) -val cli_term : unit -> t Cmdliner.Term.t -- GitLab From 356ae622eb84bf1bc3a37bfa64255e406015b084 Mon Sep 17 00:00:00 2001 From: Sebastien Mondet Date: Fri, 16 Aug 2019 16:05:07 -0400 Subject: [PATCH 3/6] Opam: fix `vendors/flextesa-lib/flextesa.opam` --- vendors/flextesa-lib/flextesa.opam | 1 + 1 file changed, 1 insertion(+) diff --git a/vendors/flextesa-lib/flextesa.opam b/vendors/flextesa-lib/flextesa.opam index e56a37545088..5f42bf6c12b3 100644 --- a/vendors/flextesa-lib/flextesa.opam +++ b/vendors/flextesa-lib/flextesa.opam @@ -14,6 +14,7 @@ depends: [ "dum" "tezos-stdlib-unix" "lwt" + "fmt" ] build: [ ["dune" "build" "-p" name "-j" jobs] -- GitLab From abfd33153bc2f93ea40ba931aa120e4e77890f7d Mon Sep 17 00:00:00 2001 From: vbot Date: Fri, 13 Sep 2019 18:31:11 +0200 Subject: [PATCH 4/6] Flextesa: adapt to recent mbytes changes and dependencies rework --- .../command_daemons_protocol_change.ml | 545 ++++++++----- src/bin_sandbox/command_voting.ml | 734 ++++++++++++------ vendors/flextesa-lib/dune | 1 + vendors/flextesa-lib/flextesa.opam | 2 +- vendors/flextesa-lib/tezos_protocol.ml | 2 +- 5 files changed, 864 insertions(+), 420 deletions(-) diff --git a/src/bin_sandbox/command_daemons_protocol_change.ml b/src/bin_sandbox/command_daemons_protocol_change.ml index f2f23bfc17ba..f3b70ec55ea1 100644 --- a/src/bin_sandbox/command_daemons_protocol_change.ml +++ b/src/bin_sandbox/command_daemons_protocol_change.ml @@ -8,15 +8,22 @@ let wait_for_voting_period ?level_within_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_within_period ~default:"" + sprintf + "Waiting for voting period: `%s`%s" + period_name + (Option.value_map + level_within_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_within_period ~f:(fun lvl -> - Tezos_client.rpc state ~client `Get + Tezos_client.rpc + state + ~client + `Get ~path:"/chains/main/blocks/head/metadata" >>= fun json -> try @@ -27,24 +34,32 @@ let wait_for_voting_period ?level_within_period state ~client ~attempts period in return (voting_period_position >= lvl) with e -> - failf "Cannot get level.voting_period_position: %s" - (Printexc.to_string e) ) + failf + "Cannot get level.voting_period_position: %s" + (Printexc.to_string e)) >>= fun lvl_ok -> - Tezos_client.rpc state ~client `Get + 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 + Tezos_client.successful_client_cmd + state + ~client ["show"; "voting"; "period"] >>= fun res -> - Console.say state + Console.say + state EF.( - desc_list (wf "Voting period:") + desc_list + (wf "Voting period:") [markdown_verbatim (String.concat ~sep:"\n" res#out)]) - >>= fun () -> return (`Not_done message) ) + >>= 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 @@ -52,19 +67,34 @@ let run state ~protocol ~size ~base_port ~no_daemons_for ?external_peer_ports ~second_endorser_exec ~second_accuser_exec ~admin_exec ~new_protocol_path ~extra_dummy_proposals_batch_size ~extra_dummy_proposals_batch_levels ~waiting_attempts test_variant () = - Helpers.System_dependencies.precheck state `Or_fail + Helpers.System_dependencies.precheck + state + `Or_fail ~protocol_paths:[new_protocol_path] ~executables: - [ node_exec; client_exec; first_baker_exec; first_endorser_exec - ; first_accuser_exec; second_baker_exec; second_endorser_exec - ; second_accuser_exec ] + [ 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 + Test_scenario.network_with_protocol + ?external_peer_ports + ~protocol + ~size + ~base_port + state + ~node_exec + ~client_exec >>= fun (nodes, protocol) -> - Tezos_client.rpc state + Tezos_client.rpc + state ~client:(Tezos_client.of_node (List.hd_exn nodes) ~exec:client_exec) - `Get ~path:"/chains/main/chain_id" + `Get + ~path:"/chains/main/chain_id" >>= fun chain_id_json -> let network_id = match chain_id_json with `String s -> s | _ -> assert false @@ -72,78 +102,111 @@ let run state ~protocol ~size ~base_port ~no_daemons_for ?external_peer_ports 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" ] ) + [ 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 {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 + | 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 (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 ] ) ) + ( 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 + let (key, priv) = Tezos_protocol.Account.(name acc, private_key acc) in Tezos_client.import_secret_key ~state client key priv >>= fun () -> - say state + say + state EF.( desc_list (haf "Registration-as-delegate:") - [ desc (af "Client:") (af "%S" client.Tezos_client.id) - ; desc (af "Key:") (af "%S" key) ]) + [ 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 + say + state EF.( - desc_list (haf "Starting daemons:") - [ desc (af "Client:") (af "%S" client.Tezos_client.id) - ; desc (af "Key:") (af "%S" key) ]) + 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 {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.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 + @ [ 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] ]) ; + (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] ]) ; (* 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. @@ -156,7 +219,9 @@ let run state ~protocol ~size ~base_port ~no_daemons_for ?external_peer_ports >>= 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 + 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 @@ -165,47 +230,64 @@ let run state ~protocol ~size ~base_port ~no_daemons_for ?external_peer_ports match protocols with | `A l when List.exists l ~f:(function `String h -> h = hash | _ -> false) -> - Console.say state + Console.say + state EF.( - wf "Node `%s` already knows protocol `%s`." nod.Tezos_node.id + 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 + Tezos_admin_client.inject_protocol + admin + state ~path:new_protocol_path >>= fun (_, new_protocol_hash) -> ( if new_protocol_hash = hash then - Console.say state + Console.say + state EF.( - wf "Injected protocol `%s` in `%s`" new_protocol_hash + wf + "Injected protocol `%s` in `%s`" + new_protocol_hash nod.Tezos_node.id) else - failf "Injecting protocol %s failed (≠ %s)" new_protocol_hash + failf + "Injecting protocol %s failed (≠ %s)" + new_protocol_hash hash ) - >>= fun () -> return (Some hash) ) + >>= fun () -> return (Some hash)) >>= fun prot_opt -> ( match prot_opt with - | Some s -> return s - | None -> failf "protocol injection problem?" ) + | 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 + 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 )) + sprintf "http://localhost:%d" rpc_port)) ~bakers: - (List.map protocol.Tezos_protocol.bootstrap_accounts + (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 + 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) ] + [ ( protocol.Tezos_protocol.hash, + first_baker_exec, + first_endorser_exec ); + (new_protocol_hash, second_baker_exec, second_endorser_exec) ] >>= fun () -> let msg = EF.( @@ -213,106 +295,155 @@ let run state ~protocol ~size ~base_port ~no_daemons_for ?external_peer_ports (shout "Kiln-Configuration DONE") (wf "Kiln was configured at `%s`" kiln_config.path)) in - Console.say state msg >>= fun () -> return msg ) + Console.say state msg >>= fun () -> return msg) >>= fun kiln_info_opt -> - Test_scenario.Queries.wait_for_all_levels_to_be state - ~attempts:waiting_attempts ~seconds:10. nodes + Test_scenario.Queries.wait_for_all_levels_to_be + state + ~attempts:waiting_attempts + ~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 () -> - Interactive_test.Pauser.generic state + 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." ] + [ 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:waiting_attempts - `Proposal ~level_within_period:3 + wait_for_voting_period + state + ~client:client_0 + ~attempts:waiting_attempts + `Proposal + ~level_within_period:3 >>= fun _ -> let submit_prop acc client hash = - Tezos_client.successful_client_cmd state ~client - [ "submit"; "proposals"; "for" - ; Tezos_protocol.Account.name acc - ; hash; "--force" ] + Tezos_client.successful_client_cmd + state + ~client + [ "submit"; + "proposals"; + "for"; + Tezos_protocol.Account.name acc; + hash; + "--force" ] >>= fun _ -> - Console.sayf state + Console.sayf + state Fmt.( fun ppf () -> pf ppf "%s voted for %s" (Tezos_protocol.Account.name acc) hash) in List_sequential.iter keys_and_daemons ~f:(fun (acc, client, _) -> - submit_prop acc client new_protocol_hash ) + submit_prop acc client new_protocol_hash) >>= fun () -> let make_dummy_protocol_hashes t tag = List.map (List.init extra_dummy_proposals_batch_size ~f:(fun s -> - sprintf "proto-%s-%d" tag s )) + sprintf "proto-%s-%d" tag s)) ~f:(fun s -> - (t, Tezos_crypto.Protocol_hash.(hash_string [s] |> to_b58check)) ) + (t, Tezos_crypto.Protocol_hash.(hash_string [s] |> to_b58check))) in let extra_dummy_protocols = List.bind extra_dummy_proposals_batch_levels ~f:(fun l -> - make_dummy_protocol_hashes l (sprintf "%d" l) ) + make_dummy_protocol_hashes l (sprintf "%d" l)) in - Console.say state + Console.say + state EF.( - wf "Going to also vote for %s" + wf + "Going to also vote for %s" (String.concat ~sep:", " (List.map extra_dummy_protocols ~f:snd))) >>= fun () -> - List_sequential.iteri extra_dummy_protocols + List_sequential.iteri + extra_dummy_protocols ~f:(fun nth (level, proto_hash) -> match List.nth keys_and_daemons (nth / 19) with | None -> failf "Too many dummy protocols Vs available voting power (%d)" nth | Some (acc, client, _) -> - wait_for_voting_period state ~client:client_0 - ~attempts:waiting_attempts `Proposal ~level_within_period:level - >>= fun _ -> submit_prop acc client proto_hash ) + wait_for_voting_period + state + ~client:client_0 + ~attempts:waiting_attempts + `Proposal + ~level_within_period:level + >>= fun _ -> submit_prop acc client proto_hash) >>= fun () -> - wait_for_voting_period state ~client:client_0 ~attempts:waiting_attempts + wait_for_voting_period + state + ~client:client_0 + ~attempts:waiting_attempts `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" ] + Tezos_client.successful_client_cmd + state + ~client + [ "submit"; + "ballot"; + "for"; + Tezos_protocol.Account.name acc; + new_protocol_hash; + "yea" ] >>= fun _ -> - Console.sayf state + Console.sayf + state Fmt.( fun ppf () -> - pf ppf "%s voted Yea to test %s" + pf + ppf + "%s voted Yea to test %s" (Tezos_protocol.Account.name acc) - new_protocol_hash) ) + new_protocol_hash)) >>= fun () -> - wait_for_voting_period state ~client:client_0 ~attempts:waiting_attempts + wait_for_voting_period + state + ~client:client_0 + ~attempts:waiting_attempts `Promotion_vote >>= fun _ -> let protocol_switch_will_happen = match test_variant with - | `Full_upgrade -> true - | `Nay_for_promotion -> false + | `Full_upgrade -> + true + | `Nay_for_promotion -> + false in 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 - ; (if protocol_switch_will_happen then "yea" else "nay") ] + Tezos_client.successful_client_cmd + state + ~client + [ "submit"; + "ballot"; + "for"; + Tezos_protocol.Account.name acc; + new_protocol_hash; + (if protocol_switch_will_happen then "yea" else "nay") ] >>= fun _ -> - Console.sayf state + Console.sayf + state Fmt.( fun ppf () -> - pf ppf "%s voted Yea to promote %s" + pf + ppf + "%s voted Yea to promote %s" (Tezos_protocol.Account.name acc) - new_protocol_hash) ) + new_protocol_hash)) >>= fun () -> - wait_for_voting_period state ~client:client_0 ~attempts:waiting_attempts + wait_for_voting_period + state + ~client:client_0 + ~attempts:waiting_attempts `Proposal >>= fun _ -> - Tezos_client.successful_client_cmd state ~client:client_0 + Tezos_client.successful_client_cmd + state + ~client:client_0 ["show"; "voting"; "period"] >>= fun res -> let protocol_to_wait_for = @@ -322,7 +453,10 @@ let run state ~protocol ~size ~base_port ~no_daemons_for ?external_peer_ports Helpers.wait_for state ~attempts:waiting_attempts ~seconds:4. (fun _ -> Console.say state EF.(wf "Checking actual protocol transition") >>= fun () -> - Tezos_client.rpc state ~client:client_0 `Get + 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 @@ -331,65 +465,85 @@ let run state ~protocol ~size ~base_port ~no_daemons_for ?external_peer_ports if proto_hash <> protocol_to_wait_for then return (`Not_done - (sprintf "Protocol not done: %s Vs %s" proto_hash + (sprintf + "Protocol not done: %s Vs %s" + proto_hash protocol_to_wait_for)) - else return (`Done ()) ) + else return (`Done ())) >>= fun () -> - Interactive_test.Pauser.generic state + Interactive_test.Pauser.generic + state EF. - [ wf "Test finished, protocol is now %s, things should keep baking." - protocol_to_wait_for - ; markdown_verbatim (String.concat ~sep:"\n" res#out) ] + [ wf + "Test finished, protocol is now %s, things should keep baking." + protocol_to_wait_for; + markdown_verbatim (String.concat ~sep:"\n" res#out) ] ~force:true let cmd ~pp_error () = let open Cmdliner in let open Term in let variants = - [ ( "full-upgrade" - , `Full_upgrade - , "Go through the whole voting process and do the protocol change." ) - ; ( "nay-for-promotion" - , `Nay_for_promotion - , "Go through the whole voting process but vote Nay at the last period \ + [ ( "full-upgrade", + `Full_upgrade, + "Go through the whole voting process and do the protocol change." ); + ( "nay-for-promotion", + `Nay_for_promotion, + "Go through the whole voting process but vote Nay at the last period \ and hence stay on the same protocol." ) ] in - Test_command_line.Run_command.make ~pp_error + Test_command_line.Run_command.make + ~pp_error ( pure (fun size - base_port - (`Attempts waiting_attempts) - (`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) - (`Extra_dummy_proposals_batch_size extra_dummy_proposals_batch_size) - (`Extra_dummy_proposals_batch_levels - extra_dummy_proposals_batch_levels) - generate_kiln_config - test_variant - state - -> + base_port + (`Attempts waiting_attempts) + (`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) + (`Extra_dummy_proposals_batch_size + extra_dummy_proposals_batch_size) + (`Extra_dummy_proposals_batch_levels + extra_dummy_proposals_batch_levels) + generate_kiln_config + test_variant + 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 test_variant ~waiting_attempts + 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 + test_variant + ~waiting_attempts ~extra_dummy_proposals_batch_size ~extra_dummy_proposals_batch_levels in - (state, Interactive_test.Pauser.run_test ~pp_error state actual_test) - ) + (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.") @@ -399,21 +553,32 @@ let cmd ~pp_error () = $ Arg.( pure (fun n -> `Attempts n) $ value - (opt int 60 - (info ["waiting-attempts"] + (opt + int + 60 + (info + ["waiting-attempts"] ~doc: "Number of attempts done while waiting for voting periods"))) $ Arg.( pure (fun l -> `External_peers l) $ value - (opt_all int [] - (info ["add-external-peer-port"] ~docv:"PORT-NUMBER" + (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" + (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" @@ -428,13 +593,20 @@ let cmd ~pp_error () = $ Arg.( pure (fun p -> `Protocol_path p) $ required - (pos 0 (some string) None - (info [] ~doc:"The protocol to inject and vote on." + (pos + 0 + (some string) + None + (info + [] + ~doc:"The protocol to inject and vote on." ~docv:"PROTOCOL-PATH"))) $ Arg.( pure (fun l -> `Extra_dummy_proposals_batch_size l) $ value - (opt int 0 + (opt + int + 0 (info ["extra-dummy-proposals-batch-size"] ~docv:"NUMBER" @@ -442,7 +614,9 @@ let cmd ~pp_error () = $ Arg.( pure (fun x -> `Extra_dummy_proposals_batch_levels x) $ value - (opt (list ~sep:',' int) [] + (opt + (list ~sep:',' int) + [] (info ["extra-dummy-proposals-batch-levels"] ~docv:"NUMBER" @@ -452,7 +626,8 @@ let cmd ~pp_error () = $ Kiln.Configuration_directory.cli_term () $ Arg.( let doc = - sprintf "Which variant of the test to run (one of {%s})" + sprintf + "Which variant of the test to run (one of {%s})" ( List.map ~f:(fun (n, _, _) -> n) variants |> String.concat ~sep:", " ) in @@ -466,31 +641,31 @@ let cmd ~pp_error () = "Vote and Protocol-upgrade with bakers, endorsers, and accusers." in let man : Manpage.block list = - [ `S "DAEMONS-UPGRADE TEST" - ; `P + [ `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 + round followed by a protocol change while all the daemons."; + `P (sprintf "There are for now %d variants (see option `--test-variant`):" - (List.length variants)) - ; `Blocks + (List.length variants)); + `Blocks (List.concat_map variants ~f:(fun (n, _, desc) -> - [`Noblank; `P (sprintf "* `%s`: %s" n desc)] )) - ; `P "The test is interactive-only:" - ; `Blocks + [`Noblank; `P (sprintf "* `%s`: %s" n desc)])); + `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 \ + 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 potential protocol switch has happened (and been \ + `--second-*` executables)."; + "Once the potential protocol switch has happened (and been \ verified), the test re-enters an interactive prompt to let \ the user play with the protocol (the first or second one, \ depending on the `--test-variant` option)." ]) ] diff --git a/src/bin_sandbox/command_voting.ml b/src/bin_sandbox/command_voting.ml index 65d366d0b607..9c7ca9b584b1 100644 --- a/src/bin_sandbox/command_voting.ml +++ b/src/bin_sandbox/command_voting.ml @@ -4,92 +4,142 @@ open Internal_pervasives module Counter_log = Helpers.Counter_log let ledger_prompt_notice state ef = - Console.say state + Console.say + state EF.( - desc (shout "Ledger-prompt") + desc + (shout "Ledger-prompt") (list [ef; wf "Please hit “✔” on the ledger."])) let setup_baking_ledger state uri ~client = - Interactive_test.Pauser.generic state + Interactive_test.Pauser.generic + state EF. - [ wf "Setting up the ledger device %S" uri - ; haf + [ wf "Setting up the ledger device %S" uri; + haf "Please make sure the ledger is on the Baking app and quit (`q`) \ this prompt to continue." ] ~force:true >>= fun () -> let key_name = "ledgered" in let baker = Tezos_client.Keyed.make client ~key_name ~secret_key:uri in - ledger_prompt_notice state + ledger_prompt_notice + state EF.( wf "Importing %S in client `%s`. The ledger should be prompting for \ acknowledgment to provide the public key." - uri client.Tezos_client.id) + uri + client.Tezos_client.id) >>= fun () -> Tezos_client.Keyed.initialize state baker >>= fun _ -> - ledger_prompt_notice state + ledger_prompt_notice + state EF.( wf "Setting up %S for baking. The ledger should be showing the setup \ parameters (Address, Main chain, HWMs)." uri) >>= fun () -> - Tezos_client.successful_client_cmd state ~client - [ "setup"; "ledger"; "to"; "bake"; "for"; key_name; "--main-hwm"; "0" - ; "--test-hwm"; "0" ] + Tezos_client.successful_client_cmd + state + ~client + [ "setup"; + "ledger"; + "to"; + "bake"; + "for"; + key_name; + "--main-hwm"; + "0"; + "--test-hwm"; + "0" ] >>= fun _ -> return baker let failf fmt = ksprintf (fun s -> fail (`Scenario_error s)) fmt let transfer state ~client ~src ~dst ~amount = - Tezos_client.successful_client_cmd state ~client - [ "--wait"; "none"; "transfer"; sprintf "%Ld" amount; "from"; src; "to"; dst - ; "--fee"; "0.05"; "--burn-cap"; "0.3" ] + Tezos_client.successful_client_cmd + state + ~client + [ "--wait"; + "none"; + "transfer"; + sprintf "%Ld" amount; + "from"; + src; + "to"; + dst; + "--fee"; + "0.05"; + "--burn-cap"; + "0.3" ] let register state ~client ~dst = - Tezos_client.successful_client_cmd state ~client - [ "--wait"; "none"; "register"; "key"; dst; "as"; "delegate"; "--fee" - ; "0.05" ] + Tezos_client.successful_client_cmd + state + ~client + [ "--wait"; + "none"; + "register"; + "key"; + dst; + "as"; + "delegate"; + "--fee"; + "0.05" ] let bake_until_voting_period ?keep_alive_delegate state ~baker ~attempts period = let client = baker.Tezos_client.Keyed.client 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 + Tezos_client.rpc + state + ~client + `Get ~path:"/chains/main/blocks/head/votes/current_period_kind" >>= function - | `String p when p = period_name -> return (`Done (nth - 1)) + | `String p when p = period_name -> + return (`Done (nth - 1)) | other -> Asynchronous_result.map_option keep_alive_delegate ~f:(fun dst -> - register state ~client ~dst >>= fun res -> return () ) + register state ~client ~dst >>= fun res -> return ()) >>= fun _ -> ksprintf (Tezos_client.Keyed.bake state baker) - "Baker %s bakes %d/%d waiting for %S voting period" client.id nth - attempts period_name + "Baker %s bakes %d/%d waiting for %S voting period" + client.id + nth + attempts + period_name >>= fun () -> - return (`Not_done (sprintf "Waiting for %S period" period_name)) ) + return (`Not_done (sprintf "Waiting for %S period" period_name))) let check_understood_protocols state ~chain ~client ~protocol_hash ~expect_clueless_client = Asynchronous_result.bind_on_result - (Tezos_client.successful_client_cmd state ~client + (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 ) + 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 ) + | 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 ) + | 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 @@ -97,37 +147,50 @@ let run state ~winner_path ~demo_path ~current_hash ~node_exec ~client_exec let default_attempts = 50 in Helpers.clear_root state >>= fun () -> - Helpers.System_dependencies.precheck state `Or_fail + 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 + Interactive_test.Pauser.generic + state EF.[af "Ready to start"; af "Root path deleted."] >>= fun () -> - let protocol, baker_0_account, baker_0_balance = + let (protocol, baker_0_account, baker_0_balance) = 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 - hash - ; time_between_blocks= [1; 0] - ; bootstrap_accounts= + ( { + d with + 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) ) } - , fst baker - , snd baker ) + if fst baker = n then (n, v) else (n, 1_000L)); + }, + fst baker, + snd baker ) in - Test_scenario.network_with_protocol ~protocol ~size ~base_port state - ~node_exec ~client_exec + 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.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"] + @ [ 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)) ]) ; @@ -137,7 +200,9 @@ let run state ~winner_path ~demo_path ~current_hash ~node_exec ~client_exec Tezos_client.of_node ~exec:client_exec (List.nth_exn nodes n) in let baker_0 = - Tezos_client.Keyed.make (client 0) ~key_name:"baker-0" + Tezos_client.Keyed.make + (client 0) + ~key_name:"baker-0" ~secret_key:(Tezos_protocol.Account.private_key baker_0_account) in Tezos_client.Keyed.initialize state baker_0 @@ -145,7 +210,7 @@ let run state ~winner_path ~demo_path ~current_hash ~node_exec ~client_exec let level_counter = Counter_log.create () in let first_bakes = 5 in Loop.n_times first_bakes (fun nth -> - ksprintf (Tezos_client.Keyed.bake state baker_0) "initial-bake %d" nth ) + ksprintf (Tezos_client.Keyed.bake state baker_0) "initial-bake %d" nth) >>= fun () -> let initial_level = first_bakes + 1 in Counter_log.add level_counter "initial_level" initial_level ; @@ -155,40 +220,53 @@ let run state ~winner_path ~demo_path ~current_hash ~node_exec ~client_exec >>= fun () -> let account = Tezos_protocol.Account.of_name "special-baker" in let baker = - Tezos_client.Keyed.make (client 0) + Tezos_client.Keyed.make + (client 0) ~key_name:(Tezos_protocol.Account.name account) ~secret_key:(Tezos_protocol.Account.private_key account) in Tezos_client.Keyed.initialize state baker >>= fun _ -> return baker - | Some uri -> setup_baking_ledger state ~client:(client 0) uri ) + | 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_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} + {baker_0 with client = winner_client} in let winner_special_baker = let open Tezos_client.Keyed in - {special_baker with client= winner_client} + {special_baker with client = winner_client} in - Interactive_test.Pauser.add_commands state + Interactive_test.Pauser.add_commands + state Interactive_test.Commands. - [ arbitrary_command_on_clients state - ~command_names:["wc"; "winner-client"] ?make_admin:None + [ arbitrary_command_on_clients + state + ~command_names:["wc"; "winner-client"] + ?make_admin:None ~clients:[winner_client] ] ; - Interactive_test.Pauser.generic state + Interactive_test.Pauser.generic + state EF.[wf "You can now try the new-client"] >>= fun () -> - Interactive_test.Pauser.add_commands state + Interactive_test.Pauser.add_commands + state Interactive_test.Commands. - [ arbitrary_command_on_clients state ~command_names:["baker"] ~make_admin + [ arbitrary_command_on_clients + state + ~command_names:["baker"] + ~make_admin ~clients:[special_baker.Tezos_client.Keyed.client] ] ; - transfer state (* Tezos_client.successful_client_cmd state *) + transfer + state (* Tezos_client.successful_client_cmd state *) ~client:(client 0) ~amount:(Int64.div baker_0_balance 2_000_000L) - ~src:"baker-0" ~dst:special_baker.Tezos_client.Keyed.key_name + ~src:"baker-0" + ~dst:special_baker.Tezos_client.Keyed.key_name >>= fun res -> - Console.say state + Console.say + state EF.( desc (wf "Successful transfer baker-0 -> special:") @@ -198,20 +276,32 @@ let run state ~winner_path ~demo_path ~current_hash ~node_exec ~client_exec Loop.n_times after_transfer_bakes (fun nth -> ksprintf (Tezos_client.Keyed.bake state baker_0) - "after-transfer-bake %d" nth ) + "after-transfer-bake %d" + nth) >>= fun () -> Counter_log.add level_counter "after-transfer-bakes" after_transfer_bakes ; - Test_scenario.Queries.wait_for_all_levels_to_be state - ~attempts:default_attempts ~seconds:8. nodes + Test_scenario.Queries.wait_for_all_levels_to_be + state + ~attempts:default_attempts + ~seconds:8. + nodes (`At_least (Counter_log.sum level_counter)) >>= fun () -> Asynchronous_result.map_option with_ledger ~f:(fun _ -> - ledger_prompt_notice state EF.(wf "Registering as delegate.") ) + ledger_prompt_notice state EF.(wf "Registering as delegate.")) >>= fun (_ : unit option) -> - Tezos_client.successful_client_cmd state ~client:(client 0) - [ "--wait"; "none"; "register"; "key" - ; special_baker.Tezos_client.Keyed.key_name; "as"; "delegate"; "--fee" - ; "0.5" ] + Tezos_client.successful_client_cmd + state + ~client:(client 0) + [ "--wait"; + "none"; + "register"; + "key"; + special_baker.Tezos_client.Keyed.key_name; + "as"; + "delegate"; + "--fee"; + "0.5" ] >>= fun _ -> let activation_bakes = let open Tezos_protocol in @@ -220,15 +310,21 @@ let run state ~winner_path ~demo_path ~current_hash ~node_exec ~client_exec Loop.n_times activation_bakes (fun nth -> ksprintf (Tezos_client.Keyed.bake state baker_0) - "Baking after new delegate registered: %d/%d" nth activation_bakes + "Baking after new delegate registered: %d/%d" + nth + activation_bakes >>= fun () -> - Tezos_client.successful_client_cmd state ~client:(client 0) + Tezos_client.successful_client_cmd + state + ~client:(client 0) ["rpc"; "get"; "/chains/main/blocks/head/helpers/baking_rights"] >>= fun res -> - Console.say state + Console.say + state EF.( - desc (haf "Baking rights") - (markdown_verbatim (String.concat ~sep:"\n" res#out))) ) + desc + (haf "Baking rights") + (markdown_verbatim (String.concat ~sep:"\n" res#out)))) >>= fun () -> Counter_log.add level_counter "activation-bakes" activation_bakes ; Tezos_client.Keyed.bake state special_baker "Baked by Special Baker™" @@ -240,13 +336,22 @@ let run state ~winner_path ~demo_path ~current_hash ~node_exec ~client_exec the next one *) 3 * protocol.blocks_per_voting_period) in - bake_until_voting_period state ~baker:special_baker ~attempts `Proposal + bake_until_voting_period + state + ~baker:special_baker + ~attempts + `Proposal ~keep_alive_delegate:baker_0.key_name >>= fun extra_bakes_waiting_for_proposal_period -> - Counter_log.add level_counter "wait-for-proposal-period" + Counter_log.add + level_counter + "wait-for-proposal-period" extra_bakes_waiting_for_proposal_period ; - Test_scenario.Queries.wait_for_all_levels_to_be state - ~attempts:default_attempts ~seconds:8. nodes + Test_scenario.Queries.wait_for_all_levels_to_be + state + ~attempts:default_attempts + ~seconds:8. + nodes (`At_least (Counter_log.sum level_counter)) >>= fun () -> let admin_0 = Tezos_admin_client.of_client ~exec:admin_exec (client 0) in @@ -257,135 +362,188 @@ let run state ~winner_path ~demo_path ~current_hash ~node_exec ~client_exec 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" - (Filename.quote path) (Filename.quote tmpdir) + Running_processes.run_successful_cmdf + state + "cp -L -R %s %s" + (Filename.quote path) + (Filename.quote tmpdir) >>= fun _ -> ( if make_different then - Running_processes.run_successful_cmdf state - "echo '(* Protocol %s *)' >> %s/main.mli" name (Filename.quote tmpdir) + 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 + Interactive_test.Pauser.generic + state EF. - [ af "Just injected %s (%s): %s" name path hash - ; markdown_verbatim (String.concat ~sep:"\n" res#out) ] + [ af "Just injected %s (%s): %s" name path hash; + markdown_verbatim (String.concat ~sep:"\n" res#out) ] >>= fun () -> return hash in make_and_inject_protocol "winner" winner_path >>= fun winner_hash -> - make_and_inject_protocol ~make_different:(winner_path = demo_path) "demo" + 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 - Interactive_test.Pauser.generic state + Interactive_test.Pauser.generic + state EF. - [ af "Network up" - ; desc (haf "Protcols") + [ af "Network up"; + desc (haf "Protcols") @@ list (List.map after_injections_protocols ~f:(fun p -> - af "`%s` (%s)" p + af + "`%s` (%s)" + p ( if List.mem default_protocols p ~equal:String.equal then "previously known" else match p with - | _ when p = winner_hash -> "injected winner" - | _ when p = demo_hash -> "injected demo" - | _ -> "injected unknown" ) )) ] + | _ when p = winner_hash -> + "injected winner" + | _ when p = demo_hash -> + "injected demo" + | _ -> + "injected unknown" ))) ] >>= fun () -> Asynchronous_result.map_option with_ledger ~f:(fun _ -> - Interactive_test.Pauser.generic state + Interactive_test.Pauser.generic + state EF. - [ af "About to VOTE" - ; haf "Please switch to the Wallet app and quit (`q`) this prompt." + [ af "About to VOTE"; + haf "Please switch to the Wallet app and quit (`q`) this prompt." ] - ~force:true ) + ~force:true) >>= fun (_ : unit option) -> let submit_proposals baker props = Asynchronous_result.map_option with_ledger ~f:(fun _ -> - ledger_prompt_notice state + ledger_prompt_notice + state EF.( - wf "Submitting proposal%s: %s" + wf + "Submitting proposal%s: %s" (if List.length props = 1 then "" else "s") - (String.concat ~sep:", " props)) ) + (String.concat ~sep:", " props))) >>= fun _ -> - Tezos_client.successful_client_cmd state + Tezos_client.successful_client_cmd + state ~client:baker.Tezos_client.Keyed.client (["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 to_submit_first + | false -> + submit_proposals special_baker to_submit_first | true -> List_sequential.iter to_submit_first ~f:(fun one -> - submit_proposals special_baker [one] ) ) + submit_proposals special_baker [one]) ) >>= fun () -> - Tezos_client.successful_client_cmd state ~client:baker_0.client + Tezos_client.successful_client_cmd + state + ~client:baker_0.client ["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 + bake_until_voting_period + state + ~baker:baker_0 + ~attempts:protocol.blocks_per_voting_period + `Testing_vote ~keep_alive_delegate:special_baker.key_name >>= fun extra_bakes_waiting_for_testing_vote_period -> - Counter_log.add level_counter "wait-for-testing-vote-period" + Counter_log.add + level_counter + "wait-for-testing-vote-period" extra_bakes_waiting_for_testing_vote_period ; - Test_scenario.Queries.wait_for_all_levels_to_be state - ~attempts:default_attempts ~seconds:8. nodes + Test_scenario.Queries.wait_for_all_levels_to_be + state + ~attempts:default_attempts + ~seconds:8. + nodes (`At_least (Counter_log.sum level_counter)) >>= fun () -> Helpers.wait_for state ~attempts:default_attempts ~seconds:2. (fun nth -> - Tezos_client.rpc state ~client:(client 1) `Get + 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_hash then return (`Not_done - (sprintf "Waiting for current_proposal_json to be %s (%s)" + (sprintf + "Waiting for current_proposal_json to be %s (%s)" winner_hash Ezjsonm.(to_string (wrap current_proposal_json)))) - else return (`Done ()) ) + else return (`Done ())) >>= fun () -> - Tezos_client.successful_client_cmd state ~client:baker_0.client + Tezos_client.successful_client_cmd + state + ~client:baker_0.client ["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_hash) ) + ledger_prompt_notice + state + EF.(wf "Submitting “Yes” ballot for %S" winner_hash)) >>= fun (_ : unit option) -> - Tezos_client.successful_client_cmd state ~client:special_baker.client + Tezos_client.successful_client_cmd + state + ~client:special_baker.client ["submit"; "ballot"; "for"; special_baker.key_name; winner_hash; "yay"] >>= fun _ -> - Interactive_test.Pauser.generic state + Interactive_test.Pauser.generic + state EF.[af "Ballots are in (not baked though)"] >>= fun () -> - bake_until_voting_period state ~baker:baker_0 + bake_until_voting_period + state + ~baker:baker_0 ~attempts:(1 + protocol.blocks_per_voting_period) - ~keep_alive_delegate:special_baker.key_name `Testing + ~keep_alive_delegate:special_baker.key_name + `Testing >>= fun extra_bakes_waiting_for_testing_period -> - Counter_log.add level_counter "wait-for-testing-period" + Counter_log.add + level_counter + "wait-for-testing-period" extra_bakes_waiting_for_testing_period ; - Test_scenario.Queries.wait_for_all_levels_to_be state - ~attempts:default_attempts ~seconds:8. nodes + Test_scenario.Queries.wait_for_all_levels_to_be + state + ~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 + 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 + Interactive_test.Pauser.generic + state EF. - [ af "About to bake on the test chain." - ; haf + [ af "About to bake on the test chain."; + haf "Please switch back to the Baking app and quit (`q`) \ this prompt." ] - ~force:true ) + ~force:true) >>= fun (_ : unit option) -> let testing_bakes = 5 in Loop.n_times testing_bakes (fun ith -> @@ -393,25 +551,39 @@ let run state ~winner_path ~demo_path ~current_hash ~node_exec ~client_exec 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) ) + 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 + 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 + Interactive_test.Pauser.generic + state EF.[wf "Testing period, with proper winner-client, have fun."] >>= fun () -> return () | `Expected_misunderstanding -> - Console.say state + Console.say + state EF.(wf "Winner-Client cannot bake on test chain (expected)") | `Failure_to_understand -> - failf "Winner-Client cannot bake on test chain!" ) + 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 + Tezos_client.rpc + state + ~client:(client 1) + `Get ~path:"/chains/main/blocks/head/metadata" >>= fun metadata_json -> try @@ -419,7 +591,8 @@ let run state ~winner_path ~demo_path ~current_hash ~node_exec ~client_exec Jqo.field metadata_json ~k:"test_chain_status" |> Jqo.field ~k:"protocol" with - | `String s when s = winner_hash -> return (`Done ()) + | `String s when s = winner_hash -> + return (`Done ()) | other -> return (`Not_done @@ -427,94 +600,134 @@ let run state ~winner_path ~demo_path ~current_hash ~node_exec ~client_exec with e -> return (`Not_done - (sprintf "Cannot get test-chain protocol: %s → %s" + (sprintf + "Cannot get test-chain protocol: %s → %s" (Exn.to_string e) - Ezjsonm.(to_string (wrap metadata_json)))) ) + Ezjsonm.(to_string (wrap metadata_json))))) >>= fun () -> - bake_until_voting_period state ~baker:baker_0 + bake_until_voting_period + state + ~baker:baker_0 ~attempts:(1 + protocol.blocks_per_voting_period) - ~keep_alive_delegate:special_baker.key_name `Promotion_vote + ~keep_alive_delegate:special_baker.key_name + `Promotion_vote >>= fun extra_bakes_waiting_for_promotion_period -> - Counter_log.add level_counter "wait-for-promotion-period" + Counter_log.add + level_counter + "wait-for-promotion-period" extra_bakes_waiting_for_promotion_period ; - Test_scenario.Queries.wait_for_all_levels_to_be state - ~attempts:default_attempts ~seconds:8. nodes + Test_scenario.Queries.wait_for_all_levels_to_be + state + ~attempts:default_attempts + ~seconds:8. + nodes (`At_least (Counter_log.sum level_counter)) >>= fun () -> Interactive_test.Pauser.generic state EF.[haf "Before ballots"] >>= fun () -> - Tezos_client.successful_client_cmd state ~client:baker_0.client + Tezos_client.successful_client_cmd + state + ~client:baker_0.client ["submit"; "ballot"; "for"; baker_0.key_name; winner_hash; "yay"] >>= fun _ -> Asynchronous_result.map_option with_ledger ~f:(fun _ -> - Interactive_test.Pauser.generic state + Interactive_test.Pauser.generic + state EF. - [ af "About to cast approval ballot." - ; haf + [ 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_hash) ) + ledger_prompt_notice + state + EF.(wf "Submitting “Yes” ballot for %S" winner_hash)) >>= fun (_ : unit option) -> - Tezos_client.successful_client_cmd state ~client:special_baker.client + Tezos_client.successful_client_cmd + state + ~client:special_baker.client ["submit"; "ballot"; "for"; special_baker.key_name; winner_hash; "yay"] >>= fun _ -> - Interactive_test.Pauser.generic state + Interactive_test.Pauser.generic + state EF.[af "Final ballot(s) are in (not baked though)"] >>= fun () -> let ballot_bakes = 1 in Loop.n_times ballot_bakes (fun _ -> - Tezos_client.Keyed.bake state baker_0 "Baking the promotion vote ballots" - ) + Tezos_client.Keyed.bake state baker_0 "Baking the promotion vote ballots") >>= fun () -> Counter_log.add level_counter "bake-the-ballots" ballot_bakes ; - Tezos_client.successful_client_cmd state ~client:(client 0) + Tezos_client.successful_client_cmd + state + ~client:(client 0) ["list"; "understood"; "protocols"] >>= fun client_protocols_result -> - Interactive_test.Pauser.generic state + Interactive_test.Pauser.generic + state EF. - [ af "Final ballot(s) are baked in." - ; af "The client `%s` understands the following protocols: %s" + [ af "Final ballot(s) are baked in."; + af + "The client `%s` understands the following protocols: %s" Tezos_executable.( Option.value ~default:(default_binary client_exec) client_exec.binary) (String.concat ~sep:", " client_protocols_result#out) ] >>= fun () -> - Helpers.wait_for state ~seconds:0.5 - ~attempts:(1 + protocol.blocks_per_voting_period) (fun nth -> + Helpers.wait_for + state + ~seconds:0.5 + ~attempts:(1 + protocol.blocks_per_voting_period) + (fun nth -> let client = baker_0.client in - Running_processes.run_successful_cmdf state - "curl http://localhost:%d/chains/main/blocks/head/metadata" client.port + Running_processes.run_successful_cmdf + state + "curl http://localhost:%d/chains/main/blocks/head/metadata" + client.port >>= fun curl_res -> 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_hash -> return (`Done (nth - 1)) + | `String p when p = winner_hash -> + return (`Done (nth - 1)) | other -> - transfer state ~client ~amount:1L + transfer + state + ~client + ~amount:1L ~src:baker_0.Tezos_client.Keyed.key_name ~dst:special_baker.Tezos_client.Keyed.key_name >>= fun _ -> ksprintf (Tezos_client.Keyed.bake state baker_0) - "Baker %s bakes %d/%d waiting for next protocol: %S" client.id nth - attempts winner_hash + "Baker %s bakes %d/%d waiting for next protocol: %S" + client.id + nth + attempts + winner_hash >>= fun () -> return (`Not_done - (sprintf "Waiting for next_protocol: %S (≠ %s)" winner_hash - Ezjsonm.(to_string (wrap other)))) ) + (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" + Counter_log.add + level_counter + "wait-for-next-protocol" extra_bakes_waiting_for_next_protocol ; - check_understood_protocols state ~client:winner_client ~chain:"main" - ~protocol_hash:winner_hash ~expect_clueless_client:clueless_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 + Console.say + state EF.( wf "As expected, the client does not know about %s" winner_hash) | `Failure_to_understand -> @@ -524,53 +737,71 @@ let run state ~winner_path ~demo_path ~current_hash ~node_exec ~client_exec >>= fun () -> (* This actually depends on the protocol upgrade. *) Asynchronous_result.bind_on_result - (Tezos_client.successful_client_cmd state ~client:winner_client + (Tezos_client.successful_client_cmd + state + ~client:winner_client ["upgrade"; "baking"; "state"]) ~f:(function - | Ok _ -> return () + | Ok _ -> + return () | Error _ -> - Console.say state + Console.say + state EF.( - desc (shout "Warning") + desc + (shout "Warning") (wf "Command `upgrade baking state` failed, but we \ - keep going with the baking.")) ) + keep going with the baking."))) >>= fun () -> Asynchronous_result.map_option with_ledger ~f:(fun _ -> - Interactive_test.Pauser.generic state + Interactive_test.Pauser.generic + state EF. - [ af "About to bake on the new winning protocol." - ; haf + [ 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` *) ) + (* USB thing is often slower than humans hitting `q` *)) >>= fun (_ : unit option) -> - Tezos_client.Keyed.bake state winner_baker_0 + 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 + Tezos_client.Keyed.bake + state + winner_special_baker "Second bake on new protocol !!" >>= fun () -> - Counter_log.incr level_counter + Counter_log.incr + level_counter "special-baker-bakes-on-new-protocol" ; - Tezos_client.rpc state ~client:winner_client `Get + 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 () + | `String p when p = winner_hash -> + return () | other -> - failf "Protocol is not `%s` but `%s`" winner_hash - Ezjsonm.(to_string (wrap other)) ) ) + failf + "Protocol is not `%s` but `%s`" + winner_hash + Ezjsonm.(to_string (wrap other)) )) >>= fun () -> - Interactive_test.Pauser.generic state + Interactive_test.Pauser.generic + state EF. - [ haf "End of the Voting test: SUCCESS \\o/" - ; desc + [ 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)) ] >>= fun () -> return () @@ -578,40 +809,64 @@ let run state ~winner_path ~demo_path ~current_hash ~node_exec ~client_exec let cmd ~pp_error () = let open Cmdliner in let open Term in - Test_command_line.Run_command.make ~pp_error + Test_command_line.Run_command.make + ~pp_error ( pure (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) - state - -> - ( state - , Interactive_test.Pauser.run_test state ~pp_error - (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) ) ) + 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) + state + -> + ( state, + Interactive_test.Pauser.run_test + state + ~pp_error + (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" + (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.( pure Filename.dirname $ required - (pos 1 (some string) None - (info [] ~docv:"LOSER-PROTOCOL-PATH" + (pos + 1 + (some string) + None + (info + [] + ~docv:"LOSER-PROTOCOL-PATH" ~doc: "The protocol to inject and down-vote, e.g. \ `./src/bin_client/test/proto_test_injection/TEZOS_PROTOCOL` \ @@ -634,19 +889,28 @@ let cmd ~pp_error () = $ Arg.( pure (fun p -> `Hash p) $ value - (opt (some string) None - (info ["current-hash"] + (opt + (some string) + None + (info + ["current-hash"] ~doc:"The hash to advertise as the current protocol."))) $ Arg.( pure (fun p -> `Base_port p) $ value - (opt int 46_000 + (opt + int + 46_000 (info ["base-port"] ~doc:"Base port number to build upon."))) $ Arg.( pure (fun x -> `With_ledger x) $ value - (opt (some string) None - (info ["with-ledger"] ~docv:"ledger://..." + (opt + (some string) + None + (info + ["with-ledger"] + ~docv:"ledger://..." ~doc: "Do the test with a Ledger Nano device as one of the \ bakers/voters."))) @@ -654,39 +918,43 @@ let cmd ~pp_error () = pure (fun x -> `Serialize_proposals x) $ value (flag - (info ["serialize-proposals"] + (info + ["serialize-proposals"] ~doc: "Run the proposals one-by-one instead of all together \ (preferred by the Ledger)."))) $ Test_command_line.cli_state ~name:"voting" () ) (let doc = "Sandbox network with a full round of voting." in let man : Manpage.block list = - [ `S "VOTING TEST" - ; `P + [ `S "VOTING TEST"; + `P "This command provides a test which uses a network sandbox to \ perform a full round of protocol vote and upgrade, including \ voting and baking on the test chain with or without a Ledger Nano \ - device."; `P "There are two main test behaviors:" - ; `P + device."; + `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 + 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 + 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 + 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. In this case, the option \ diff --git a/vendors/flextesa-lib/dune b/vendors/flextesa-lib/dune index c414c0e03c34..e503e19f23da 100644 --- a/vendors/flextesa-lib/dune +++ b/vendors/flextesa-lib/dune @@ -14,5 +14,6 @@ ezjsonm tezos-stdlib-unix tezos-crypto + tezos-base )) diff --git a/vendors/flextesa-lib/flextesa.opam b/vendors/flextesa-lib/flextesa.opam index 5f42bf6c12b3..9343a433535e 100644 --- a/vendors/flextesa-lib/flextesa.opam +++ b/vendors/flextesa-lib/flextesa.opam @@ -13,6 +13,7 @@ depends: [ "genspio" { = "0.0.2" } "dum" "tezos-stdlib-unix" + "tezos-base" "lwt" "fmt" ] @@ -22,4 +23,3 @@ build: [ ] synopsis: "Flexible Tezos Sandboxes: library to run various Tezos network-sandboxes" - diff --git a/vendors/flextesa-lib/tezos_protocol.ml b/vendors/flextesa-lib/tezos_protocol.ml index 9d7174f12ad8..ea27b8f9e31b 100644 --- a/vendors/flextesa-lib/tezos_protocol.ml +++ b/vendors/flextesa-lib/tezos_protocol.ml @@ -10,7 +10,7 @@ module Key = struct let make name = let seed = - Tezos_stdlib.MBytes.of_string + Bigstring.of_string (String.concat ~sep:"" (List.init 42 ~f:(fun _ -> name))) in let pkh, pk, sk = Tezos_crypto.Ed25519.generate_key ~seed () in {name; pkh; pk; sk} -- GitLab From 20931132334ba406fadcf2cd8c2be417653161cf Mon Sep 17 00:00:00 2001 From: vbot Date: Fri, 13 Sep 2019 18:30:13 +0000 Subject: [PATCH 5/6] Update .gitlab-ci.yml --- .gitlab-ci.yml | 62 +++++++++++++++++++++++++------------------------- 1 file changed, 31 insertions(+), 31 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 315cd25b8959..2d24416addb4 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -618,141 +618,141 @@ opam:42:tezos-client-alpha: variables: package: tezos-client-alpha -opam:43:tezos-protocol-updater: +opam:43:tezos-version: + <<: *opam_definition + variables: + package: tezos-version + +opam:44:tezos-protocol-updater: <<: *opam_definition variables: package: tezos-protocol-updater -opam:44:tezos-baking-alpha: +opam:45:tezos-baking-alpha: <<: *opam_definition variables: package: tezos-baking-alpha -opam:45:tezos-protocol-genesis: +opam:46:tezos-protocol-genesis: <<: *opam_definition variables: package: tezos-protocol-genesis -opam:46:ocplib-resto-json: +opam:47:ocplib-resto-json: <<: *opam_definition variables: package: ocplib-resto-json -opam:47:tezos-validation: +opam:48:tezos-validation: <<: *opam_definition variables: package: tezos-validation -opam:48:ocplib-resto-cohttp-server: +opam:49:ocplib-resto-cohttp-server: <<: *opam_definition variables: package: ocplib-resto-cohttp-server -opam:49:tezos-protocol-demo-noops: +opam:50:tezos-protocol-demo-noops: <<: *opam_definition variables: package: tezos-protocol-demo-noops -opam:50:tezos-baking-alpha-commands: +opam:51:tezos-baking-alpha-commands: <<: *opam_definition variables: package: tezos-baking-alpha-commands -opam:51:tezos-client-alpha-commands: +opam:52:tezos-client-alpha-commands: <<: *opam_definition variables: package: tezos-client-alpha-commands -opam:52:tezos-client-genesis: +opam:53:tezos-client-genesis: <<: *opam_definition variables: package: tezos-client-genesis -opam:53:ocplib-ezresto: +opam:54:ocplib-ezresto: <<: *opam_definition variables: package: ocplib-ezresto -opam:54:tezos-embedded-protocol-alpha: +opam:55:tezos-embedded-protocol-alpha: <<: *opam_definition variables: package: tezos-embedded-protocol-alpha -opam:55:tezos-shell: +opam:56:tezos-shell: <<: *opam_definition variables: package: tezos-shell -opam:56:tezos-protocol-alpha-parameters: +opam:57:tezos-protocol-alpha-parameters: <<: *opam_definition variables: package: tezos-protocol-alpha-parameters -opam:57:tezos-rpc-http-server: +opam:58:tezos-rpc-http-server: <<: *opam_definition variables: package: tezos-rpc-http-server -opam:58:tezos-embedded-protocol-demo-noops: +opam:59:tezos-embedded-protocol-demo-noops: <<: *opam_definition variables: package: tezos-embedded-protocol-demo-noops -opam:59:tezos-embedded-protocol-genesis: +opam:60:tezos-embedded-protocol-genesis: <<: *opam_definition variables: package: tezos-embedded-protocol-genesis -opam:60:tezos-endorser-alpha-commands: +opam:61:tezos-endorser-alpha-commands: <<: *opam_definition variables: package: tezos-endorser-alpha-commands -opam:61:tezos-client: +opam:62:tezos-client: <<: *opam_definition variables: package: tezos-client -opam:62:ocplib-ezresto-directory: +opam:63:ocplib-ezresto-directory: <<: *opam_definition variables: package: ocplib-ezresto-directory -opam:63:tezos-accuser-alpha: +opam:64:tezos-accuser-alpha: <<: *opam_definition variables: package: tezos-accuser-alpha -opam:64:tezos-codec: +opam:65:tezos-codec: <<: *opam_definition variables: package: tezos-codec -opam:65:ocplib-json-typed-browser: +opam:66:ocplib-json-typed-browser: <<: *opam_definition variables: package: ocplib-json-typed-browser -opam:66:tezos-mempool-alpha: +opam:67:tezos-mempool-alpha: <<: *opam_definition variables: package: tezos-mempool-alpha -opam:67:tezos-tooling: +opam:68:tezos-tooling: <<: *opam_definition variables: package: tezos-tooling -opam:68:flextesa: +opam:69:flextesa: <<: *opam_definition variables: package: flextesa -opam:69:tezos-version: - <<: *opam_definition - variables: - package: tezos-version - opam:70:tezos-protocol-alpha-tests: <<: *opam_definition variables: -- GitLab From 7c4daf6761b9ec320e6d4e25b7d98043a3287371 Mon Sep 17 00:00:00 2001 From: Sebastien Mondet Date: Fri, 13 Sep 2019 18:37:32 -0400 Subject: [PATCH 6/6] Vendor: fix flextesa-lib opam file --- vendors/flextesa-lib/flextesa.opam | 1 + 1 file changed, 1 insertion(+) diff --git a/vendors/flextesa-lib/flextesa.opam b/vendors/flextesa-lib/flextesa.opam index 9343a433535e..07029b110033 100644 --- a/vendors/flextesa-lib/flextesa.opam +++ b/vendors/flextesa-lib/flextesa.opam @@ -16,6 +16,7 @@ depends: [ "tezos-base" "lwt" "fmt" + "cohttp-lwt-unix" ] build: [ ["dune" "build" "-p" name "-j" jobs] -- GitLab