diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index ab31b2cf4..1bfe06709 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -323,190 +323,197 @@ opam:25:tezos-protocol-environment-sigs: variables: package: tezos-protocol-environment-sigs -opam:26:tezos-client-base: - <<: *opam_definition - variables: - package: tezos-client-base - -opam:27:tezos-protocol-compiler: - <<: *opam_definition - variables: - package: tezos-protocol-compiler - -opam:28:tezos-signer-services: - <<: *opam_definition - variables: - package: tezos-signer-services - -opam:29:tezos-protocol-alpha: - <<: *opam_definition - variables: - package: tezos-protocol-alpha - -opam:30:tezos-protocol-environment: - <<: *opam_definition - variables: - package: tezos-protocol-environment - -opam:31:tezos-signer-backends: - <<: *opam_definition - variables: - package: tezos-signer-backends - -opam:32:tezos-client-alpha: - <<: *opam_definition - variables: - package: tezos-client-alpha - -opam:33:tezos-client-commands: - <<: *opam_definition - variables: - package: tezos-client-commands - -opam:34:tezos-protocol-environment-shell: - <<: *opam_definition - variables: - package: tezos-protocol-environment-shell - -opam:35:tezos-baking-alpha: - <<: *opam_definition - variables: - package: tezos-baking-alpha - -opam:36:tezos-protocol-genesis: - <<: *opam_definition - variables: - package: tezos-protocol-genesis - -opam:37:ocplib-resto-json: - <<: *opam_definition - variables: - package: ocplib-resto-json - -opam:38:tezos-protocol-updater: - <<: *opam_definition - variables: - package: tezos-protocol-updater - -opam:39:tezos-p2p: - <<: *opam_definition - variables: - package: tezos-p2p - -opam:40:tezos-baking-alpha-commands: - <<: *opam_definition - variables: - package: tezos-baking-alpha-commands - -opam:41:tezos-client-alpha-commands: - <<: *opam_definition - variables: - package: tezos-client-alpha-commands - -opam:42:tezos-client-base-unix: - <<: *opam_definition - variables: - package: tezos-client-base-unix - -opam:43:tezos-client-genesis: - <<: *opam_definition - variables: - package: tezos-client-genesis - -opam:44:ocplib-ezresto: - <<: *opam_definition - variables: - package: ocplib-ezresto - -opam:45:ledgerwallet: +opam:26:ledgerwallet: <<: *opam_definition variables: package: ledgerwallet -opam:46:tezos-embedded-protocol-alpha: +opam:27:tezos-client-base: + <<: *opam_definition + variables: + package: tezos-client-base + +opam:28:tezos-protocol-compiler: + <<: *opam_definition + variables: + package: tezos-protocol-compiler + +opam:29:ledgerwallet-tezos: + <<: *opam_definition + variables: + package: ledgerwallet-tezos + +opam:30:tezos-signer-services: + <<: *opam_definition + variables: + package: tezos-signer-services + +opam:31:tezos-protocol-alpha: + <<: *opam_definition + variables: + package: tezos-protocol-alpha + +opam:32:tezos-protocol-environment: + <<: *opam_definition + variables: + package: tezos-protocol-environment + +opam:33:tezos-signer-backends: + <<: *opam_definition + variables: + package: tezos-signer-backends + +opam:34:tezos-client-alpha: + <<: *opam_definition + variables: + package: tezos-client-alpha + +opam:35:tezos-client-commands: + <<: *opam_definition + variables: + package: tezos-client-commands + +opam:36:tezos-protocol-environment-shell: + <<: *opam_definition + variables: + package: tezos-protocol-environment-shell + +opam:37:tezos-baking-alpha: + <<: *opam_definition + variables: + package: tezos-baking-alpha + +opam:38:tezos-protocol-genesis: + <<: *opam_definition + variables: + package: tezos-protocol-genesis + +opam:39:ocplib-resto-json: + <<: *opam_definition + variables: + package: ocplib-resto-json + +opam:40:tezos-protocol-updater: + <<: *opam_definition + variables: + package: tezos-protocol-updater + +opam:41:tezos-p2p: + <<: *opam_definition + variables: + package: tezos-p2p + +opam:42:tezos-baking-alpha-commands: + <<: *opam_definition + variables: + package: tezos-baking-alpha-commands + +opam:43:tezos-client-alpha-commands: + <<: *opam_definition + variables: + package: tezos-client-alpha-commands + +opam:44:tezos-client-base-unix: + <<: *opam_definition + variables: + package: tezos-client-base-unix + +opam:45:tezos-client-genesis: + <<: *opam_definition + variables: + package: tezos-client-genesis + +opam:46:ocplib-ezresto: + <<: *opam_definition + variables: + package: ocplib-ezresto + +opam:47:tezos-embedded-protocol-alpha: <<: *opam_definition variables: package: tezos-embedded-protocol-alpha -opam:47:tezos-embedded-protocol-demo: +opam:48:tezos-embedded-protocol-demo: <<: *opam_definition variables: package: tezos-embedded-protocol-demo -opam:48:tezos-embedded-protocol-genesis: +opam:49:tezos-embedded-protocol-genesis: <<: *opam_definition variables: package: tezos-embedded-protocol-genesis -opam:49:tezos-shell: +opam:50:tezos-shell: <<: *opam_definition variables: package: tezos-shell -opam:50:tezos-endorser-alpha-commands: +opam:51:tezos-endorser-alpha-commands: <<: *opam_definition variables: package: tezos-endorser-alpha-commands -opam:51:tezos-client: +opam:52:tezos-client: <<: *opam_definition variables: package: tezos-client -opam:52:tezos-endorser-alpha: - <<: *opam_definition - variables: - package: tezos-endorser-alpha - -opam:53:tezos-accuser-alpha-commands: - <<: *opam_definition - variables: - package: tezos-accuser-alpha-commands - -opam:54:ocplib-ezresto-directory: +opam:53:ocplib-ezresto-directory: <<: *opam_definition variables: package: ocplib-ezresto-directory -opam:55:tezos-accuser-alpha: +opam:54:tezos-accuser-alpha: <<: *opam_definition variables: package: tezos-accuser-alpha -opam:56:tezos-baker-alpha: +opam:55:tezos-endorser-alpha: + <<: *opam_definition + variables: + package: tezos-endorser-alpha + +opam:56:tezos-accuser-alpha-commands: + <<: *opam_definition + variables: + package: tezos-accuser-alpha-commands + +opam:57:tezos-baker-alpha: <<: *opam_definition variables: package: tezos-baker-alpha -opam:57:tezos-protocol-demo: +opam:58:tezos-protocol-demo: <<: *opam_definition variables: package: tezos-protocol-demo -opam:58:tezos-signer: +opam:59:tezos-signer: <<: *opam_definition variables: package: tezos-signer -opam:59:ledgerwallet-tezos: - <<: *opam_definition - variables: - package: ledgerwallet-tezos - opam:60:tezos-node: <<: *opam_definition variables: package: tezos-node -opam:59:ocplib-json-typed-browser: +opam:61:ocplib-json-typed-browser: <<: *opam_definition variables: package: ocplib-json-typed-browser -opam:60:tezos-baker-alpha-commands: +opam:62:tezos-baker-alpha-commands: <<: *opam_definition variables: package: tezos-baker-alpha-commands + +opam:63:tezos-bench: + <<: *opam_definition + variables: + package: tezos-bench + + ##END_OPAM## diff --git a/src/lib_shell/bench/bench_simple.ml b/src/lib_shell/bench/bench_simple.ml new file mode 100644 index 000000000..0c1f70880 --- /dev/null +++ b/src/lib_shell/bench/bench_simple.ml @@ -0,0 +1,72 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +let make_simple blocks = + let rec loop pred n = + if n <= 0 then + return pred + else + Block.bake pred >>=? fun block -> + loop block (n - 1) in + Context.init 5 >>=? fun (genesis, _) -> + loop genesis blocks + +type args = { + blocks : int ; + accounts : int ; +} + +let default_args = { + blocks = 1000 ; + accounts = 5 ; +} + +let set_blocks cf blocks = + cf := { !cf with blocks } + +let set_accounts cf accounts = + cf := { !cf with accounts } + +let read_args () = + let args = ref default_args in + let specific = + [ + ("--blocks", Arg.Int (set_blocks args), "number of blocks"); + ("--accounts", Arg.Int (set_accounts args), "number of acount"); + ] + in + let usage = "Usage: [--blocks n] [--accounts n] " in + Arg.parse specific (fun _ -> ()) usage ; + !args + +let () = + let args = read_args () in + match Lwt_main.run (make_simple args.blocks) with + | Ok _head -> + Format.printf "Success.@." ; + exit 0 + | Error err -> + Format.eprintf "%a@." pp_print_error err ; + exit 1 diff --git a/src/lib_shell/bench/bench_tool.ml b/src/lib_shell/bench/bench_tool.ml new file mode 100644 index 000000000..c17367bfc --- /dev/null +++ b/src/lib_shell/bench/bench_tool.ml @@ -0,0 +1,369 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +module Helpers_Nonce = Nonce +open Proto_alpha +open Parameters_repr +open Constants_repr +open Alpha_context + +(** Args *) + +type args = { + mutable length : int ; + mutable seed : int ; + mutable accounts : int ; + mutable nb_commitments : int ; + mutable params : Parameters_repr.t; +} + +let default_args = { + length = 100 ; + seed = 0; + accounts = 100 ; + nb_commitments = 200 ; + params = { bootstrap_accounts = [] ; + commitments = [] ; + bootstrap_contracts = [] ; + constants = default ; + security_deposit_ramp_up_cycles = None ; + no_reward_cycles = None ; + } +} + +let debug = ref false + +let if_debug k = + if !debug then k () + +let if_debug_s k = + if !debug then k () else return () + +let args = default_args + +let parse_param_file name = + if not (Sys.file_exists name) then + failwith "Parameters : Inexistent JSON file" + else begin + Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file name >>=? fun json -> + match Data_encoding.Json.destruct Parameters_repr.encoding json with + | exception exn -> + failwith "Parameters : Invalid JSON file - %a" Error_monad.pp_exn exn + | param -> return param + end + +let read_args () = + let parse_param name = + parse_param_file name >>= begin function + | Ok p -> Lwt.return p + | Error errs -> + Format.printf "Parameters parsing error : %a ==> using \ + default parameters\n%!" Error_monad.pp_print_error errs ; + Lwt.return default_args.params end |> Lwt_main.run + in + + let specific = + [ + ("--length", Arg.Int (fun n -> args.length <- n), "Length of the chain (nb of blocks)") ; + ("--seed", Arg.Int (fun n -> args.seed <- n), "Used seed (default 0)") ; + ("--random-commitments", Arg.Int (fun n -> args.nb_commitments <- n), + "Number of randomly generated commitments. Defaults to 200. If \ + less than 0, commitments in protocol parameter files are used.") ; + ("--accounts", Arg.Int (fun n -> args.accounts <- n), + "Number of initial randomly generated accounts. Still adds \ + bootstrap account if present in the parameters file.") ; + ("--parameters", Arg.String (fun s -> args.params <- parse_param s), "JSON protocol parameters file") ; + + ("--debug", Arg.Set debug, "Print more info") ; + ] + in + let usage = "Usage: [--length n] [--seed n] [--accounts n] [--parameters json_file]" in + Arg.parse specific (fun _ -> ()) usage + +(** Utils *) + +let choose_exp_nat n = + (* seems fine *) + let lambda = 1. /. (log (float n)) in + let u = Random.float 1. in + (-. (log u)) /. lambda |> int_of_float + +let pi = 3.1415926502 +let two_pi = 2. *. 3.1415926502 +let round x = x +. 0.5 |> int_of_float + +let rec choose_gaussian_nat (a, b) = + assert (b >= a); + let sigma = 4. in + let mu = ((b - a) / 2 + a) |> float in + let gauss () = + let u1 = Random.float 1. (* |> fun x -> 1. -. x *) in + let u2 = Random.float 1. in + let r = sqrt (-. (2. *. log u1)) in + let theta = cos (two_pi *. u2) in + r *. theta + in + let z = gauss () in + let z = z *. sigma +. mu |> round in + if z > a && z < b then z else choose_gaussian_nat (a, b) + +let list_shuffle l = + List.map (fun c -> (Random.bits (), c)) l |> + List.sort compare |> List.map snd + +(******************************************************************) + +type gen_state = { mutable possible_transfers : (Account.t * Account.t) list ; + mutable remaining_transfers : (Account.t * Account.t) list ; + mutable remaining_activations : (Account.t * Commitment_repr.t) list; + mutable nonce_to_reveal : (Cycle.t * Raw_level.t * Nonce.t) list ; + } + +let generate_random_endorsement ctxt n = + let slot = n in + Context.get_endorser ctxt slot >>=? fun delegate -> + Op.endorsement ~delegate ctxt [ slot ] + +let generate_and_add_random_endorsements inc = + let pred inc = Incremental.predecessor inc in + let nb_endorsements = + let n = args.params.constants.endorsers_per_block in + n - (choose_exp_nat n) + in + if_debug begin fun () -> + Format.printf "[DEBUG] Generating up to %d endorsements...\n%!" nb_endorsements end; + + map_s (generate_random_endorsement (B (pred inc))) (0-- (nb_endorsements -1)) >>=? fun endorsements -> + + let compare op1 op2 = + Operation_hash.compare (Operation.hash op1) (Operation.hash op2) + in + + let endorsements = List.sort_uniq compare endorsements in + let endorsements = List.map Operation.pack endorsements in + fold_left_s Incremental.add_operation inc endorsements + +let regenerate_transfers = ref false +let generate_random_activation ({ remaining_activations ; } as gen_state) inc = + regenerate_transfers := true ; + let open Account in + match remaining_activations with + | [] -> assert false + | (({ pkh ; _ } as account), _)::l -> + if_debug begin fun () -> + Format.printf "[DEBUG] Generating an activation.\n%!" end; + gen_state.remaining_activations <- l ; + add_account account; + Op.activation inc pkh Account.commitment_secret + +exception No_transfer_left +let rec generate_random_transfer ({ remaining_transfers ; } as gen_state) ctxt = + if remaining_transfers = [] then raise No_transfer_left; + let (a1, a2) = List.hd remaining_transfers in + gen_state.remaining_transfers <- List.tl remaining_transfers; + let open Account in + let c1 = Alpha_context.Contract.implicit_contract a1.pkh in + let c2 = Alpha_context.Contract.implicit_contract a2.pkh in + Context.Contract.balance ctxt c1 >>=? fun b1 -> + if Tez.(b1 < Tez.one) then + generate_random_transfer gen_state ctxt + else + Op.transaction ctxt c1 c2 Tez.one + + +let generate_random_operation (inc : Incremental.t) gen_state = + let rnd = Random.int 100 in + match rnd with + | x when x < 2 && gen_state.remaining_activations <> [] -> + generate_random_activation gen_state (I inc) + | _ -> generate_random_transfer gen_state (I inc) + +(* Build a random block *) +let step gen_state blk : Block.t tzresult Lwt.t = + let priority = choose_exp_nat 5 in + (* let nb_operations_per_block = choose_gaussian_nat (10, List.length (Account.get_known_accounts ())) in *) + let nb_operations_per_block = choose_gaussian_nat (10, 100) in + + if !regenerate_transfers then begin + let l = Signature.Public_key_hash.Table.fold + (fun _ v acc -> v::acc ) Account.known_accounts [] in + (* TODO : make possible transfer computations efficient.. *) + gen_state.possible_transfers <- List.product l l |> List.filter (fun (a,b) -> a <> b); + regenerate_transfers := false + end; + gen_state.remaining_transfers <- list_shuffle gen_state.possible_transfers ; + + let nb_operations = + min nb_operations_per_block (List.length gen_state.remaining_transfers) + in + (* Nonce *) + begin Alpha_services.Helpers.current_level ~offset:1l (Block.rpc_ctxt) blk >>|? function + | Level.{ expected_commitment = true ; cycle ; level } -> + if_debug begin fun () -> Format.printf "[DEBUG] Commiting a nonce\n%!" end; + begin + let (hash, nonce) = + Helpers_Nonce.generate () in + gen_state.nonce_to_reveal <- (cycle, level, nonce) :: gen_state.nonce_to_reveal; + Some hash + end + | _ -> None + end >>=? fun seed_nonce_hash -> + + Incremental.begin_construction ~priority ?seed_nonce_hash blk >>=? fun inc -> + let open Cycle in + + if_debug begin fun () -> Format.printf "[DEBUG] Generating %d random operations...\n%!" nb_operations end; + + (* Generate random operations *) + fold_left_s + (fun inc _ -> + try + generate_random_operation inc gen_state >>=? fun op -> + Incremental.add_operation inc op + with No_transfer_left -> return inc + ) + inc (1 -- nb_operations) >>=? fun inc -> + + (* Endorsements *) + generate_and_add_random_endorsements inc >>=? fun inc -> + + (* Revelations *) + (* TODO debug cycle *) + begin Alpha_services.Helpers.current_level ~offset:1l Incremental.rpc_ctxt inc >>|? function { cycle ; level ; _ } -> + if_debug begin fun () -> Format.printf "[DEBUG] Current cycle : %a\n%!" Cycle.pp cycle end ; + if_debug begin fun () -> Format.printf "[DEBUG] Current level : %a\n%!" Raw_level.pp level end ; + begin match gen_state.nonce_to_reveal with + | ((pred_cycle, _, _)::_) as l when succ pred_cycle = cycle -> + if_debug begin fun () -> Format.printf "[DEBUG] Seed nonce revelation : %d nonces to reveal.\n%!" + @@ List.length l end; + gen_state.nonce_to_reveal <- [] ; + (* fold_left_s (fun inc (_, level, nonce) -> *) + (* Op.seed_nonce_revelation inc level nonce >>=? fun op -> + * Incremental.add_operation inc op *) + (* return *) inc (* TODO reactivate the seeds *) + (* ) inc l *) + | _ -> inc + end + end >>=? fun inc -> + (* (\* Shuffle the operations a bit (why not) *\) + * let operations = endorsements @ operations |> list_shuffle in *) + + Incremental.finalize_block inc + +let init () = + Random.init args.seed ; + let parameters = args.params in + + (* keys randomness is delegated to module Signature's bindings *) + (* TODO : distribute the tokens randomly *) + (* Right now, we split half of 80.000 rolls between generated accounts *) + (* TODO : ensure we don't overflow with the underlying commitments *) + Tez_repr.( + Lwt.return @@ Alpha_environment.wrap_error @@ + args.params.Parameters_repr.constants.Constants_repr.tokens_per_roll + *? 80_000L >>=? fun total_amount -> + Lwt.return @@ Alpha_environment.wrap_error @@ + total_amount /? 2L >>=? fun amount -> + Lwt.return @@ Alpha_environment.wrap_error @@ + amount /? (Int64.of_int args.accounts) ) >>=? fun initial_amount -> + + (* Ensure a deterministic run *) + let new_seed () : MBytes.t = + String.(make 32 '\000' |> map (fun _ -> Random.int 0x100 |> char_of_int)) |> + MBytes.of_string + in + + map_s + (fun _ -> return (Account.new_account ~seed:(new_seed ()) (), initial_amount)) + (1--args.accounts) >>=? fun initial_accounts -> + if_debug begin fun () -> + List.iter + (fun (Account.{pkh},_) -> Format.printf "[DEBUG] Account %a created\n%!" Signature.Public_key_hash.pp_short pkh ) + initial_accounts end; + + let possible_transfers = + let l = List.map fst initial_accounts in + List.product l l |> List.filter (fun (a,b) -> a <> b) + in + + begin match args.nb_commitments with + | x when x < 0 -> return ([], parameters) + | x -> + map_s + (fun _ -> Account.new_commitment ~seed:(new_seed ()) ()) (1 -- x) >>=? fun commitments -> + return (commitments, { parameters with commitments = List.map snd commitments }) + end >>=? fun (remaining_activations, { bootstrap_accounts=_ ; commitments ; + constants ; security_deposit_ramp_up_cycles ; + no_reward_cycles }) -> + let gen_state = { possible_transfers ; remaining_transfers = [] ; + nonce_to_reveal = [] ; remaining_activations } in + + Block.genesis_with_parameters constants + ~commitments + ~security_deposit_ramp_up_cycles + ~no_reward_cycles initial_accounts + >>=? fun genesis -> + + if_debug_s begin fun () -> + iter_s (let open Account in fun ({ pkh } as acc, _) -> + let contract = Alpha_context.Contract.implicit_contract acc.pkh in + Context.Contract.manager (B genesis) contract >>=? fun { pkh = pkh' } -> + Context.Contract.balance (B genesis) contract >>=? fun balance -> + return @@ Format.printf "[DEBUG] %a's manager is %a with a balance of %a\n%!" + Signature.Public_key_hash.pp_short pkh + Signature.Public_key_hash.pp_short pkh' + Tez.pp balance + ) initial_accounts end >>=? fun () -> + + if_debug begin fun () -> + Format.printf "[DEBUG] Constants : %a\n%!" + Data_encoding.Json.pp + (Data_encoding.Json.construct + Constants_repr.parametric_encoding parameters.Parameters_repr.constants) + end; + + Format.printf "@[Starting generation with :@ \ + @[length = %d@]@ \ + @[seed = %d@]@ \ + @[nb_commi. = %d@]@ \ + @[#accounts = %d@]@ @]@." args.length args.seed args.nb_commitments args.accounts; + let rec loop gen_state blk = function + | 0 -> return (gen_state, blk) + | n -> begin + Block.print_block blk; + step gen_state blk >>=? fun blk' -> + loop gen_state blk' (n-1) + end + in + return (loop gen_state genesis args.length) + +let () = + Lwt_main.run (read_args (); init ()) |> function + | Ok _head -> + Format.printf "Success.@." ; + exit 0 + | Error err -> + Format.eprintf "%a@." pp_print_error err ; + exit 1 diff --git a/src/lib_shell/bench/helpers/account.ml b/src/lib_shell/bench/helpers/account.ml new file mode 100644 index 000000000..6acb5e5ba --- /dev/null +++ b/src/lib_shell/bench/helpers/account.ml @@ -0,0 +1,89 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Proto_alpha + +type t = { + pkh : Signature.Public_key_hash.t ; + pk : Signature.Public_key.t ; + sk : Signature.Secret_key.t ; +} +type account = t + +let commitment_secret = + Proto_alpha.Blinded_public_key_hash.activation_code_of_hex + "aaaaaaaaaaaaaaaaaaaabbbbbbbbbbbbbbbbbbbb" + +let known_accounts = Signature.Public_key_hash.Table.create 17 + +let new_account ?seed () = + let (pkh, pk, sk) = Signature.generate_key ?seed ~algo:Ed25519 () in + let account = { pkh ; pk ; sk } in + Signature.Public_key_hash.Table.add known_accounts pkh account ; + account + +let add_account ({ pkh ; _ } as account) = + Signature.Public_key_hash.Table.add known_accounts pkh account + +let dictator_account = new_account () + +let find pkh = + try return (Signature.Public_key_hash.Table.find known_accounts pkh) + with Not_found -> + failwith "Missing account: %a" Signature.Public_key_hash.pp pkh + +let find_alternate pkh = + let exception Found of t in + try + Signature.Public_key_hash.Table.iter + (fun pkh' account -> + if not (Signature.Public_key_hash.equal pkh pkh') then + raise (Found account)) + known_accounts ; + raise Not_found + with Found account -> account + +let dummy_account = new_account () + +let new_commitment ?seed () = + let (pkh, pk, sk) = Signature.generate_key ?seed ~algo:Ed25519 () in + let unactivated_account = { pkh; pk; sk } in + let open Proto_alpha in + let open Commitment_repr in + let pkh = match pkh with Ed25519 pkh -> pkh | _ -> assert false in + let bpkh = Blinded_public_key_hash.of_ed25519_pkh commitment_secret pkh in + Lwt.return @@ Alpha_environment.wrap_error @@ + Tez_repr.(one *? 4_000L) >>=? fun amount -> + return @@ (unactivated_account, { blinded_public_key_hash = bpkh ; amount }) + +let generate_accounts n : (t * Tez_repr.t) list = + Signature.Public_key_hash.Table.clear known_accounts ; + let amount = Tez_repr.of_mutez_exn 4_000_000_000_000L in + List.map (fun _ -> + let (pkh, pk, sk) = Signature.generate_key () in + let account = { pkh ; pk ; sk } in + Signature.Public_key_hash.Table.add known_accounts pkh account ; + account, amount) + (0--(n-1)) diff --git a/src/lib_shell/bench/helpers/account.mli b/src/lib_shell/bench/helpers/account.mli new file mode 100644 index 000000000..0e8801147 --- /dev/null +++ b/src/lib_shell/bench/helpers/account.mli @@ -0,0 +1,54 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Proto_alpha + +type t = { + pkh : Signature.Public_key_hash.t ; + pk : Signature.Public_key.t ; + sk : Signature.Secret_key.t ; +} +type account = t + +val commitment_secret : Blinded_public_key_hash.activation_code + +val dictator_account: account +val dummy_account: account + +val new_account: ?seed : MBytes.t -> unit -> account + +val new_commitment : ?seed:MBytes.t -> unit -> + (account * Commitment_repr.t) tzresult Lwt.t + +val add_account : t -> unit + +val known_accounts : t Signature.Public_key_hash.Table.t + +val find: Signature.Public_key_hash.t -> t tzresult Lwt.t +val find_alternate: Signature.Public_key_hash.t -> t + +(** [generate_accounts n] : generates [n] random accounts with + 4.000.000.000 tz and add them to the global account state *) +val generate_accounts : int -> (t * Tez_repr.t) list diff --git a/src/lib_shell/bench/helpers/assert.ml b/src/lib_shell/bench/helpers/assert.ml new file mode 100644 index 000000000..1f26f7dba --- /dev/null +++ b/src/lib_shell/bench/helpers/assert.ml @@ -0,0 +1,113 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Proto_alpha + +let error ~loc v f = + match v with + | Error err when List.exists f err -> + return () + | Ok _ -> + failwith "Unexpected successful result (%s)" loc + | Error err -> + failwith "@[Unexpected error (%s): %a@]" loc pp_print_error err + +let proto_error ~loc v f = + error ~loc v + (function + | Alpha_environment.Ecoproto_error err -> f err + | _ -> false) + +let equal ~loc (cmp : 'a -> 'a -> bool) msg pp a b = + if not (cmp a b) then + failwith "@[@[[%s]@] - @[%s : %a is not equal to %a@]@]" loc msg pp a pp b + else + return () + +let not_equal ~loc (cmp : 'a -> 'a -> bool) msg pp a b = + if cmp a b then + failwith "@[@[[%s]@] - @[%s : %a is equal to %a@]@]" loc msg pp a pp b + else + return () + +let equal_tez ~loc (a:Alpha_context.Tez.t) (b:Alpha_context.Tez.t) = + let open Alpha_context in + equal ~loc Tez.(=) "Tez aren't equal" Tez.pp a b + +let not_equal_tez ~loc (a:Alpha_context.Tez.t) (b:Alpha_context.Tez.t) = + let open Alpha_context in + not_equal ~loc Tez.(=) "Tez are equal" Tez.pp a b + +let equal_int ~loc (a:int) (b:int) = + equal ~loc (=) "Integers aren't equal" Format.pp_print_int a b + +let not_equal_int ~loc (a:int) (b:int) = + not_equal ~loc (=) "Integers are equal" Format.pp_print_int a b + +let equal_bool ~loc (a:bool) (b:bool) = + equal ~loc (=) "Booleans aren't equal" Format.pp_print_bool a b + +let not_equal_bool ~loc (a:bool) (b:bool) = + not_equal ~loc (=) "Booleans are equal" Format.pp_print_bool a b + + +open Context +(* Some asserts for account operations *) + +(** [balance_is b c amount] checks that the current balance of contract [c] is + [amount]. + Default balance type is [Main], pass [~kind] with [Deposit], [Fees] or + [Rewards] for the others. *) +let balance_is ~loc b contract ?(kind = Contract.Main) expected = + Contract.balance b contract ~kind >>=? fun balance -> + equal_tez ~loc balance expected + +(** [balance_was_operated ~operand b c old_balance amount] checks that the + current balance of contract [c] is [operand old_balance amount] and + returns the current balance. + Default balance type is [Main], pass [~kind] with [Deposit], [Fees] or + [Rewards] for the others. *) +let balance_was_operated ~(operand) ~loc b contract ?(kind = Contract.Main) old_balance amount = + operand old_balance amount |> + Alpha_environment.wrap_error |> Lwt.return >>=? fun expected -> + balance_is ~loc b contract ~kind expected + +let balance_was_credited = balance_was_operated ~operand:Alpha_context.Tez.(+?) + +let balance_was_debited = balance_was_operated ~operand:Alpha_context.Tez.(-?) + + +(* debug *) + +let print_balances ctxt id = + Contract.balance ~kind:Main ctxt id >>=? fun main -> + Contract.balance ~kind:Deposit ctxt id >>=? fun deposit -> + Contract.balance ~kind:Fees ctxt id >>=? fun fees -> + Contract.balance ~kind:Rewards ctxt id >>|? fun rewards -> + Format.printf "\nMain: %s\nDeposit: %s\nFees: %s\nRewards: %s\n" + (Alpha_context.Tez.to_string main) + (Alpha_context.Tez.to_string deposit) + (Alpha_context.Tez.to_string fees) + (Alpha_context.Tez.to_string rewards) diff --git a/src/lib_shell/bench/helpers/block.ml b/src/lib_shell/bench/helpers/block.ml new file mode 100644 index 000000000..f176a2778 --- /dev/null +++ b/src/lib_shell/bench/helpers/block.ml @@ -0,0 +1,411 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Proto_alpha +module Proto_Nonce = Nonce (* Renamed otherwise is masked by Alpha_context *) +open Alpha_context + +(* This type collects a block and the context that results from its application *) +type t = { + hash : Block_hash.t ; + header : Block_header.t ; + operations : Operation.packed list ; + context : Tezos_protocol_environment_memory.Context.t ; +} +type block = t + +let rpc_context block = { + Alpha_environment.Updater.block_hash = block.hash ; + block_header = block.header.shell ; + context = block.context ; +} + +let rpc_ctxt = + new Alpha_environment.proto_rpc_context_of_directory + rpc_context Proto_alpha.rpc_services + +(******** Policies ***********) + +(* Policies are functions that take a block and return a tuple + [(account, level, timestamp)] for the [forge_header] function. *) + +(* This type is used only to provide a simpler interface to the exterior. *) +type baker_policy = + | By_priority of int + | By_account of public_key_hash + | Excluding of public_key_hash list + +let get_next_baker_by_priority priority block = + Alpha_services.Delegate.Baking_rights.get rpc_ctxt + ~all:true + ~max_priority:(priority+1) block >>=? fun bakers -> + let { Alpha_services.Delegate.Baking_rights.delegate = pkh ; + timestamp} = List.find (fun { Alpha_services.Delegate.Baking_rights.priority = p } -> p = priority) bakers in + return (pkh, priority, Option.unopt_exn (Failure "") timestamp) + +let get_next_baker_by_account pkh block = + Alpha_services.Delegate.Baking_rights.get rpc_ctxt + ~delegates:[pkh] + ~max_priority:256 block >>=? fun bakers -> + let { Alpha_services.Delegate.Baking_rights.delegate = pkh ; + timestamp ; priority } = List.hd bakers in + return (pkh, priority, Option.unopt_exn (Failure "") timestamp) + +let get_next_baker_excluding excludes block = + Alpha_services.Delegate.Baking_rights.get rpc_ctxt + ~max_priority:256 block >>=? fun bakers -> + let { Alpha_services.Delegate.Baking_rights.delegate = pkh ; + timestamp ; priority } = + List.find + (fun { Alpha_services.Delegate.Baking_rights.delegate } -> + not (List.mem delegate excludes)) + bakers in + return (pkh, priority, Option.unopt_exn (Failure "") timestamp) + +let dispatch_policy = function + | By_priority p -> get_next_baker_by_priority p + | By_account a -> get_next_baker_by_account a + | Excluding al -> get_next_baker_excluding al + +let get_next_baker ?(policy = By_priority 0) = dispatch_policy policy + +module Forge = struct + + type header = { + baker : public_key_hash ; (* the signer of the block *) + shell : Block_header.shell_header ; + contents : Block_header.contents ; + } + + let default_proof_of_work_nonce = + MBytes.create Constants.proof_of_work_nonce_size + + let make_contents + ?(proof_of_work_nonce = default_proof_of_work_nonce) + ~priority ~seed_nonce_hash () = + Block_header.{ priority ; + proof_of_work_nonce ; + seed_nonce_hash } + + let make_shell + ~level ~predecessor ~timestamp ~fitness ~operations_hash = + Tezos_base.Block_header.{ + level ; + predecessor ; + timestamp ; + fitness ; + operations_hash ; + (* We don't care of the following values, only the shell validates them. *) + proto_level = 0 ; + validation_passes = 0 ; + context = Context_hash.zero ; + } + + let set_seed_nonce_hash seed_nonce_hash { baker ; shell ; contents } = + { baker ; shell ; contents = { contents with seed_nonce_hash } } + + let set_baker baker header = { header with baker } + + let sign_header { baker ; shell ; contents } = + Account.find baker >>=? fun delegate -> + let unsigned_bytes = + Data_encoding.Binary.to_bytes_exn + Block_header.unsigned_encoding + (shell, contents) in + let signature = + Signature.sign + ~watermark:(Signature.Block_header Chain_id.zero) + delegate.sk unsigned_bytes in + Block_header.{ shell ; protocol_data = { contents ; signature } } |> + return + + let forge_header + ?(policy = By_priority 0) + ?(operations = []) pred = + dispatch_policy policy pred >>=? fun (pkh, priority, timestamp) -> + let level = Int32.succ pred.header.shell.level in + begin + match Fitness_repr.to_int64 pred.header.shell.fitness with + | Ok old_fitness -> + return (Fitness_repr.from_int64 + (Int64.add (Int64.of_int 1) old_fitness)) + | Error _ -> assert false + end >>=? fun fitness -> + begin + Alpha_services.Helpers.current_level ~offset:1l (rpc_ctxt) pred >>|? function + | { expected_commitment = true } -> Some (fst (Proto_Nonce.generate ())) + | { expected_commitment = false } -> None + end >>=? fun seed_nonce_hash -> + let hashes = List.map Operation.hash_packed operations in + let operations_hash = Operation_list_list_hash.compute + [Operation_list_hash.compute hashes] in + let shell = make_shell ~level ~predecessor:pred.hash + ~timestamp ~fitness ~operations_hash in + let contents = make_contents ~priority ~seed_nonce_hash () in + return { baker = pkh ; shell ; contents } + + (* compatibility only, needed by incremental *) + let contents + ?(proof_of_work_nonce = default_proof_of_work_nonce) + ?(priority = 0) ?seed_nonce_hash () = + { Block_header.priority ; + proof_of_work_nonce ; + seed_nonce_hash ; + } + +end + +(********* Genesis creation *************) + +(* Hard-coded context key *) +let protocol_param_key = [ "protocol_parameters" ] + +let check_constants_consistency constants = + let open Constants_repr in + let { blocks_per_cycle ; blocks_per_commitment ; + blocks_per_roll_snapshot ; _ } = constants in + Error_monad.unless (blocks_per_commitment <= blocks_per_cycle) + (fun () -> failwith "Inconsistent constants : blocks per commitment must be \ + less than blocks per cycle") >>=? fun () -> + Error_monad.unless (blocks_per_cycle >= blocks_per_roll_snapshot) + (fun () -> failwith "Inconsistent constants : blocks per cycle \ + must be superior than blocks per roll snapshot") >>=? + return + +let initial_context + constants + header + commitments + initial_accounts + security_deposit_ramp_up_cycles + no_reward_cycles + = + let bootstrap_accounts = + List.map (fun (Account.{ pk = public_key ; pkh = public_key_hash }, amount) -> + Parameters_repr.{ public_key = Some public_key ; public_key_hash ; amount } + ) initial_accounts + in + let json = + Data_encoding.Json.construct + Parameters_repr.encoding + Parameters_repr.{ + bootstrap_accounts ; + bootstrap_contracts = [] ; + commitments ; + constants ; + security_deposit_ramp_up_cycles ; + no_reward_cycles ; + } + in + let proto_params = + Data_encoding.Binary.to_bytes_exn Data_encoding.json json + in + Tezos_protocol_environment_memory.Context.( + set empty protocol_param_key proto_params + ) >>= fun ctxt -> + Main.init ctxt header + >|= Alpha_environment.wrap_error >>=? fun { context; _ } -> + return context + +let genesis_with_parameters + constants + ?(commitments = []) + ?(security_deposit_ramp_up_cycles = None) + ?(no_reward_cycles = None) + (initial_accounts : (Account.t * Tez_repr.t) list) + = + if initial_accounts = [] then + Pervasives.failwith "Must have one account with a roll to bake"; + + (* Check there is at least one roll *) + begin try + let open Test_utils in + fold_left_s (fun acc (_, amount) -> + Alpha_environment.wrap_error @@ + Tez_repr.(+?) acc amount >>?= fun acc -> + if acc >= constants.Constants_repr.tokens_per_roll then + raise Exit + else return acc + ) Tez_repr.zero initial_accounts >>=? fun _ -> + failwith "Insufficient tokens in initial accounts to create one roll" + with Exit -> return () + end >>=? fun () -> + check_constants_consistency constants >>=? fun () -> + let hash = + Block_hash.of_b58check_exn "BLockGenesisGenesisGenesisGenesisGenesisCCCCCeZiLHU" + in + let shell = Forge.make_shell + ~level:0l + ~predecessor:hash + ~timestamp:Time.epoch + ~fitness: (Fitness_repr.from_int64 0L) + ~operations_hash: Operation_list_list_hash.zero in + let contents = Forge.make_contents + ~priority:0 + ~seed_nonce_hash:None () in + initial_context + constants + shell + commitments + initial_accounts + security_deposit_ramp_up_cycles + no_reward_cycles + >>=? fun context -> + let block = + { hash ; + header = { + shell = shell ; + protocol_data = { + contents = contents ; + signature = Signature.zero ; + } ; + }; + operations = [] ; + context ; + } + in + return block + +let genesis + ?(preserved_cycles = Constants_repr.default.preserved_cycles) + ?(blocks_per_cycle = Constants_repr.default.blocks_per_cycle) + ?(blocks_per_commitment = Constants_repr.default.blocks_per_commitment) + ?(blocks_per_roll_snapshot = Constants_repr.default.blocks_per_roll_snapshot) + ?(blocks_per_voting_period = Constants_repr.default.blocks_per_voting_period) + ?(time_between_blocks = Constants_repr.default.time_between_blocks) + ?(endorsers_per_block = Constants_repr.default.endorsers_per_block) + ?(hard_gas_limit_per_operation = Constants_repr.default.hard_gas_limit_per_operation) + ?(hard_gas_limit_per_block = Constants_repr.default.hard_gas_limit_per_block) + ?(proof_of_work_threshold = Int64.(neg one)) + ?(tokens_per_roll = Constants_repr.default.tokens_per_roll) + ?(michelson_maximum_type_size = Constants_repr.default.michelson_maximum_type_size) + ?(seed_nonce_revelation_tip = Constants_repr.default.seed_nonce_revelation_tip) + ?(origination_burn = Constants_repr.default.origination_burn) + ?(block_security_deposit = Constants_repr.default.block_security_deposit) + ?(endorsement_security_deposit = Constants_repr.default.endorsement_security_deposit) + ?(block_reward = Constants_repr.default.block_reward) + ?(endorsement_reward = Constants_repr.default.endorsement_reward) + ?(cost_per_byte = Constants_repr.default.cost_per_byte) + ?(hard_storage_limit_per_operation = Constants_repr.default.hard_storage_limit_per_operation) + (initial_accounts : (Account.t * Tez_repr.t) list) = + let constants : Constants_repr.parametric = { + preserved_cycles ; + blocks_per_cycle ; + blocks_per_commitment ; + blocks_per_roll_snapshot ; + blocks_per_voting_period ; + time_between_blocks ; + endorsers_per_block ; + hard_gas_limit_per_operation ; + hard_gas_limit_per_block ; + proof_of_work_threshold ; + tokens_per_roll ; + michelson_maximum_type_size ; + seed_nonce_revelation_tip ; + origination_burn ; + block_security_deposit ; + endorsement_security_deposit ; + block_reward ; + endorsement_reward ; + cost_per_byte ; + hard_storage_limit_per_operation ; + } in + genesis_with_parameters constants initial_accounts + +(********* Baking *************) + +let apply header ?(operations = []) pred = + begin + let open Alpha_environment.Error_monad in + Proto_alpha.Main.begin_application + ~chain_id:Chain_id.zero + ~predecessor_context: pred.context + ~predecessor_fitness: pred.header.shell.fitness + ~predecessor_timestamp: pred.header.shell.timestamp + header >>=? fun vstate -> + fold_left_s + (fun vstate op -> + Proto_alpha.apply_operation vstate op >>=? fun (state, _result) -> + return state) + vstate operations >>=? fun vstate -> + Proto_alpha.Main.finalize_block vstate >>=? fun (validation, _result) -> + return validation.context + end >|= Alpha_environment.wrap_error >>|? fun context -> + let hash = Block_header.hash header in + { hash ; header ; operations ; context } + +let bake ?policy ?operation ?operations pred = + let operations = + match operation,operations with + | Some op, Some ops -> Some (op::ops) + | Some op, None -> Some [op] + | None, Some ops -> Some ops + | None, None -> None + in + Forge.forge_header ?policy ?operations pred >>=? fun header -> + Forge.sign_header header >>=? fun header -> + apply header ?operations pred + +(* This function is duplicated from Context to avoid a cyclic dependency *) +let get_constants b = + Alpha_services.Constants.all rpc_ctxt b + +(********** Cycles ****************) + +let bake_n ?policy n b = + Error_monad.fold_left_s + (fun b _ -> bake ?policy b) b (1 -- n) + +let bake_until_cycle_end ?policy b = + get_constants b >>=? fun Constants.{ parametric = { blocks_per_cycle } } -> + let current_level = b.header.shell.level in + let current_level = Int32.rem current_level blocks_per_cycle in + let delta = Int32.sub blocks_per_cycle current_level in + bake_n ?policy (Int32.to_int delta) b + +let bake_until_n_cycle_end ?policy n b = + Error_monad.fold_left_s + (fun b _ -> bake_until_cycle_end ?policy b) b (1 -- n) + +let bake_until_cycle ?policy cycle (b:t) = + get_constants b >>=? fun Constants.{ parametric = { blocks_per_cycle } } -> + let rec loop (b:t) = + let current_cycle = + let current_level = b.header.shell.level in + let current_cycle = Int32.div current_level blocks_per_cycle in + current_cycle + in + if Int32.equal (Cycle.to_int32 cycle) current_cycle then + return b + else + bake_until_cycle_end ?policy b >>=? fun b -> + loop b + in + loop b + +let print_block block = + Format.printf "@[%6i %s@]\n%!" + (Int32.to_int (block.header.shell.level)) + (Block_hash.to_b58check (block.hash)) diff --git a/src/lib_shell/bench/helpers/block.mli b/src/lib_shell/bench/helpers/block.mli new file mode 100644 index 000000000..987d843ea --- /dev/null +++ b/src/lib_shell/bench/helpers/block.mli @@ -0,0 +1,156 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Proto_alpha +open Alpha_context + +type t = { + hash : Block_hash.t ; + header : Block_header.t ; + operations : Operation.packed list ; + context : Tezos_protocol_environment_memory.Context.t ; (** Resulting context *) +} +type block = t + +val rpc_ctxt: t Alpha_environment.RPC_context.simple + +(** Policies to select the next baker: + - [By_priority p] selects the baker at priority [p] + - [By_account pkh] selects the first slot for baker [pkh] + - [Excluding pkhs] selects the first baker that doesn't belong to [pkhs] +*) +type baker_policy = + | By_priority of int + | By_account of public_key_hash + | Excluding of public_key_hash list + +(** Returns (account, priority, timestamp) of the next baker given + a policy, defaults to By_priority 0. *) +val get_next_baker: + ?policy:baker_policy -> + t -> (public_key_hash * int * Time.t) tzresult Lwt.t + +module Forge : sig + + val contents: + ?proof_of_work_nonce:MBytes.t -> + ?priority:int -> + ?seed_nonce_hash: Nonce_hash.t -> + unit -> Block_header.contents + + type header + + (** Forges a correct header following the policy. + The header can then be modified and applied with [apply]. *) + val forge_header: + ?policy:baker_policy -> + ?operations: Operation.packed list -> + t -> header tzresult Lwt.t + + (** Sets uniquely seed_nonce_hash of a header *) + val set_seed_nonce_hash: + Nonce_hash.t option -> header -> header + + (** Sets the baker that will sign the header to an arbitrary pkh *) + val set_baker: + public_key_hash -> header -> header + + (** Signs the header with the key of the baker configured in the header. + The header can no longer be modified, only applied. *) + val sign_header: + header -> + Block_header.block_header tzresult Lwt.t + +end + +val genesis_with_parameters : + Constants_repr.parametric -> + ?commitments: Commitment_repr.t list -> + ?security_deposit_ramp_up_cycles:int option -> + ?no_reward_cycles:int option -> + (Account.t * Proto_alpha.Tez_repr.t) list -> block tzresult Lwt.t + +(** [genesis accounts] : generates an initial block with the + given constants [] and initializes [accounts] with their + associated amounts. +*) +val genesis: + ?preserved_cycles:int -> + ?blocks_per_cycle:int32 -> + ?blocks_per_commitment:int32 -> + ?blocks_per_roll_snapshot:int32 -> + ?blocks_per_voting_period:int32 -> + ?time_between_blocks:Period_repr.t list -> + ?endorsers_per_block:int -> + ?hard_gas_limit_per_operation:Z.t -> + ?hard_gas_limit_per_block:Z.t -> + ?proof_of_work_threshold:int64 -> + ?tokens_per_roll:Tez_repr.tez -> + ?michelson_maximum_type_size:int -> + ?seed_nonce_revelation_tip:Tez_repr.tez -> + ?origination_burn:Tez_repr.tez -> + ?block_security_deposit:Tez_repr.tez -> + ?endorsement_security_deposit:Tez_repr.tez -> + ?block_reward:Tez_repr.tez -> + ?endorsement_reward:Tez_repr.tez -> + ?cost_per_byte: Tez_repr.t -> + ?hard_storage_limit_per_operation: Z.t -> + (Account.t * Tez_repr.tez) list -> block tzresult Lwt.t + +(** Applies a signed header and its operations to a block and + obtains a new block *) +val apply: + Block_header.block_header -> + ?operations: Operation.packed list -> + t -> t tzresult Lwt.t + +(** + [bake b] returns a block [b'] which has as predecessor block [b]. + Optional parameter [policy] allows to pick the next baker in several ways. + This function bundles together [forge_header], [sign_header] and [apply]. + These functions should be used instead of bake to craft unusual blocks for + testing together with setters for properties of the headers. + For examples see seed.ml or double_baking.ml +*) +val bake: + ?policy: baker_policy -> + ?operation: Operation.packed -> + ?operations: Operation.packed list -> + t -> t tzresult Lwt.t + +(** Bakes [n] blocks. *) +val bake_n : ?policy:baker_policy -> int -> t -> block tzresult Lwt.t + +(** Given a block [b] at level [l] bakes enough blocks to complete a cycle, + that is [blocks_per_cycle - (l % blocks_per_cycle)]. *) +val bake_until_cycle_end : ?policy:baker_policy -> t -> t tzresult Lwt.t + +(** Bakes enough blocks to end [n] cycles. *) +val bake_until_n_cycle_end : ?policy:baker_policy -> int -> t -> t tzresult Lwt.t + +(** Bakes enough blocks to reach the cycle. *) +val bake_until_cycle : ?policy:baker_policy -> Cycle.t -> t -> t tzresult Lwt.t + +val print_block: t -> unit diff --git a/src/lib_shell/bench/helpers/context.ml b/src/lib_shell/bench/helpers/context.ml new file mode 100644 index 000000000..0fc8dbac8 --- /dev/null +++ b/src/lib_shell/bench/helpers/context.ml @@ -0,0 +1,194 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Proto_alpha +open Alpha_context + +type t = + | B of Block.t + | I of Incremental.t + +let branch = function + | B b -> b.hash + | I i -> (Incremental.predecessor i).hash + +let level = function + | B b -> b.header.shell.level + | I i -> (Incremental.level i) + +let get_level ctxt = + level ctxt + |> Raw_level.of_int32 + |> Alpha_environment.wrap_error + |> Lwt.return + +let rpc_ctxt = object + method call_proto_service0 : + 'm 'q 'i 'o. + ([< RPC_service.meth ] as 'm, Alpha_environment.RPC_context.t, Alpha_environment.RPC_context.t, 'q, 'i, 'o) RPC_service.t -> + t -> 'q -> 'i -> 'o tzresult Lwt.t = + fun s pr q i -> + match pr with + | B b -> Block.rpc_ctxt#call_proto_service0 s b q i + | I b -> Incremental.rpc_ctxt#call_proto_service0 s b q i + method call_proto_service1 : + 'm 'a 'q 'i 'o. + ([< RPC_service.meth ] as 'm, Alpha_environment.RPC_context.t, Alpha_environment.RPC_context.t * 'a, 'q, 'i, 'o) RPC_service.t -> + t -> 'a -> 'q -> 'i -> 'o tzresult Lwt.t = + fun s pr a q i -> + match pr with + | B bl -> Block.rpc_ctxt#call_proto_service1 s bl a q i + | I bl -> Incremental.rpc_ctxt#call_proto_service1 s bl a q i + method call_proto_service2 : + 'm 'a 'b 'q 'i 'o. + ([< RPC_service.meth ] as 'm, Alpha_environment.RPC_context.t, (Alpha_environment.RPC_context.t * 'a) * 'b, 'q, 'i, 'o) RPC_service.t -> + t -> 'a -> 'b -> 'q -> 'i -> 'o tzresult Lwt.t = + fun s pr a b q i -> + match pr with + | B bl -> Block.rpc_ctxt#call_proto_service2 s bl a b q i + | I bl -> Incremental.rpc_ctxt#call_proto_service2 s bl a b q i + method call_proto_service3 : + 'm 'a 'b 'c 'q 'i 'o. + ([< RPC_service.meth ] as 'm, Alpha_environment.RPC_context.t, ((Alpha_environment.RPC_context.t * 'a) * 'b) * 'c, 'q, 'i, 'o) RPC_service.t -> + t -> 'a -> 'b -> 'c -> 'q -> 'i -> 'o tzresult Lwt.t = + fun s pr a b c q i -> + match pr with + | B bl -> Block.rpc_ctxt#call_proto_service3 s bl a b c q i + | I bl -> Incremental.rpc_ctxt#call_proto_service3 s bl a b c q i +end + +let get_endorsers ctxt = + Alpha_services.Delegate.Endorsing_rights.get rpc_ctxt ctxt + +let get_endorser ctxt slot = + Alpha_services.Delegate.Endorsing_rights.get + rpc_ctxt ctxt >>=? fun endorsers -> + try return (List.find (fun {Alpha_services.Delegate.Endorsing_rights.slots} -> List.mem slot slots) endorsers).delegate + with _ -> + failwith "Failed to lookup endorsers for ctxt %a, slot %d." + Block_hash.pp_short (branch ctxt) slot + +let get_bakers ctxt = + Alpha_services.Delegate.Baking_rights.get + ~max_priority:256 + rpc_ctxt ctxt >>=? fun bakers -> + return (List.map + (fun p -> p.Alpha_services.Delegate.Baking_rights.delegate) + bakers) + +let get_constants b = + Alpha_services.Constants.all rpc_ctxt b + +module Contract = struct + + let pkh c = Alpha_context.Contract.is_implicit c |> function + | Some p -> return p + | None -> failwith "pkh: only for implicit contracts" + + type balance_kind = Main | Deposit | Fees | Rewards + + let balance ?(kind = Main) ctxt contract = + begin match kind with + | Main -> + Alpha_services.Contract.balance rpc_ctxt ctxt contract + | _ -> + match Alpha_context.Contract.is_implicit contract with + | None -> + invalid_arg + "get_balance: no frozen accounts for an originated contract." + | Some pkh -> + Alpha_services.Delegate.frozen_balance_by_cycle + rpc_ctxt ctxt pkh >>=? fun map -> + Lwt.return @@ + Cycle.Map.fold + (fun _cycle { Delegate.deposit ; fees ; rewards } acc -> + acc >>?fun acc -> + match kind with + | Deposit -> Test_tez.Tez.(acc +? deposit) + | Fees -> Test_tez.Tez.(acc +? fees) + | Rewards -> Test_tez.Tez.(acc +? rewards) + | _ -> assert false) + map + (Ok Tez.zero) + end + + let counter ctxt contract = + Alpha_services.Contract.counter rpc_ctxt ctxt contract + + let manager ctxt contract = + Alpha_services.Contract.manager rpc_ctxt ctxt contract >>=? fun pkh -> + Account.find pkh + + let is_manager_key_revealed ctxt contract = + Alpha_services.Contract.manager_key rpc_ctxt ctxt contract >>=? fun (_, res) -> + return (res <> None) + + let delegate_opt ctxt contract = + Alpha_services.Contract.delegate_opt rpc_ctxt ctxt contract + +end + +module Delegate = struct + + type info = Delegate_services.info = { + balance: Tez.t ; + frozen_balance: Tez.t ; + frozen_balance_by_cycle: Delegate.frozen_balance Cycle.Map.t ; + staking_balance: Tez.t ; + delegated_contracts: Contract_hash.t list ; + delegated_balance: Tez.t ; + deactivated: bool ; + grace_period: Cycle.t ; + } + + let info ctxt pkh = + Alpha_services.Delegate.info rpc_ctxt ctxt pkh + +end + +let init + ?(slow=false) + ?preserved_cycles + ?endorsers_per_block + n = + let accounts = Account.generate_accounts n in + let contracts = List.map (fun (a, _) -> + Alpha_context.Contract.implicit_contract Account.(a.pkh)) accounts in + begin + if slow then + Block.genesis + ?preserved_cycles + ?endorsers_per_block + accounts + else + Block.genesis + ?preserved_cycles + ~blocks_per_cycle:32l + ~blocks_per_commitment:4l + ~blocks_per_roll_snapshot:8l + ?endorsers_per_block + accounts + end >>=? fun blk -> + return (blk, contracts) diff --git a/src/lib_shell/bench/helpers/context.mli b/src/lib_shell/bench/helpers/context.mli new file mode 100644 index 000000000..e16b2d3b5 --- /dev/null +++ b/src/lib_shell/bench/helpers/context.mli @@ -0,0 +1,88 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Proto_alpha +open Alpha_context + +type t = + | B of Block.t + | I of Incremental.t + +val branch: t -> Block_hash.t + +val get_level: t -> Raw_level.t tzresult Lwt.t + +val get_endorsers: t -> Alpha_services.Delegate.Endorsing_rights.t list tzresult Lwt.t + +val get_endorser: t -> int -> public_key_hash tzresult Lwt.t + +val get_bakers: t -> public_key_hash list tzresult Lwt.t + +(** Returns all the constants of the protocol *) +val get_constants: t -> Constants.t tzresult Lwt.t + +module Contract : sig + + val pkh: Contract.t -> public_key_hash tzresult Lwt.t + + type balance_kind = Main | Deposit | Fees | Rewards + + (** Returns the balance of a contract, by default the main balance. + If the contract is implicit the frozen balances are available too: + deposit, fees ot rewards. *) + val balance: ?kind:balance_kind -> t -> Contract.t -> Tez.t tzresult Lwt.t + + val counter: t -> Contract.t -> Z.t tzresult Lwt.t + val manager: t -> Contract.t -> Account.t tzresult Lwt.t + val is_manager_key_revealed: t -> Contract.t -> bool tzresult Lwt.t + + val delegate_opt: t -> Contract.t -> public_key_hash option tzresult Lwt.t + +end + +module Delegate : sig + + type info = Delegate_services.info = { + balance: Tez.t ; + frozen_balance: Tez.t ; + frozen_balance_by_cycle: Delegate.frozen_balance Cycle.Map.t ; + staking_balance: Tez.t ; + delegated_contracts: Contract_hash.t list ; + delegated_balance: Tez.t ; + deactivated: bool ; + grace_period: Cycle.t ; + } + + val info: t -> public_key_hash -> Delegate_services.info tzresult Lwt.t + +end + +(** [init n] : returns an initial block with [n] initialized accounts + and the associated implicit contracts *) +val init: + ?slow: bool -> + ?preserved_cycles:int -> + ?endorsers_per_block:int -> + int -> (Block.t * Alpha_context.Contract.t list) tzresult Lwt.t diff --git a/src/lib_shell/bench/helpers/incremental.ml b/src/lib_shell/bench/helpers/incremental.ml new file mode 100644 index 000000000..fbb711d6d --- /dev/null +++ b/src/lib_shell/bench/helpers/incremental.ml @@ -0,0 +1,122 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Proto_alpha +open Alpha_context + +type t = { + predecessor: Block.t ; + state: M.validation_state ; + rev_operations: Operation.packed list ; + header: Block_header.t ; + delegate: Account.t ; +} +type incremental = t + +let predecessor { predecessor ; _ } = predecessor + +let level st = st.header.shell.level + +let rpc_context st = + let result = Alpha_context.finalize st.state.ctxt in + { + Alpha_environment.Updater.block_hash = Block_hash.zero ; + block_header = { st.header.shell with fitness = result.fitness } ; + context = result.context ; + } + +let rpc_ctxt = + new Alpha_environment.proto_rpc_context_of_directory + rpc_context Proto_alpha.rpc_services + +let begin_construction ?(priority=0) ?timestamp ?seed_nonce_hash (predecessor : Block.t) = + Block.get_next_baker ~policy:(Block.By_priority priority) + predecessor >>=? fun (delegate, priority, real_timestamp) -> + Account.find delegate >>=? fun delegate -> + let timestamp = Option.unopt ~default:real_timestamp timestamp in + let contents = Block.Forge.contents ~priority ?seed_nonce_hash () in + let protocol_data = { + Block_header.contents ; + signature = Signature.zero ; + } in + let header = { + Block_header.shell = { + predecessor = predecessor.hash ; + proto_level = predecessor.header.shell.proto_level ; + validation_passes = predecessor.header.shell.validation_passes ; + fitness = predecessor.header.shell.fitness ; + timestamp ; + level = predecessor.header.shell.level ; + context = Context_hash.zero ; + operations_hash = Operation_list_list_hash.zero ; + } ; + protocol_data = { + contents ; + signature = Signature.zero ; + } ; + } in + M.begin_construction + ~chain_id:Chain_id.zero + ~predecessor_context: predecessor.context + ~predecessor_timestamp: predecessor.header.shell.timestamp + ~predecessor_fitness: predecessor.header.shell.fitness + ~predecessor_level: predecessor.header.shell.level + ~predecessor:predecessor.hash + ~timestamp + ~protocol_data + () >>=? fun state -> + return { + predecessor ; + state ; + rev_operations = [] ; + header ; + delegate ; + } + +let add_operation st op = + M.apply_operation st.state op >>=? fun (state, _result) -> + return { st with state ; rev_operations = op :: st.rev_operations } + +let finalize_block st = + M.finalize_block st.state >>=? fun (result, _) -> + let operations = List.rev st.rev_operations in + let operations_hash = + Operation_list_list_hash.compute [ + Operation_list_hash.compute (List.map Operation.hash_packed operations) + ] in + let header = + { st.header with + shell = { + st.header.shell with + operations_hash ; fitness = result.fitness ; + level = Int32.succ st.header.shell.level + } } in + let hash = Block_header.hash header in + return { + Block.hash ; + header ; + operations ; + context = result.context ; + } diff --git a/src/lib_shell/bench/helpers/incremental.mli b/src/lib_shell/bench/helpers/incremental.mli new file mode 100644 index 000000000..edb5eef03 --- /dev/null +++ b/src/lib_shell/bench/helpers/incremental.mli @@ -0,0 +1,47 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Proto_alpha +open Alpha_context + +type t +type incremental = t + +val predecessor: incremental -> Block.t + +val level: incremental -> int32 + +val begin_construction: + ?priority:int -> + ?timestamp:Time.t -> + ?seed_nonce_hash: Nonce_hash.t -> + Block.t -> incremental tzresult Lwt.t + +val add_operation: + incremental -> Operation.packed -> incremental tzresult Lwt.t + +val finalize_block: incremental -> Block.t tzresult Lwt.t + +val rpc_ctxt: incremental Alpha_environment.RPC_context.simple diff --git a/src/lib_shell/bench/helpers/jbuild b/src/lib_shell/bench/helpers/jbuild new file mode 100644 index 000000000..b4dfdbc46 --- /dev/null +++ b/src/lib_shell/bench/helpers/jbuild @@ -0,0 +1,19 @@ +(jbuild_version 1) + +(library + ((name tezos_alpha_bench_helpers) + (libraries (tezos-base + tezos-stdlib-unix + tezos-shell-services + tezos-protocol-environment + tezos-protocol-alpha + alcotest-lwt)) + (flags (:standard -w -9-32 -safe-string + -open Tezos_base__TzPervasives + -open Tezos_stdlib_unix + -open Tezos_shell_services)))) + +(alias + ((name runtest_indent) + (deps ((glob_files *.ml*))) + (action (run bash ${libexec:tezos-stdlib:test-ocp-indent.sh} ${^})))) diff --git a/src/lib_shell/bench/helpers/nonce.ml b/src/lib_shell/bench/helpers/nonce.ml new file mode 100644 index 000000000..c5a42bf92 --- /dev/null +++ b/src/lib_shell/bench/helpers/nonce.ml @@ -0,0 +1,49 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Proto_alpha + +module Table = Hashtbl.Make(struct + type t = Nonce_hash.t + let hash h = + Int32.to_int (MBytes.get_int32 (Nonce_hash.to_bytes h) 0) + let equal = Nonce_hash.equal + end) + +let known_nonces = Table.create 17 + +let generate () = + match + Alpha_context.Nonce.of_bytes @@ + Rand.generate Alpha_context.Constants.nonce_length + with + | Ok nonce -> + let hash = Alpha_context.Nonce.hash nonce in + Table.add known_nonces hash nonce ; + (hash, nonce) + | Error _ -> assert false + +let forget_all () = Table.clear known_nonces +let get hash = Table.find known_nonces hash diff --git a/src/lib_shell/bench/helpers/nonce.mli b/src/lib_shell/bench/helpers/nonce.mli new file mode 100644 index 000000000..d95991157 --- /dev/null +++ b/src/lib_shell/bench/helpers/nonce.mli @@ -0,0 +1,31 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Proto_alpha + +(** Returns a fresh nonce and its corresponding hash (and stores them). *) +val generate: unit -> Nonce_hash.t * Alpha_context.Nonce.t +val get: Nonce_hash.t -> Alpha_context.Nonce.t +val forget_all: unit -> unit diff --git a/src/lib_shell/bench/helpers/op.ml b/src/lib_shell/bench/helpers/op.ml new file mode 100644 index 000000000..b478c45a0 --- /dev/null +++ b/src/lib_shell/bench/helpers/op.ml @@ -0,0 +1,224 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Proto_alpha +open Alpha_context + +let sign ?(watermark = Signature.Generic_operation) + sk ctxt contents = + let branch = Context.branch ctxt in + let unsigned = + Data_encoding.Binary.to_bytes_exn + Operation.unsigned_encoding + ({ branch }, Contents_list contents) in + let signature = Some (Signature.sign ~watermark sk unsigned) in + ({ shell = { branch } ; + protocol_data = { + contents ; + signature ; + } ; + } : _ Operation.t) + +let endorsement ?delegate ?level ctxt = + fun ?(signing_context=ctxt) slots -> + begin + match delegate with + | None -> Context.get_endorser ctxt (List.hd slots) + | Some delegate -> return delegate + end >>=? fun delegate_pkh -> + Account.find delegate_pkh >>=? fun delegate -> + begin + match level with + | None -> Context.get_level ctxt + | Some level -> return level + end >>=? fun level -> + let op = + Single + (Endorsement { level }) in + return (sign ~watermark:(Signature.Endorsement Chain_id.zero) + delegate.sk signing_context op) + +let sign ?watermark sk ctxt (Contents_list contents) = + Operation.pack (sign ?watermark sk ctxt contents) + +let manager_operation + ?(fee = Tez.zero) + ?(gas_limit = Constants_repr.default.hard_gas_limit_per_operation) + ?(storage_limit = Constants_repr.default.hard_storage_limit_per_operation) + ?public_key ~source ctxt operation = + Context.Contract.counter ctxt source >>=? fun counter -> + Context.Contract.manager ctxt source >>=? fun account -> + let public_key = Option.unopt ~default:account.pk public_key in + let counter = Z.succ counter in + Context.Contract.is_manager_key_revealed ctxt source >>=? function + | true -> + let op = + Manager_operation { + source ; + fee ; + counter ; + operation ; + gas_limit ; + storage_limit ; + } in + return (Contents_list (Single op)) + | false -> + let op_reveal = + Manager_operation { + source ; + fee = Tez.zero ; + counter ; + operation = Reveal public_key ; + gas_limit = Z.of_int 20 ; + storage_limit = Z.zero ; + } in + let op = + Manager_operation { + source ; + fee ; + counter = Z.succ counter ; + operation ; + gas_limit ; + storage_limit ; + } in + return (Contents_list (Cons (op_reveal, Single op))) + +let revelation ctxt public_key = + let pkh = Signature.Public_key.hash public_key in + let source = Contract.implicit_contract pkh in + Context.Contract.counter ctxt source >>=? fun counter -> + Context.Contract.manager ctxt source >>=? fun account -> + let counter = Z.succ counter in + let sop = + Contents_list + (Single + (Manager_operation { + source ; + fee = Tez.zero ; + counter ; + operation = Reveal public_key ; + gas_limit = Z.of_int 20 ; + storage_limit = Z.zero ; + })) in + return @@ sign account.sk ctxt sop + +let originated_contract (op: Operation.packed) = + let nonce = Contract.initial_origination_nonce (Operation.hash_packed op) in + Contract.originated_contract nonce + +exception Impossible + +let origination ?delegate ?script + ?(spendable = true) ?(delegatable = true) ?(preorigination = None) + ?public_key ?manager ?credit ?fee ?gas_limit ?storage_limit ctxt source = + Context.Contract.manager ctxt source >>=? fun account -> + let manager = Option.unopt ~default:account.pkh manager in + let default_credit = Tez.of_mutez @@ Int64.of_int 1000001 in + let default_credit = Option.unopt_exn Impossible default_credit in + let credit = Option.unopt ~default:default_credit credit in + let operation = + Origination { + manager ; + delegate ; + script ; + spendable ; + delegatable ; + credit ; + preorigination ; + } in + manager_operation ?public_key ?fee ?gas_limit ?storage_limit + ~source ctxt operation >>=? fun sop -> + let op = sign account.sk ctxt sop in + return (op , originated_contract op) + +let miss_signed_endorsement ?level ctxt slot = + begin + match level with + | None -> Context.get_level ctxt + | Some level -> return level + end >>=? fun level -> + Context.get_endorser ctxt slot >>=? fun real_delegate_pkh -> + let delegate = Account.find_alternate real_delegate_pkh in + endorsement ~delegate:delegate.pkh ~level ctxt [slot] + +let transaction ?fee ?gas_limit ?storage_limit ?parameters ctxt + (src:Contract.t) (dst:Contract.t) + (amount:Tez.t) = + let top = Transaction { + amount; + parameters; + destination=dst; + } in + manager_operation ?fee ?gas_limit ?storage_limit + ~source:src ctxt top >>=? fun sop -> + Context.Contract.manager ctxt src >>=? fun account -> + return @@ sign account.sk ctxt sop + +let delegation ?fee ctxt source dst = + let top = Delegation dst in + manager_operation ?fee ~source ctxt top >>=? fun sop -> + Context.Contract.manager ctxt source >>=? fun account -> + return @@ sign account.sk ctxt sop + +let activation ctxt (pkh : Signature.Public_key_hash.t) activation_code = + begin match pkh with + | Ed25519 edpkh -> return edpkh + | _ -> failwith "Wrong public key hash : %a - Commitments must be activated with an Ed25519 \ + encrypted public key hash" Signature.Public_key_hash.pp pkh + end >>=? fun id -> + let contents = + Single (Activate_account { id ; activation_code } ) in + let branch = Context.branch ctxt in + return { + shell = { branch } ; + protocol_data = Operation_data { + contents ; + signature = None ; + } ; + } + +let double_endorsement ctxt op1 op2 = + let contents = + Single (Double_endorsement_evidence {op1 ; op2}) in + let branch = Context.branch ctxt in + return { + shell = { branch } ; + protocol_data = Operation_data { + contents ; + signature = None ; + } ; + } + +let double_baking ctxt bh1 bh2 = + let contents = + Single (Double_baking_evidence {bh1 ; bh2}) in + let branch = Context.branch ctxt in + return { + shell = { branch } ; + protocol_data = Operation_data { + contents ; + signature = None ; + } ; + } diff --git a/src/lib_shell/bench/helpers/op.mli b/src/lib_shell/bench/helpers/op.mli new file mode 100644 index 000000000..d32266c8e --- /dev/null +++ b/src/lib_shell/bench/helpers/op.mli @@ -0,0 +1,92 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Proto_alpha +open Alpha_context + +val endorsement: + ?delegate:public_key_hash -> + ?level:Raw_level.t -> + Context.t -> ?signing_context:Context.t -> + int list -> Kind.endorsement Operation.t tzresult Lwt.t + +val miss_signed_endorsement: + ?level:Raw_level.t -> + Context.t -> int -> Kind.endorsement Operation.t tzresult Lwt.t + +val transaction: + ?fee:Tez.tez -> + ?gas_limit:Z.t -> + ?storage_limit:Z.t -> + ?parameters:Script.lazy_expr -> + Context.t -> + Contract.t -> + Contract.t -> + Tez.t -> + Operation.packed tzresult Lwt.t + +val delegation: + ?fee:Tez.tez -> Context.t -> + Contract.t -> public_key_hash option -> + Operation.packed tzresult Lwt.t + +val revelation: + Context.t -> public_key -> Operation.packed tzresult Lwt.t + +val origination: + ?delegate:public_key_hash -> + ?script:Script.t -> + ?spendable:bool -> + ?delegatable:bool -> + ?preorigination: Contract.contract option -> + ?public_key:public_key -> + ?manager:public_key_hash -> + ?credit:Tez.tez -> + ?fee:Tez.tez -> + ?gas_limit:Z.t -> + ?storage_limit:Z.t -> + Context.t -> + Contract.contract -> + (Operation.packed * Contract.contract) tzresult Lwt.t + +val originated_contract: + Operation.packed -> Contract.contract + +val double_endorsement: + Context.t -> + Kind.endorsement Operation.t -> + Kind.endorsement Operation.t -> + Operation.packed tzresult Lwt.t + +val double_baking: + Context.t -> + Block_header.block_header -> + Block_header.block_header -> + Operation.packed tzresult Lwt.t + +val activation: + Context.t -> + Signature.Public_key_hash.t -> Blinded_public_key_hash.activation_code -> + Operation.packed tzresult Lwt.t diff --git a/src/lib_shell/bench/helpers/proto_alpha.ml b/src/lib_shell/bench/helpers/proto_alpha.ml new file mode 100644 index 000000000..5bfe3f514 --- /dev/null +++ b/src/lib_shell/bench/helpers/proto_alpha.ml @@ -0,0 +1,39 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +module Name = struct let name = "alpha" end +module Alpha_environment = Tezos_protocol_environment_memory.MakeV1(Name)() + +type alpha_error = Alpha_environment.Error_monad.error +type 'a alpha_tzresult = 'a Alpha_environment.Error_monad.tzresult + +module Proto = Tezos_protocol_alpha.Functor.Make(Alpha_environment) +module Block_services = struct + include Block_services + include Block_services.Make(Proto)(Proto) +end +include Proto + +module M = Alpha_environment.Lift(Main) diff --git a/src/lib_shell/bench/helpers/test.ml b/src/lib_shell/bench/helpers/test.ml new file mode 100644 index 000000000..63d256388 --- /dev/null +++ b/src/lib_shell/bench/helpers/test.ml @@ -0,0 +1,35 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(* Wraps an alcotest so that it prints correcly errors from the Error_monad. *) +let tztest name speed f = + Alcotest_lwt.test_case name speed begin fun _sw () -> + f () >>= function + | Ok () -> Lwt.return_unit + | Error err -> + Tezos_stdlib_unix.Logging_unix.close () >>= fun () -> + Format.eprintf "WWW %a@." pp_print_error err ; + Lwt.fail Alcotest.Test_error + end diff --git a/src/lib_shell/bench/helpers/test_tez.ml b/src/lib_shell/bench/helpers/test_tez.ml new file mode 100644 index 000000000..5d2aeb67a --- /dev/null +++ b/src/lib_shell/bench/helpers/test_tez.ml @@ -0,0 +1,49 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Proto_alpha +open Alpha_context +open Alpha_environment + +(* This module is mostly to wrap the errors from the protocol *) +module Tez = struct + include Tez + + let ( +? ) t1 t2 = (t1 +? t2) |> wrap_error + let ( -? ) t1 t2 = (t1 -? t2) |> wrap_error + let ( *? ) t1 t2 = (t1 *? t2) |> wrap_error + let ( /? ) t1 t2 = (t1 /? t2) |> wrap_error + + let ( + ) t1 t2 = + match t1 +? t2 with + | Ok r -> r + | Error _ -> + Pervasives.failwith "adding tez" + + let of_int x = + match Tez.of_mutez (Int64.mul (Int64.of_int x) 1_000_000L) with + | None -> invalid_arg "tez_of_int" + | Some x -> x +end diff --git a/src/lib_shell/bench/helpers/test_utils.ml b/src/lib_shell/bench/helpers/test_utils.ml new file mode 100644 index 000000000..e71947bc7 --- /dev/null +++ b/src/lib_shell/bench/helpers/test_utils.ml @@ -0,0 +1,43 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(* This file should not depend on any other file from tests. *) + +let (>>?=) x y = match x with + | Ok(a) -> y a + | Error(b) -> fail @@ List.hd b + +(** Like List.find but returns the index of the found element *) +let findi p = + let rec aux p i = function + | [] -> raise Not_found + | x :: l -> if p x then (x,i) else aux p (i+1) l + in + aux p 0 + +exception Pair_of_list +let pair_of_list = function + | [a;b] -> a,b + | _ -> raise Pair_of_list diff --git a/src/lib_shell/bench/jbuild b/src/lib_shell/bench/jbuild new file mode 100644 index 000000000..f82390426 --- /dev/null +++ b/src/lib_shell/bench/jbuild @@ -0,0 +1,31 @@ +(jbuild_version 1) + +(executables + ((names (bench_simple bench_tool)) + (libraries (tezos-base + tezos-shell + tezos_alpha_bench_helpers)) + (flags (:standard -w -9+27-30-32-40@8 + -safe-string + -open Tezos_base__TzPervasives + -open Tezos_shell + -open Tezos_alpha_bench_helpers)))) + +(alias + ((name buildtest) + (deps (bench_tool.exe bench_simple.exe)))) + +(alias + ((name runbench_alpha_simple) + (deps (bench_simple.exe)) + (action (chdir ${ROOT} (run ${exe:bench_simple.exe}))))) + +(alias + ((name runbench_alpha) + (deps (bench_tool.exe)) + (action (chdir ${ROOT} (run ${exe:bench_tool.exe}))))) + +(alias + ((name runtest_indent) + (deps ((glob_files *.ml*))) + (action (run bash ${libexec:tezos-stdlib:test-ocp-indent.sh} ${^})))) diff --git a/src/lib_shell/bench/tezos-bench.opam b/src/lib_shell/bench/tezos-bench.opam new file mode 100644 index 000000000..7c154f07a --- /dev/null +++ b/src/lib_shell/bench/tezos-bench.opam @@ -0,0 +1,24 @@ +opam-version: "1.2" +version: "dev" +maintainer: "contact@tezos.com" +authors: [ "Tezos devteam" ] +homepage: "https://www.tezos.com/" +bug-reports: "https://gitlab.com/tezos/tezos/issues" +dev-repo: "https://gitlab.com/tezos/tezos.git" +license: "unreleased" +depends: [ + "ocamlfind" { build } + "jbuilder" { build & >= "1.0+beta17" } + "tezos-base" + "tezos-shell" + "tezos-embedded-protocol-alpha" + "cmdliner" + "ssl" + "alcotest-lwt" +] +build: [ + [ "jbuilder" "build" "-p" name "-j" jobs ] +] +build-test: [ + [ "jbuilder" "runtest" "-p" name "-j" jobs ] +]