balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Shell: benchmark for the context storage

Browse Source 
Co-authored-by: Quyen <kim.quyen.ly@tezos.com>
Co-authored-by: Grégoire Henry <gregoire.henry@tezos.com>
Signed-off-by: Grégoire Henry <gregoire.henry@tezos.com>
This commit is contained in:
Vincent Botbol 2018-07-11 20:46:35 +02:00 committed by Grégoire Henry
parent f1dce56885
commit 6909f0b3bc
No known key found for this signature in database
GPG Key ID: 50D984F20BD445D2
23 changed files with 2482 additions and 124 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

255
.gitlab-ci.yml
View File

@ -323,190 +323,197 @@ opam:25:tezos-protocol-environment-sigs:
variables: variables:
package: tezos-protocol-environment-sigs package: tezos-protocol-environment-sigs
opam:26:tezos-client-base: opam:26:ledgerwallet:
<<: *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_definition <<: *opam_definition
variables: variables:
package: ledgerwallet 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 <<: *opam_definition
variables: variables:
package: tezos-embedded-protocol-alpha package: tezos-embedded-protocol-alpha
opam:47:tezos-embedded-protocol-demo: opam:48:tezos-embedded-protocol-demo:
<<: *opam_definition <<: *opam_definition
variables: variables:
package: tezos-embedded-protocol-demo package: tezos-embedded-protocol-demo
opam:48:tezos-embedded-protocol-genesis: opam:49:tezos-embedded-protocol-genesis:
<<: *opam_definition <<: *opam_definition
variables: variables:
package: tezos-embedded-protocol-genesis package: tezos-embedded-protocol-genesis
opam:49:tezos-shell: opam:50:tezos-shell:
<<: *opam_definition <<: *opam_definition
variables: variables:
package: tezos-shell package: tezos-shell
opam:50:tezos-endorser-alpha-commands: opam:51:tezos-endorser-alpha-commands:
<<: *opam_definition <<: *opam_definition
variables: variables:
package: tezos-endorser-alpha-commands package: tezos-endorser-alpha-commands
opam:51:tezos-client: opam:52:tezos-client:
<<: *opam_definition <<: *opam_definition
variables: variables:
package: tezos-client package: tezos-client
opam:52:tezos-endorser-alpha: opam:53:ocplib-ezresto-directory:
<<: *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_definition <<: *opam_definition
variables: variables:
package: ocplib-ezresto-directory package: ocplib-ezresto-directory
opam:55:tezos-accuser-alpha: opam:54:tezos-accuser-alpha:
<<: *opam_definition <<: *opam_definition
variables: variables:
package: tezos-accuser-alpha 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 <<: *opam_definition
variables: variables:
package: tezos-baker-alpha package: tezos-baker-alpha
opam:57:tezos-protocol-demo: opam:58:tezos-protocol-demo:
<<: *opam_definition <<: *opam_definition
variables: variables:
package: tezos-protocol-demo package: tezos-protocol-demo
opam:58:tezos-signer: opam:59:tezos-signer:
<<: *opam_definition <<: *opam_definition
variables: variables:
package: tezos-signer package: tezos-signer
opam:59:ledgerwallet-tezos:
<<: *opam_definition
variables:
package: ledgerwallet-tezos
opam:60:tezos-node: opam:60:tezos-node:
<<: *opam_definition <<: *opam_definition
variables: variables:
package: tezos-node package: tezos-node
opam:59:ocplib-json-typed-browser: opam:61:ocplib-json-typed-browser:
<<: *opam_definition <<: *opam_definition
variables: variables:
package: ocplib-json-typed-browser package: ocplib-json-typed-browser
opam:60:tezos-baker-alpha-commands: opam:62:tezos-baker-alpha-commands:
<<: *opam_definition <<: *opam_definition
variables: variables:
package: tezos-baker-alpha-commands package: tezos-baker-alpha-commands
opam:63:tezos-bench:
<<: *opam_definition
variables:
package: tezos-bench
##END_OPAM## ##END_OPAM##

72
src/lib_shell/bench/bench_simple.ml Normal file
View File

@ -0,0 +1,72 @@
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* 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

369
src/lib_shell/bench/bench_tool.ml Normal file
View File

@ -0,0 +1,369 @@
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* 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 "@[<v 2>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

89
src/lib_shell/bench/helpers/account.ml Normal file
View File

@ -0,0 +1,89 @@
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* 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))

54
src/lib_shell/bench/helpers/account.mli Normal file
View File

@ -0,0 +1,54 @@
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* 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

113
src/lib_shell/bench/helpers/assert.ml Normal file
View File

@ -0,0 +1,113 @@
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* 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)

411
src/lib_shell/bench/helpers/block.ml Normal file
View File

@ -0,0 +1,411 @@
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* 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))

156
src/lib_shell/bench/helpers/block.mli Normal file
View File

@ -0,0 +1,156 @@
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* 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 <opts> accounts] : generates an initial block with the
given constants [<opts>] 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

194
src/lib_shell/bench/helpers/context.ml Normal file
View File

@ -0,0 +1,194 @@
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* 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)

88
src/lib_shell/bench/helpers/context.mli Normal file
View File

@ -0,0 +1,88 @@
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* 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

122
src/lib_shell/bench/helpers/incremental.ml Normal file
View File

@ -0,0 +1,122 @@
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* 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 ;
}

47
src/lib_shell/bench/helpers/incremental.mli Normal file
View File

@ -0,0 +1,47 @@
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* 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

19
src/lib_shell/bench/helpers/jbuild Normal file
View File

@ -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} ${^}))))

49
src/lib_shell/bench/helpers/nonce.ml Normal file
View File

@ -0,0 +1,49 @@
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* 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

31
src/lib_shell/bench/helpers/nonce.mli Normal file
View File

@ -0,0 +1,31 @@
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* 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

224
src/lib_shell/bench/helpers/op.ml Normal file
View File

@ -0,0 +1,224 @@
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* 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 ;
} ;
}

92
src/lib_shell/bench/helpers/op.mli Normal file
View File

@ -0,0 +1,92 @@
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* 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

39
src/lib_shell/bench/helpers/proto_alpha.ml Normal file
View File

@ -0,0 +1,39 @@
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* 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)

35
src/lib_shell/bench/helpers/test.ml Normal file
View File

@ -0,0 +1,35 @@
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* 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

49
src/lib_shell/bench/helpers/test_tez.ml Normal file
View File

@ -0,0 +1,49 @@
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* 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

43
src/lib_shell/bench/helpers/test_utils.ml Normal file
View File

@ -0,0 +1,43 @@
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* 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

31
src/lib_shell/bench/jbuild Normal file
View File

@ -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} ${^}))))

24
src/lib_shell/bench/tezos-bench.opam Normal file
View File

@ -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 ]
]