From e5ea08d6751b1d273dee2ed80e2be285ce69b2f6 Mon Sep 17 00:00:00 2001 From: Galfour Date: Mon, 15 Jan 2018 22:09:25 +0100 Subject: [PATCH] Tests: add isolate tests --- test/proto_alpha/jbuild | 1 + test/proto_alpha_isolate/jbuild | 38 ++ test/proto_alpha_isolate/test_isolate_dsl.ml | 163 ++++++ .../test_isolate_endorsement.ml | 153 ++++++ test/proto_alpha_isolate/test_isolate_main.ml | 16 + .../test_isolate_michelson.ml | 501 ++++++++++++++++++ .../test_isolate_origination.ml | 106 ++++ .../test_isolate_transaction.ml | 164 ++++++ .../helpers_account.ml | 106 ++++ .../helpers_account.mli | 63 +++ .../helpers_apply.ml | 88 +++ .../helpers_apply.mli | 57 ++ .../helpers_assert.ml | 199 +++++++ .../helpers_assert.mli | 81 +++ .../helpers_block.ml | 188 +++++++ .../helpers_block.mli | 81 +++ .../helpers_cast.ml | 40 ++ .../helpers_cast.mli | 27 + .../helpers_constants.ml | 32 ++ .../helpers_constants.mli | 19 + .../helpers_init.ml | 123 +++++ .../helpers_init.mli | 12 + .../helpers_logger.ml | 16 + .../helpers_logger.mli | 12 + .../helpers_misc.ml | 78 +++ .../helpers_misc.mli | 29 + .../helpers_operation.ml | 137 +++++ .../helpers_operation.mli | 71 +++ .../helpers_script.ml | 36 ++ .../helpers_script.mli | 17 + .../helpers_services.ml | 23 + .../helpers_services.mli | 18 + .../helpers_sodium.ml | 19 + .../helpers_sodium.mli | 13 + .../isolate_helpers.ml | 57 ++ test/proto_alpha_isolate_helpers/jbuild | 19 + .../proto_alpha.ml | 5 + 37 files changed, 2808 insertions(+) create mode 100644 test/proto_alpha_isolate/jbuild create mode 100644 test/proto_alpha_isolate/test_isolate_dsl.ml create mode 100644 test/proto_alpha_isolate/test_isolate_endorsement.ml create mode 100644 test/proto_alpha_isolate/test_isolate_main.ml create mode 100644 test/proto_alpha_isolate/test_isolate_michelson.ml create mode 100644 test/proto_alpha_isolate/test_isolate_origination.ml create mode 100644 test/proto_alpha_isolate/test_isolate_transaction.ml create mode 100644 test/proto_alpha_isolate_helpers/helpers_account.ml create mode 100644 test/proto_alpha_isolate_helpers/helpers_account.mli create mode 100644 test/proto_alpha_isolate_helpers/helpers_apply.ml create mode 100644 test/proto_alpha_isolate_helpers/helpers_apply.mli create mode 100644 test/proto_alpha_isolate_helpers/helpers_assert.ml create mode 100644 test/proto_alpha_isolate_helpers/helpers_assert.mli create mode 100644 test/proto_alpha_isolate_helpers/helpers_block.ml create mode 100644 test/proto_alpha_isolate_helpers/helpers_block.mli create mode 100644 test/proto_alpha_isolate_helpers/helpers_cast.ml create mode 100644 test/proto_alpha_isolate_helpers/helpers_cast.mli create mode 100644 test/proto_alpha_isolate_helpers/helpers_constants.ml create mode 100644 test/proto_alpha_isolate_helpers/helpers_constants.mli create mode 100644 test/proto_alpha_isolate_helpers/helpers_init.ml create mode 100644 test/proto_alpha_isolate_helpers/helpers_init.mli create mode 100644 test/proto_alpha_isolate_helpers/helpers_logger.ml create mode 100644 test/proto_alpha_isolate_helpers/helpers_logger.mli create mode 100644 test/proto_alpha_isolate_helpers/helpers_misc.ml create mode 100644 test/proto_alpha_isolate_helpers/helpers_misc.mli create mode 100644 test/proto_alpha_isolate_helpers/helpers_operation.ml create mode 100644 test/proto_alpha_isolate_helpers/helpers_operation.mli create mode 100644 test/proto_alpha_isolate_helpers/helpers_script.ml create mode 100644 test/proto_alpha_isolate_helpers/helpers_script.mli create mode 100644 test/proto_alpha_isolate_helpers/helpers_services.ml create mode 100644 test/proto_alpha_isolate_helpers/helpers_services.mli create mode 100644 test/proto_alpha_isolate_helpers/helpers_sodium.ml create mode 100644 test/proto_alpha_isolate_helpers/helpers_sodium.mli create mode 100644 test/proto_alpha_isolate_helpers/isolate_helpers.ml create mode 100644 test/proto_alpha_isolate_helpers/jbuild create mode 100644 test/proto_alpha_isolate_helpers/proto_alpha.ml diff --git a/test/proto_alpha/jbuild b/test/proto_alpha/jbuild index 40fe0e48c..fa21894e4 100644 --- a/test/proto_alpha/jbuild +++ b/test/proto_alpha/jbuild @@ -11,6 +11,7 @@ tezos-client-base tezos-client-genesis tezos-client-alpha + tezos-shell test_lib)) (flags (:standard -w -9-32 -safe-string -open Tezos_base__TzPervasives diff --git a/test/proto_alpha_isolate/jbuild b/test/proto_alpha_isolate/jbuild new file mode 100644 index 000000000..82d949fb2 --- /dev/null +++ b/test/proto_alpha_isolate/jbuild @@ -0,0 +1,38 @@ +(jbuild_version 1) + +(rule + ((targets (michelson_v1_parser.ml)) + (action (copy# ../../src/proto_alpha/lib_client/michelson_v1_parser.ml michelson_v1_parser.ml)))) + +(rule + ((targets (michelson_macros.ml)) + (action (copy# ../../src/proto_alpha/lib_client/michelson_macros.ml michelson_macros.ml)))) + +(executables + ((names (test_isolate_main)) + (libraries (tezos-base + tezos-rpc-http + tezos-shell + test_lib + tezos_proto_alpha_isolate_helpers)) + (flags (:standard -w -9-32 -safe-string + -open Tezos_base__TzPervasives + -open Tezos_rpc_http)))) + +(alias + ((name buildtest) + (deps (test_isolate_main.exe)))) + +(alias + ((name runtest_isolate_main) + (deps (../proto_alpha/sandbox.json (glob_files ../contracts/*.tz))) + (action (chdir ${ROOT} (run ${exe:test_isolate_main.exe}))))) + +(alias + ((name runtest) + (deps ((alias runtest_isolate_main))))) + +(alias + ((name runtest_indent) + (deps ((glob_files *.ml) (glob_files *.mli))) + (action (run bash ${libexec:tezos-stdlib:test-ocp-indent.sh} ${^})))) diff --git a/test/proto_alpha_isolate/test_isolate_dsl.ml b/test/proto_alpha_isolate/test_isolate_dsl.ml new file mode 100644 index 000000000..c35e59c87 --- /dev/null +++ b/test/proto_alpha_isolate/test_isolate_dsl.ml @@ -0,0 +1,163 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + + +open Helpers_logger.Logger + +exception No_error + +open Isolate_helpers + +let run (starting_block : Block.result): unit Proto_alpha.tzresult Lwt.t = + + let open Proto_alpha.Error_monad in + + let init_tc = starting_block.tezos_context in + + Account.make_2_accounts ~tc: init_tc >>=? fun ((account_a, account_b), init_tc) -> + Account.make_account ~tc: init_tc >>=? fun (_baker, init_tc) -> + let account_unknown_foo = Account.new_account () in + debug "Accounts set" ; + + let default_fee = 10 in + + let transfer ?(tc=init_tc) ?fee a b c = + Apply.transaction_pred + ~tc + ~pred: starting_block + (a,b,c, fee) + in + let originate ?(tc=init_tc) ?fee ?(spendable=true) ?(delegatable=true) a b = + let fee = Option.unopt ~default:default_fee fee in + Apply.origination_pred + ~tc + ~pred: starting_block + (a, b, spendable, delegatable, fee) + in + + (* Send from a sender with no balance (never seen). *) + (* TODO: Is it OK to get Storage_error and not something more specific? *) + transfer + account_unknown_foo + account_b + 10000 >|= Assert.unknown_contract ~msg: __LOC__ >>= fun _ -> + debug "Transfer from no balance V2" ; + + (* Send 1000 tz to unknown account. *) + transfer + account_a + account_unknown_foo + 10000 >>= Assert.ok_contract >>=? fun (_, tc) -> + Assert.equal_cents_balance ~msg: __LOC__ ~tc (account_unknown_foo.contract, 10000) >>=? fun () -> + debug "Reception" ; + + (* Check that a basic transfer originates no contracts. *) + transfer + ~tc + account_a + account_b + 1000 + >>=? fun ((contracts, _), _) -> + Assert.equal_int ~msg: __LOC__ 0 (List.length contracts) ; + debug "No contracts originated" ; + + (* Check sender/receiver balance post transaction *) + transfer + account_a + account_b + 1000 + >>= Assert.ok_contract ~msg: __LOC__ >>=? fun (_,tc) -> + Assert.equal_cents_balance ~msg: __LOC__ ~tc (account_a.contract, 998990) >>=? fun () -> + Assert.equal_cents_balance ~msg: __LOC__ ~tc (account_b.contract, 1001000) >>=? fun () -> + debug "Transfer balances" ; + + (* Check balance too low. *) + transfer + account_a + account_b + 10000000 + >|= Assert.balance_too_low ~msg: __LOC__ >>= fun _ -> + debug "Too low" ; + + (* Check non-spendability of a non-spendable contract *) + (* TODO: Unspecified economic error: should be more specific. *) + originate + ~spendable: false + account_a + 1000 + >>= Assert.ok_contract ~msg: __LOC__ >>=? fun ((contracts,_), tc) -> + Assert.equal_int (List.length contracts) 1 ; + let non_spendable = List.hd contracts in + let account = {account_a with contract = non_spendable} in + debug "Contract created" ; + transfer account account_b 50 ~tc >>= Assert.wrap >>= fun result -> + Assert.non_spendable ~msg: __LOC__ result ; + debug "Non Spendable" ; + + (* Check spendability of a spendable contract *) + originate + ~spendable: true + ~fee: 100 + account_a + 1000 + >>= Assert.ok_contract ~msg: __LOC__ >>=? fun ((contracts, _), spendable_tc) -> + Assert.equal_int (List.length contracts) 1 ; + let contract_spendable = List.hd contracts in + let account_spendable = {account_a with contract = contract_spendable} in + debug "Contract created" ; + transfer account_spendable account_b 50 ~tc: spendable_tc >>= Assert.ok ~msg: __LOC__ >>=? fun _ -> + debug "Spendable" ; + + + (* Try spending a default account with unmatching pk/sk pairs. *) + let account = { account_a with ppk = account_b.ppk } in + transfer + account + account_b + 50 + >>= Assert.wrap >>= fun result -> + Assert.generic_economic_error ~msg: __LOC__ result ; + debug "Unmatching keys" ; + + (* Try spending a default account with keys not matching the + contract pkh. *) + let account = {account_a with contract = account_b.contract } in + transfer + account + account_unknown_foo + 50 + >>= Assert.wrap >>= fun result -> + Assert.inconsistent_pkh ~msg: __LOC__ result ; + debug "Unmatching contract" ; + + (* Try spending an originated contract without the manager's key. *) + let account = {account_b with contract = contract_spendable } in + transfer + ~tc: spendable_tc + account + account_unknown_foo + 50 + >>= Assert.wrap >>= fun result -> + Assert.inconsistent_pkh ~msg: __LOC__ result ; + debug "No manager key" ; + + return () + + +let main () = + Init.main () >>=? fun starting_block -> + run starting_block >>= Assert.wrap + + +let tests = [ + "main", (fun _ -> main ()) ; +] + +let main () = + Test.run "dsl." tests diff --git a/test/proto_alpha_isolate/test_isolate_endorsement.ml b/test/proto_alpha_isolate/test_isolate_endorsement.ml new file mode 100644 index 000000000..e820f457b --- /dev/null +++ b/test/proto_alpha_isolate/test_isolate_endorsement.ml @@ -0,0 +1,153 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + + +let name = "Isolate Endorsement" +module Logger = Logging.Make(struct let name = name end) +let section = Lwt_log.Section.make name +let () = + Lwt_log.Section.set_level section Lwt_log(*.Debug*).Warning + + +exception No_error + +open Isolate_helpers +open Shorthands +open Proto_alpha.Environment.Error_monad +let (>>?=) = Assert.(>>?=) + +let test_wrong_slot endorse_a starting_block = + let wrong_slot = function + | Proto_alpha.Baking.Invalid_endorsement_slot _ -> true + | _ -> false + in + starting_block >>=? endorse_a (-1) >>?= fun result -> + Assert.economic_error ~msg: __LOC__ wrong_slot result ; + starting_block >>=? endorse_a 16 >>?= fun result -> + Assert.economic_error ~msg: __LOC__ wrong_slot result ; + return () + + +let test_wrong_delegate endorse_a starting_block = + let wrong_delegate = function + | Proto_alpha.Baking.Wrong_delegate _ -> true + | _ -> false + in + starting_block >>=? + endorse_a 0 >>=? endorse_a 1 >>=? endorse_a 2 >>= Assert.wrap >>= fun result -> + Assert.economic_error ~msg: __LOC__ wrong_delegate result ; + return () + + +let test_endorsement_payment starting_block = + let bootstrap_accounts = Account.bootstrap_accounts in + let open Proto_alpha.Tezos_context in + starting_block >>=? fun root -> + get_tc_full root >>=? fun tc -> + let level = Level.succ tc @@ Level.current tc in + Proto_alpha.Services_registration.endorsement_rights tc level None >>=? fun (_, endorsers) -> + + let aux (endorser_slot, block_priority) = + let contract_p = + Misc.find_account bootstrap_accounts + @@ List.nth endorsers endorser_slot in + Contract.get_balance tc (Contract.default_contract contract_p.hpub) >>=? fun init_balance -> + + (* After one block, endorsement bond cost should be paid *) + Block.endorsement + root.tezos_header.shell root.hash + root.level block_priority contract_p + root.validation.context endorser_slot + >>=? fun result -> + get_balance_res contract_p result >>=? fun bond_balance -> + let proto_header = Block.get_proto_header block_priority in + Proto_alpha.Baking.check_baking_rights + result.tezos_context proto_header root.tezos_header.shell.timestamp + >>=? fun baker_hpub -> + let endorsement_bond_cost = + Constants.endorsement_bond_cost in + let baking = baker_hpub = contract_p.hpub && block_priority < 4 in + let baking_bond_cost = + if baking + then Constants.baking_bond_cost + else Tez.zero in + let cost = Cast.tez_add endorsement_bond_cost baking_bond_cost in + let expected_balance = Cast.tez_sub init_balance cost in + Assert.equal_tez ~msg: __LOC__ expected_balance bond_balance ; + (* After one cycle, (4 blocks in test/proto_alpha/sandbox), + endorsement reward sould be received *) + chain_empty_block result >>=? chain_empty_block >>=? + chain_empty_block >>=? chain_empty_block >>=? fun result -> + get_balance_res contract_p result >>=? fun reward_balance -> + Proto_alpha.Baking.endorsement_reward ~block_priority >>=? fun reward -> + let expected_balance = Cast.tez_add expected_balance reward in + let expected_balance = Cast.tez_add expected_balance endorsement_bond_cost in + Assert.equal_tez ~msg: __LOC__ expected_balance reward_balance ; + return () + in + let slots = [0 ;1 ;2 ;3 ;4 ;5 ;6 ;7 ;8 ;9 ;10 ;11 ;12 ;13 ;14] in + let prios = [0 ;1 ;2 ;3 ;4 ;5 ;6] in + iter_s aux @@ List.product slots prios + + +let test_multiple_endorsement (pred: Block.result) = + let open Proto_alpha.Tezos_context in + let tc = pred.tezos_context in + let level = Level.succ tc @@ Level.current tc in + Proto_alpha.Services_registration.endorsement_rights tc level None >>=? fun (_, endorsers) -> + let endorser = + Misc.find_account Account.bootstrap_accounts + @@ List.nth endorsers 0 in + let op = Isolate_helpers.Operation.endorsement_full endorser pred.hash, endorser in + Block.of_res ~res: pred ~ops: [op ;op] () >>= Assert.wrap >>= fun x -> + Assert.double_endorsement ~msg: __LOC__ x ; + return () + + +let test_wrong_endorsement starting_block = + let account = Account.new_account () in + let endorse slot (res: Block.result) = + Block.endorsement + res.tezos_header.shell res.hash res.level + 15 account res.validation.context slot + in + test_wrong_delegate endorse starting_block >>=? fun () -> + test_wrong_slot endorse starting_block + + +let test_fitness (res: Block.result) = + Block.of_res ~priority: 0 ~res () >>=? fun block_0 -> + let fitness_0 = block_0.validation.fitness in + Block.of_res ~priority: 1 ~res () >>=? fun block_1 -> + let fitness_1 = block_1.validation.fitness in + let diff = Fitness.compare fitness_0 fitness_1 in + Assert.equal_int ~msg: "Fitness test" diff 0 ; + return () + + +let (>>=??) = Assert.(>>=??) + +let main (): unit Error_monad.tzresult Lwt.t = + let open Error_monad in + + Init.main () >>=? fun sb -> + let starting_block = Proto_alpha.Error_monad.return sb in + + test_endorsement_payment starting_block >>=?? fun () -> + test_wrong_endorsement starting_block >>=?? fun () -> + test_multiple_endorsement sb >>=?? fun () -> + test_fitness sb >>=?? fun () -> + return () + +let tests = [ + "main", (fun _ -> main ()) ; +] + +let main () = + Test.run "endorsement." tests diff --git a/test/proto_alpha_isolate/test_isolate_main.ml b/test/proto_alpha_isolate/test_isolate_main.ml new file mode 100644 index 000000000..66acb05c4 --- /dev/null +++ b/test/proto_alpha_isolate/test_isolate_main.ml @@ -0,0 +1,16 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +let () = + Test_isolate_dsl.main (); + Test_isolate_transaction.main (); + Test_isolate_endorsement.main (); + Test_isolate_origination.main (); + Test_isolate_michelson.main () + diff --git a/test/proto_alpha_isolate/test_isolate_michelson.ml b/test/proto_alpha_isolate/test_isolate_michelson.ml new file mode 100644 index 000000000..5366831cd --- /dev/null +++ b/test/proto_alpha_isolate/test_isolate_michelson.ml @@ -0,0 +1,501 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + + +let name = "Isolate Michelson" +module Logger = Logging.Make(struct let name = name end) +let section = Lwt_log.Section.make name +let () = + Lwt_log.Section.set_level section Lwt_log.Debug(*.Warning*) + +open Logger + +open Isolate_helpers +open Shorthands + +let (>>??) = Assert.(>>??) +let (>>=??) = Assert.(>>=??) + +open Tezos_micheline + +let parse_param s : Proto_alpha.Tezos_context.Script.expr = + let (parsed, _) = Michelson_v1_parser.parse_expression s in + parsed.expanded + + +let parse_script code_str storage_str : Proto_alpha.Tezos_context.Script.t = + let code = parse_param code_str in + let storage = parse_param storage_str in + let return: Proto_alpha.Tezos_context.Script.t = {code ; storage} in + return + + +let program param ret st code = + let storage s = " storage " ^ s ^ " ; \n" in + let parameter s = " parameter " ^ s ^ " ; \n" in + let return s = " return " ^ s ^ " ; \n" in + "{\n" ^ (storage st) ^ (parameter param) ^ (return ret) ^ " " ^ code ^ "}" + +let quote s = "\"" ^ s ^ "\"" + +let test parse_execute = + let dir_path = "test/contracts/" in + let test ?tc (file_name: string) (storage: string) (input: string) = + let full_path = dir_path ^ file_name ^ ".tz" in + let file = Helpers_misc.read_file full_path in + let spaced_file = Str.global_replace (Str.regexp_string "\n") "\n " file in + let program = "{" ^ spaced_file ^ "}" in + parse_execute ?tc program input storage + in + test + + +let test_fails ?location parse_execute f s i = + test parse_execute f s i >>= fun x -> + let msg = Option.unopt ~default:"Not failing" location in + Assert.generic_economic_error ~msg x ; + return () + + +let string_of_canon output_prim = + let output_can = Proto_alpha.Michelson_v1_primitives.strings_of_prims output_prim in + let location_maker _ = + let ret : Micheline_printer.location = {comment=None} in + ret in + let output_node = Micheline.inject_locations location_maker output_can in + Format.fprintf + Format.str_formatter "%a" Micheline_printer.print_expr output_node ; + let output = Format.flush_str_formatter () in + output + + +let test_print parse_execute fn s i = + test parse_execute fn s i >>=? fun (sp, op, _) -> + let ss = string_of_canon sp in + let os = string_of_canon op in + debug "Storage : %s" ss ; + debug "Output : %s" os ; + return () + + +let test_output parse_execute ?location (file_name: string) (storage: string) (input: string) (expected_output: string) = + test parse_execute file_name storage input >>=? fun (_storage_prim, output_prim, _tc, _contracts) -> + let output = string_of_canon output_prim in + let msg = Option.unopt ~default:"strings aren't equal" location in + Assert.equal_string ~msg expected_output output ; + return () + + +let test_tc ?tc parse_execute (file_name: string) (storage: string) (input: string) = + test parse_execute ?tc file_name storage input >>=? fun (_storage_prim, _output_prim, tc, _contracts) -> + return (tc) + + +let test_contract ?tc parse_execute (file_name: string) (storage: string) (input: string) = + test parse_execute ?tc file_name storage input >>=? fun (_storage_prim, _output_prim, tc, contracts) -> + return (contracts, tc) + + + +let test_storage parse_execute ?location (file_name: string) (storage: string) (input: string) (expected_storage: string) = + test parse_execute file_name storage input >>=? fun (storage_prim, _output_prim, _tc, _contracts) -> + let storage = string_of_canon storage_prim in + let msg = Option.unopt ~default:"strings aren't equal" location in + Assert.equal_string ~msg expected_storage storage ; + return () + + +let test_example parse_execute sb = + let test_output ?location a b c d = + test_output ?location parse_execute a b c d >>= function + | Ok(x) -> return x + | Error(errs) -> ( + match location with + | None -> () + | Some(loc) -> debug "loc : %s" loc + ) ; Lwt.return (Error(errs)) + in + let test_fails ?location = test_fails ?location parse_execute in + let test_tc ?tc = test_tc ?tc parse_execute in + let test_contract ?tc = test_contract ?tc parse_execute in + (* let test_print ?location = test_print ?location parse_execute in*) + let test_storage ?location = test_storage ?location parse_execute in + + (* FORMAT: assert_output contract_file storage input expected_result *) + test_output ~location: __LOC__ "ret_int" "Unit" "Unit" "300" >>=? fun _ -> + + (* Identity on strings *) + test_output ~location: __LOC__ "str_id" "Unit" "\"Hello\"" "\"Hello\"" >>=? fun _ -> + test_output ~location: __LOC__ "str_id" "Unit" "\"abcd\"" "\"abcd\"" >>=? fun _ -> + + (* Identity on pairs *) + test_output ~location: __LOC__ "pair_id" "Unit" "(Pair True False)" "(Pair True False)" >>=? fun _ -> + test_output ~location: __LOC__ "pair_id" "Unit" "(Pair False True)" "(Pair False True)" >>=? fun _ -> + test_output ~location: __LOC__ "pair_id" "Unit" "(Pair True True)" "(Pair True True)" >>=? fun _ -> + test_output ~location: __LOC__ "pair_id" "Unit" "(Pair False False)" "(Pair False False)" >>=? fun _ -> + + (* Logical not *) + test_output ~location: __LOC__ "not" "Unit" "True" "False" >>=? fun _ -> + test_output ~location: __LOC__ "not" "Unit" "False" "True" >>=? fun _ -> + + (* Logical and *) + test_output ~location: __LOC__ "and" "Unit" "(Pair False False)" "False" >>=? fun _ -> + test_output ~location: __LOC__ "and" "Unit" "(Pair False True)" "False" >>=? fun _ -> + test_output ~location: __LOC__ "and" "Unit" "(Pair True False)" "False" >>=? fun _ -> + test_output ~location: __LOC__ "and" "Unit" "(Pair True True)" "True" >>=? fun _ -> + + (* Logical or *) + test_output ~location: __LOC__ "or" "Unit" "(Pair False False)" "False" >>=? fun _ -> + test_output ~location: __LOC__ "or" "Unit" "(Pair False True)" "True" >>=? fun _ -> + test_output ~location: __LOC__ "or" "Unit" "(Pair True False)" "True" >>=? fun _ -> + test_output ~location: __LOC__ "or" "Unit" "(Pair True True)" "True" >>=? fun _ -> + + (* XOR *) + test_output ~location: __LOC__ "xor" "Unit" "(Pair False False)" "False" >>=? fun _ -> + test_output ~location: __LOC__ "xor" "Unit" "(Pair False True)" "True" >>=? fun _ -> + test_output ~location: __LOC__ "xor" "Unit" "(Pair True False)" "True" >>=? fun _ -> + test_output ~location: __LOC__ "xor" "Unit" "(Pair True True)" "False" >>=? fun _ -> + + + (* Build list *) + test_output ~location: __LOC__ "build_list" "Unit" "0" "{ 0 }" >>=? fun _ -> + test_output ~location: __LOC__ "build_list" "Unit" "3" "{ 0 ; 1 ; 2 ; 3 }" >>=? fun _ -> + test_output ~location: __LOC__ "build_list" "Unit" "10" "{ 0 ; 1 ; 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 ; 10 }" >>=? fun _ -> + + (* Concatenate all strings of a list into one string *) + test_output ~location: __LOC__ "concat_list" "Unit" "{ \"a\" ; \"b\" ; \"c\" }" "\"abc\"" >>=? fun _ -> + test_output ~location: __LOC__ "concat_list" "Unit" "{}" "\"\"" >>=? fun _ -> + test_output ~location: __LOC__ "concat_list" "Unit" "{ \"Hello\" ; \" \" ; \"World\" ; \"!\" }" "\"Hello World!\"" >>=? fun _ -> + + (* Find maximum int in list -- returns None if not found *) + test_output ~location: __LOC__ "max_in_list" "Unit" "{}" "None" >>=? fun _ -> + test_output ~location: __LOC__ "max_in_list" "Unit" "{ 1 }" "(Some 1)" >>=? fun _ -> + test_output ~location: __LOC__ "max_in_list" "Unit" "{ -1 }" "(Some -1)" >>=? fun _ -> + test_output ~location: __LOC__ "max_in_list" "Unit" "{ 10 ; -1 ; -20 ; 100 ; 0 }" "(Some 100)" >>=? fun _ -> + test_output ~location: __LOC__ "max_in_list" "Unit" "{ 10 ; -1 ; -20 ; 100 ; 0 }" "(Some 100)" >>=? fun _ -> + test_output ~location: __LOC__ "max_in_list" "Unit" "{ -10 ; -1 ; -20 ; -100 }" "(Some -1)" >>=? fun _ -> + + (* Identity on lists *) + test_output ~location: __LOC__ "list_id" "Unit" "{ \"1\" ; \"2\" ; \"3\" }" "{ \"1\" ; \"2\" ; \"3\" }" >>=? fun _ -> + test_output ~location: __LOC__ "list_id" "Unit" "{}" "{}" >>=? fun _ -> + test_output ~location: __LOC__ "list_id" "Unit" "{ \"a\" ; \"b\" ; \"c\" }" "{ \"a\" ; \"b\" ; \"c\" }" >>=? fun _ -> + + test_output ~location: __LOC__ "list_id_map" "Unit" "{ \"1\" ; \"2\" ; \"3\" }" "{ \"1\" ; \"2\" ; \"3\" }" >>=? fun _ -> + test_output ~location: __LOC__ "list_id_map" "Unit" "{}" "{}" >>=? fun _ -> + test_output ~location: __LOC__ "list_id_map" "Unit" "{ \"a\" ; \"b\" ; \"c\" }" "{ \"a\" ; \"b\" ; \"c\" }" >>=? fun _ -> + + + (* Identity on maps *) + test_output ~location: __LOC__ "map_id" "Unit" "{ Elt 0 1 }" "{ Elt 0 1 }" >>=? fun _ -> + test_output ~location: __LOC__ "map_id" "Unit" "{ Elt 0 0 }" "{ Elt 0 0 }" >>=? fun _ -> + test_output ~location: __LOC__ "map_id" "Unit" "{ Elt 0 0 ; Elt 3 4 }" "{ Elt 0 0 ; Elt 3 4 }" >>=? fun _ -> + + (* Map block on lists *) + test_output ~location: __LOC__ "list_map_block" "Unit" "{}" "{}" >>=? fun _ -> + test_output ~location: __LOC__ "list_map_block" "Unit" "{ 1 ; 1 ; 1 ; 1 }" "{ 1 ; 2 ; 3 ; 4 }" >>=? fun _ -> + test_output ~location: __LOC__ "list_map_block" "Unit" "{ 1 ; 2 ; 3 ; 0 }" "{ 1 ; 3 ; 5 ; 3 }" >>=? fun _ -> + + (* List iter *) + test_output ~location: __LOC__ "list_iter" "Unit" "{ 10 ; 2 ; 1 }" "20" >>=? fun _ -> + test_output ~location: __LOC__ "list_iter" "Unit" "{ 3 ; 6 ; 9 }" "162" >>=? fun _ -> + + test_output ~location: __LOC__ "list_iter2" "Unit" "{ \"a\" ; \"b\" ; \"c\" }" "\"cba\"" >>=? fun _ -> + test_output ~location: __LOC__ "list_iter2" "Unit" "{}" "\"\"" >>=? fun _ -> + + + (* Identity on sets *) + test_output ~location: __LOC__ "set_id" "Unit" "{ \"a\" ; \"b\" ; \"c\" }" "{ \"a\" ; \"b\" ; \"c\" }" >>=? fun _ -> + test_output ~location: __LOC__ "set_id" "Unit" "{}" "{}" >>=? fun _ -> + test_output ~location: __LOC__ "set_id" "Unit" "{ \"asdf\" ; \"bcde\" }" "{ \"asdf\" ; \"bcde\" }" >>=? fun _ -> + + (* Set member -- set is in storage *) + test_output ~location: __LOC__ "set_member" "{}" "\"Hi\"" "False" >>=? fun _ -> + test_output ~location: __LOC__ "set_member" "{ \"Hi\" }" "\"Hi\"" "True" >>=? fun _ -> + test_output ~location: __LOC__ "set_member" "{ \"Hello\" ; \"World\" }" "\"\"" "False" >>=? fun _ -> + + (* Set size *) + test_output ~location: __LOC__ "set_size" "Unit" "{}" "0" >>=? fun _ -> + test_output ~location: __LOC__ "set_size" "Unit" "{ 1 }" "1" >>=? fun _ -> + test_output ~location: __LOC__ "set_size" "Unit" "{ 1 ; 2 ; 3 }" "3" >>=? fun _ -> + test_output ~location: __LOC__ "set_size" "Unit" "{ 1 ; 2 ; 3 ; 4 ; 5 ; 6 }" "6" >>=? fun _ -> + + (* Set iter *) + test_output ~location: __LOC__ "set_iter" "Unit" "{}" "0" >>=? fun _ -> + test_output ~location: __LOC__ "set_iter" "Unit" "{ 1 }" "1" >>=? fun _ -> + test_output ~location: __LOC__ "set_iter" "Unit" "{ -100 ; 1 ; 2 ; 3 }" "-94" >>=? fun _ -> + + (* Map size *) + test_output ~location: __LOC__ "map_size" "Unit" "{}" "0" >>=? fun _ -> + test_output ~location: __LOC__ "map_size" "Unit" "{ Elt \"a\" 1 }" "1" >>=? fun _ -> + test_output ~location: __LOC__ "map_size" "Unit" "{ Elt \"a\" 1 ; Elt \"b\" 2 ; Elt \"c\" 3 }" "3" >>=? fun _ -> + test_output ~location: __LOC__ "map_size" "Unit" "{ Elt \"a\" 1 ; Elt \"b\" 2 ; Elt \"c\" 3 ; Elt \"d\" 4 ; Elt \"e\" 5 ; Elt \"f\" 6 }" "6" >>=? fun _ -> + + (* Contains all elements -- does the second list contain all of the same elements *) + (* as the first one? I'm ignoring element multiplicity *) + test_output ~location: __LOC__ "contains_all" "Unit" "(Pair {} {})" "True" >>=? fun _ -> + test_output ~location: __LOC__ "contains_all" "Unit" "(Pair { \"a\" } { \"B\" })" "False" >>=? fun _ -> + test_output ~location: __LOC__ "contains_all" "Unit" "(Pair { \"A\" } { \"B\" })" "False" >>=? fun _ -> + test_output ~location: __LOC__ "contains_all" "Unit" "(Pair { \"B\" } { \"B\" })" "True" >>=? fun _ -> + test_output ~location: __LOC__ "contains_all" "Unit" "(Pair { \"B\" ; \"C\" ; \"asdf\" } { \"B\" ; \"B\" ; \"asdf\" ; \"C\" })" "True" >>=? fun _ -> + test_output ~location: __LOC__ "contains_all" "Unit" "(Pair { \"B\" ; \"B\" ; \"asdf\" ; \"C\" } { \"B\" ; \"C\" ; \"asdf\" })" "True" >>=? fun _ -> + + (* Concatenate the string in storage with all strings in the given list *) + test_output ~location: __LOC__ "concat_hello" "Unit" "{ \"World!\" }" "{ \"Hello World!\" }" >>=? fun _ -> + test_output ~location: __LOC__ "concat_hello" "Unit" "{}" "{}" >>=? fun _ -> + test_output ~location: __LOC__ "concat_hello" "Unit" "{ \"test1\" ; \"test2\" }" "{ \"Hello test1\" ; \"Hello test2\" }" >>=? fun _ -> + + (* Create an empty map and add a string to it *) + test_output ~location: __LOC__ "empty_map" "Unit" "Unit" "{ Elt \"hello\" \"world\" }" >>=? fun _ -> + + (* Get the value stored at the given key in the map *) + test_output ~location: __LOC__ "get_map_value" "{ Elt \"hello\" \"hi\" }" "\"hello\"" "(Some \"hi\")" >>=? fun _ -> + test_output ~location: __LOC__ "get_map_value" "{ Elt \"hello\" \"hi\" }" "\"\"" "None" >>=? fun _ -> + test_output ~location: __LOC__ "get_map_value" "{ Elt \"1\" \"one\" ; Elt \"2\" \"two\" }" "\"1\"" "(Some \"one\")" >>=? fun _ -> + + (* Map iter *) + test_output ~location: __LOC__ "map_iter" "Unit" "{ Elt 0 100 ; Elt 2 100 }" "(Pair 2 200)" >>=? fun _ -> + test_output ~location: __LOC__ "map_iter" "Unit" "{ Elt 1 1 ; Elt 2 100 }" "(Pair 3 101)" >>=? fun _ -> + + (* Return True if True branch of if was taken and False otherwise *) + test_output ~location: __LOC__ "if" "Unit" "True" "True" >>=? fun _ -> + test_output ~location: __LOC__ "if" "Unit" "False" "False" >>=? fun _ -> + + (* Generate a pair of or types *) + test_output ~location: __LOC__ "swap_left_right" "Unit" "(Left True)" "(Right True)" >>=? fun _ -> + test_output ~location: __LOC__ "swap_left_right" "Unit" "(Right \"a\")" "(Left \"a\")" >>=? fun _ -> + + (* Reverse a list *) + test_output ~location: __LOC__ "reverse" "Unit" "{}" "{}" >>=? fun _ -> + test_output ~location: __LOC__ "reverse" "Unit" "{ \"c\" ; \"b\" ; \"a\" }" "{ \"a\" ; \"b\" ; \"c\" }" >>=? fun _ -> + test_output ~location: __LOC__ "reverse_loop" "Unit" "{}" "{}" >>=? fun _ -> + test_output ~location: __LOC__ "reverse_loop" "Unit" "{ \"c\" ; \"b\" ; \"a\" }" "{ \"a\" ; \"b\" ; \"c\" }" >>=? fun _ -> + + (* Reverse using LOOP_LEFT *) + test_output ~location: __LOC__ "loop_left" "Unit" "{}" "{}" >>=? fun _ -> + test_output ~location: __LOC__ "loop_left" "Unit" "{ \"c\" ; \"b\" ; \"a\" }" "{ \"a\" ; \"b\" ; \"c\" }" >>=? fun _ -> + + (* Exec concat contract *) + test_output ~location: __LOC__ "exec_concat" "Unit" "\"\"" "\"_abc\"" >>=? fun _ -> + test_output ~location: __LOC__ "exec_concat" "Unit" "\"test\"" "\"test_abc\"" >>=? fun _ -> + + (* Get current steps to quota *) + test_output ~location: __LOC__ "steps_to_quota" "Unit" "Unit" "39991" >>=? fun _ -> + + let bootstrap_0 = List.nth Account.bootstrap_accounts 0 in + get_balance_res bootstrap_0 sb >>=?? fun _balance -> + let amount = Proto_alpha.Tezos_context.Tez.to_string @@ Cast.cents_of_int Script.init_amount in + (* Get the current balance of the contract *) + test_output ~location: __LOC__ "balance" "Unit" "Unit" ("\"" ^ amount ^ "\"") >>=? fun _ -> + + (* Test comparisons on tez { EQ ; GT ; LT ; GE ; LE } *) + test_output ~location: __LOC__ "compare" "Unit" "(Pair \"1.00\" \"2.00\")" "{ False ; False ; True ; False ; True }" >>=? fun _ -> + test_output ~location: __LOC__ "compare" "Unit" "(Pair \"2.00\" \"1.00\")" "{ False ; True ; False ; True ; False }" >>=? fun _ -> + test_output ~location: __LOC__ "compare" "Unit" "(Pair \"2.37\" \"2.37\")" "{ True ; False ; False ; True ; True }" >>=? fun _ -> + + (* Test addition and subtraction on tez *) + test_output ~location: __LOC__ "tez_add_sub" "Unit" "(Pair \"2\" \"1\")" "(Pair \"3\" \"1\")" >>=? fun _ -> + test_output ~location: __LOC__ "tez_add_sub" "Unit" "(Pair \"2.31\" \"1.01\")" "(Pair \"3.32\" \"1.3\")" >>=? fun _ -> + + (* Test get first element of list *) + test_output ~location: __LOC__ "first" "Unit" "{ 1 ; 2 ; 3 ; 4 }" "1" >>=? fun _ -> + test_output ~location: __LOC__ "first" "Unit" "{ 4 }" "4" >>=? fun _ -> + + (* Hash input string *) + (* Test assumed to be correct -- hash is based on encoding of AST *) + test_output ~location: __LOC__ "hash_string" "Unit" "\"abcdefg\"" "\"exprv3MnhXvjthGzZ7jDtXRRFremZyey9rsGtL7JRkeaQX1fThN7WF\"" >>=? fun _ -> + test_output ~location: __LOC__ "hash_string" "Unit" "\"12345\"" "\"expru81QVHsW2qaWLNHnMHSxDNhqtat17ajadri6mKUvXyc2EWHZC3\"" >>=? fun _ -> + + (* Test ASSERT *) + test_output ~location: __LOC__ "assert" "Unit" "True" "Unit" >>=? fun _ -> + test_fails ~location: __LOC__ "assert" "Unit" "False" >>=? fun _ -> + + (* COMPARE ; ASSERT_ *) + test_output ~location: __LOC__ "assert_eq" "Unit" "(Pair -1 -1)" "Unit" >>=? fun _ -> + test_fails ~location: __LOC__ "assert_eq" "Unit" "(Pair 0 -1)" >>=? fun _ -> + + test_output ~location: __LOC__ "assert_eq" "Unit" "(Pair -1 -1)" "Unit" >>=? fun _ -> + test_fails ~location: __LOC__ "assert_eq" "Unit" "(Pair 0 -1)" >>=? fun _ -> + + test_output ~location: __LOC__ "assert_neq" "Unit" "(Pair 0 -1)" "Unit" >>=? fun _ -> + test_fails ~location: __LOC__ "assert_neq" "Unit" "(Pair -1 -1)" >>=? fun _ -> + + test_output ~location: __LOC__ "assert_lt" "Unit" "(Pair -1 0)" "Unit" >>=? fun _ -> + test_fails ~location: __LOC__ "assert_lt" "Unit" "(Pair 0 -1)" >>=? fun _ -> + test_fails ~location: __LOC__ "assert_lt" "Unit" "(Pair 0 0)" >>=? fun _ -> + + test_output ~location: __LOC__ "assert_le" "Unit" "(Pair 0 0)" "Unit" >>=? fun _ -> + test_output ~location: __LOC__ "assert_le" "Unit" "(Pair -1 0)" "Unit" >>=? fun _ -> + test_fails ~location: __LOC__ "assert_le" "Unit" "(Pair 0 -1)" >>=? fun _ -> + + test_output ~location: __LOC__ "assert_gt" "Unit" "(Pair 0 -1)" "Unit" >>=? fun _ -> + test_fails ~location: __LOC__ "assert_gt" "Unit" "(Pair -1 0)" >>=? fun _ -> + test_fails ~location: __LOC__ "assert_gt" "Unit" "(Pair 0 0)" >>=? fun _ -> + + test_output ~location: __LOC__ "assert_ge" "Unit" "(Pair 0 0)" "Unit" >>=? fun _ -> + test_output ~location: __LOC__ "assert_ge" "Unit" "(Pair 0 -1)" "Unit" >>=? fun _ -> + test_fails ~location: __LOC__ "assert_ge" "Unit" "(Pair -1 0)" >>=? fun _ -> + + (* ASSERT_CMP *) + test_output ~location: __LOC__ "assert_cmpeq" "Unit" "(Pair -1 -1)" "Unit" >>=? fun _ -> + test_fails ~location: __LOC__ "assert_cmpeq" "Unit" "(Pair 0 -1)" >>=? fun _ -> + + test_output ~location: __LOC__ "assert_cmpeq" "Unit" "(Pair -1 -1)" "Unit" >>=? fun _ -> + test_fails ~location: __LOC__ "assert_cmpeq" "Unit" "(Pair 0 -1)" >>=? fun _ -> + + test_output ~location: __LOC__ "assert_cmpneq" "Unit" "(Pair 0 -1)" "Unit" >>=? fun _ -> + test_fails ~location: __LOC__ "assert_cmpneq" "Unit" "(Pair -1 -1)" >>=? fun _ -> + + test_output ~location: __LOC__ "assert_cmplt" "Unit" "(Pair -1 0)" "Unit" >>=? fun _ -> + test_fails ~location: __LOC__ "assert_cmplt" "Unit" "(Pair 0 -1)" >>=? fun _ -> + test_fails ~location: __LOC__ "assert_cmplt" "Unit" "(Pair 0 0)" >>=? fun _ -> + + test_output ~location: __LOC__ "assert_cmple" "Unit" "(Pair 0 0)" "Unit" >>=? fun _ -> + test_output ~location: __LOC__ "assert_cmple" "Unit" "(Pair -1 0)" "Unit" >>=? fun _ -> + test_fails ~location: __LOC__ "assert_cmple" "Unit" "(Pair 0 -1)" >>=? fun _ -> + + test_output ~location: __LOC__ "assert_cmpgt" "Unit" "(Pair 0 -1)" "Unit" >>=? fun _ -> + test_fails ~location: __LOC__ "assert_cmpgt" "Unit" "(Pair -1 0)" >>=? fun _ -> + test_fails ~location: __LOC__ "assert_cmpgt" "Unit" "(Pair 0 0)" >>=? fun _ -> + + test_output ~location: __LOC__ "assert_cmpge" "Unit" "(Pair 0 0)" "Unit" >>=? fun _ -> + test_output ~location: __LOC__ "assert_cmpge" "Unit" "(Pair 0 -1)" "Unit" >>=? fun _ -> + test_fails ~location: __LOC__ "assert_cmpge" "Unit" "(Pair -1 0)" >>=? fun _ -> + + (* IF_SOME *) + test_output ~location: __LOC__ "if_some" "Unit" "(Some \"hello\")" "\"hello\"" >>=? fun _ -> + test_output ~location: __LOC__ "if_some" "Unit" "None" "\"\"" >>=? fun _ -> + + (* Tests the SET_CAR and SET_CDR instructions *) + test_output ~location: __LOC__ "set_car" "(Pair \"hello\" 0)" "\"world\"" "(Pair \"world\" 0)" >>=? fun _ -> + test_output ~location: __LOC__ "set_car" "(Pair \"hello\" 0)" "\"abc\"" "(Pair \"abc\" 0)" >>=? fun _ -> + test_output ~location: __LOC__ "set_car" "(Pair \"hello\" 0)" "\"\"" "(Pair \"\" 0)" >>=? fun _ -> + + test_output ~location: __LOC__ "set_cdr" "(Pair \"hello\" 0)" "1" "(Pair \"hello\" 1)" >>=? fun _ -> + test_output ~location: __LOC__ "set_cdr" "(Pair \"hello\" 500)" "3" "(Pair \"hello\" 3)" >>=? fun _ -> + test_output ~location: __LOC__ "set_cdr" "(Pair \"hello\" 7)" "100" "(Pair \"hello\" 100)" >>=? fun _ -> + + test_storage ~location: __LOC__ "set_caddaadr" "(Pair (Pair 1 (Pair 2 (Pair (Pair (Pair 3 \"0\") 4) 5))) 6)" "\"3\"" "(Pair (Pair 1 (Pair 2 (Pair (Pair (Pair 3 \"3\") 4) 5))) 6)" >>=? fun _ -> + + test_storage ~location: __LOC__ "map_caddaadr" "(Pair (Pair 1 (Pair 2 (Pair (Pair (Pair 3 \"0\") 4) 5))) 6)" "Unit" "(Pair (Pair 1 (Pair 2 (Pair (Pair (Pair 3 \"1\") 4) 5))) 6)" >>=? fun _ -> + + (* Did the given key sign the string? (key is bootstrap1) *) + test_output ~location: __LOC__ "check_signature" "(Pair \"26981d372a7b3866621bf79713d249197fe6d518ef702fa65738e1715bde9da54df04fefbcc84287ecaa9f74ad9296462731aa24bbcece63c6bf73a8f5752309\" \"hello\")" "\"edpkuBknW28nW72KG6RoHtYW7p12T6GKc7nAbwYX5m8Wd9sDVC9yav\"" "True" >>=? fun _ -> + + test_output ~location: __LOC__ "check_signature" "(Pair \"26981d372a7b3866621bf79713d249197fe6d518ef702fa65738e1715bde9da54df04fefbcc84287ecaa9f74ad9296462731aa24bbcece63c6bf73a8f5752309\" \"abcd\")" "\"edpkuBknW28nW72KG6RoHtYW7p12T6GKc7nAbwYX5m8Wd9sDVC9yav\"" "False" >>=? fun _ -> + + (* Convert a public key to a public key hash *) + test_output ~location: __LOC__ "hash_key" "Unit" "\"edpkuBknW28nW72KG6RoHtYW7p12T6GKc7nAbwYX5m8Wd9sDVC9yav\"" "\"tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx\"" >>=? fun _ -> + test_output ~location: __LOC__ "hash_key" "Unit" "\"edpkuJqtDcA2m2muMxViSM47MPsGQzmyjnNTawUPqR8vZTAMcx61ES\"" "\"tz1XPTDmvT3vVE5Uunngmixm7gj7zmdbPq6k\"" >>=? fun _ -> + + (* Test timestamp operations *) + test_output ~location: __LOC__ "add_timestamp_delta" "Unit" "(Pair 100 100)" "\"1970-01-01T00:03:20Z\"" >>=? fun _ -> + test_output ~location: __LOC__ "add_timestamp_delta" "Unit" "(Pair 100 -100)" "\"1970-01-01T00:00:00Z\"" >>=? fun _ -> + test_output ~location: __LOC__ "add_timestamp_delta" "Unit" "(Pair \"1970-01-01T00:00:00Z\" 0)" "\"1970-01-01T00:00:00Z\"" >>=? fun _ -> + + test_output ~location: __LOC__ "add_delta_timestamp" "Unit" "(Pair 100 100)" "\"1970-01-01T00:03:20Z\"" >>=? fun _ -> + test_output ~location: __LOC__ "add_delta_timestamp" "Unit" "(Pair -100 100)" "\"1970-01-01T00:00:00Z\"" >>=? fun _ -> + test_output ~location: __LOC__ "add_delta_timestamp" "Unit" "(Pair 0 \"1970-01-01T00:00:00Z\")" "\"1970-01-01T00:00:00Z\"" >>=? fun _ -> + + test_output ~location: __LOC__ "sub_timestamp_delta" "Unit" "(Pair 100 100)" "\"1970-01-01T00:00:00Z\"" >>=? fun _ -> + test_output ~location: __LOC__ "sub_timestamp_delta" "Unit" "(Pair 100 -100)" "\"1970-01-01T00:03:20Z\"" >>=? fun _ -> + test_output ~location: __LOC__ "sub_timestamp_delta" "Unit" "(Pair 100 2000000000000000000)" "-1999999999999999900" >>=? fun _ -> + + test_output ~location: __LOC__ "diff_timestamps" "Unit" "(Pair 0 0)" "0" >>=? fun _ -> + test_output ~location: __LOC__ "diff_timestamps" "Unit" "(Pair 0 1)" "-1" >>=? fun _ -> + test_output ~location: __LOC__ "diff_timestamps" "Unit" "(Pair 1 0)" "1" >>=? fun _ -> + test_output ~location: __LOC__ "diff_timestamps" "Unit" "(Pair \"1970-01-01T00:03:20Z\" \"1970-01-01T00:00:00Z\")" "200" >>=? fun _ -> + + (* Test NOW *) + let now = sb.tezos_header.shell.timestamp in + let now_str = quote @@ Tezos_base.Time.to_notation now in + test_storage ~location: __LOC__ "store_now" "\"1970-01-01T00:03:20Z\"" "Unit" now_str >>=? fun _ -> + + (* Test TRANSFER_TO *) + Account.make_account ~tc: sb.tezos_context >>=?? fun (account, tc) -> + let account_str = quote @@ Ed25519.Public_key_hash.to_b58check account.hpub in + test_tc ~tc "transfer_to" "Unit" account_str >>=? fun tc -> + let amount = Account.init_amount + 100 in + Assert.equal_cents_balance ~tc (account.contract, amount * 100) >>=?? fun _ -> + + (* Test CREATE_ACCOUNT *) + Account.make_account ~tc: sb.tezos_context >>=?? fun (account, tc) -> + let account_str = quote @@ Ed25519.Public_key_hash.to_b58check account.hpub in + test_contract ~tc "create_account" account_str account_str >>=? fun (cs, tc) -> + Assert.equal_int 1 @@ List.length cs ; + + (* Test CREATE_CONTRACT *) + test_contract ~tc "create_contract" account_str account_str >>=? fun (cs, tc) -> + Assert.equal_int 1 @@ List.length cs ; + let contract = List.hd cs in + Proto_alpha.Tezos_context.Contract.get_script tc contract >>=?? fun res -> + let script = Option.unopt_exn (Failure "get_script") res in + Script.execute_code_pred ~tc sb script (parse_param "\"abc\"") >>=?? fun (_, ret, _, _, _) -> + Assert.equal_string ~msg: __LOC__ "\"abc\"" @@ string_of_canon ret ; + + (* Test DEFAULT_ACCOUNT *) + let account = Account.new_account () in + let b_str = quote @@ Ed25519.Public_key_hash.to_b58check account.hpub in + test_contract ~tc "default_account" "Unit" b_str >>=? fun (_cs, tc) -> + Assert.equal_cents_balance ~tc (account.contract, 100 * 100) >>=?? fun _ -> + return () + + +let test_program parse_execute = + let open Error_monad in + let id_code = "code + { DUP ; + PAIR ; + CAR }" in + let id_int_program = + program "int" "int" "int" id_code in + let id_ill_param_program = + program "string" "int" "string" id_code in + let id_ill_return_program = + program "int" "string" "int" id_code in + let id_pbool_program = + program "(pair bool bool)" "(pair bool bool)" "unit" id_code in + let push_300_code = "code + { CAR ; + PUSH nat 300 ; + PAIR }" in + let push_300 = + program "unit" "nat" "unit" push_300_code in + parse_execute id_int_program "2" "3" >>=? fun _ -> + parse_execute id_ill_param_program "2" "3" >>= fun x -> + Assert.ill_typed_data_error ~msg: "Good data type" x ; + parse_execute id_ill_return_program "2" "3" >>= fun x -> + Assert.ill_typed_return_error ~msg: "Good return type" x ; + parse_execute push_300 "Unit" "Unit" >>=? fun _ -> + parse_execute id_pbool_program "(Pair True True)" "Unit" >>=? fun _ -> + return () + + +let main (): unit Error_monad.tzresult Lwt.t = + Init.main () >>=? fun sb -> + let execute_code ?tc = Script.execute_code_pred ?tc sb in + let parse_execute ?tc code_str param_str storage_str = + let param = parse_param param_str in + let script = parse_script code_str storage_str in + execute_code ?tc script param >>=?? fun (ret, st, _, tc, nonce) -> + let contracts = Proto_alpha.Tezos_context.Contract.originated_contracts nonce in + return (ret, st, tc, contracts) + in + test_program parse_execute >>=? fun _x -> + test_example parse_execute sb >>=? fun _x -> + return () + + + + +let tests = [ + "main", (fun _ -> main ()) ; +] + +let main () = + Test.run "michelson." tests diff --git a/test/proto_alpha_isolate/test_isolate_origination.ml b/test/proto_alpha_isolate/test_isolate_origination.ml new file mode 100644 index 000000000..db47a018d --- /dev/null +++ b/test/proto_alpha_isolate/test_isolate_origination.ml @@ -0,0 +1,106 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + + +let name = "Isolate Origination" +module Logger = Logging.Make(struct let name = name end) +let section = Lwt_log.Section.make name +let () = + Lwt_log.Section.set_level section Lwt_log.Debug + + +exception No_error + +open Isolate_helpers +let (>>?=) = Assert.(>>?=) +let (>>=??) = Assert.(>>=??) + +let test_simple_origination originate = + let open Proto_alpha.Error_monad in + let src = List.hd Account.bootstrap_accounts in + + (* 0 balance should fail *) + originate src 0 >>= Assert.wrap >>= fun result -> + Assert.initial_amount_too_low ~msg: __LOC__ result ; + + (* .5 Balance should fail *) + originate src 50 >>= Assert.wrap >>= fun result -> + Assert.initial_amount_too_low ~msg: __LOC__ result ; + + (* 2. Balance should work *) + originate src 200 >>= Assert.ok >>= fun _ -> + return () + + +let test_delegation + (originate: ?tc: Proto_alpha.Tezos_context.t -> ?delegatable: bool -> 'a) + (delegate: ?tc: Proto_alpha.Tezos_context.t -> 'b) + = + + let open Proto_alpha.Error_monad in + let account_a = List.nth Account.bootstrap_accounts 0 in + let account_b = List.nth Account.bootstrap_accounts 1 in + + (* Delegatable should change delegate *) + originate + ~delegatable: true account_a 200 + >>=? fun ((contracts, _errs), tc) -> + let contract = List.hd contracts in + let account_ac = {account_a with contract} in + delegate ~tc account_ac account_b.hpub >>= Assert.ok ~msg: __LOC__ >>= fun _ -> + + (* Not-Delegatable should not change delegate *) + originate + ~delegatable: false account_a 200 + >>=? fun ((contracts, _errs), tc) -> + let contract = List.hd contracts in + let account_a = {account_a with contract} in + delegate ~tc account_a account_b.hpub >>= Assert.wrap >>= fun res -> + Assert.non_delegatable ~msg: __LOC__ res ; + + return () + + +let main (): unit Error_monad.tzresult Lwt.t = + + Init.main () >>=? fun root -> + + let originate ?(tc=root.tezos_context) ?baker ?spendable ?fee ?delegatable src amount = + let delegatable = Option.unopt ~default:true delegatable in + let spendable = Option.unopt ~default:true spendable in + let fee = Option.unopt ~default:10 fee in + Apply.origination_pred + ?baker + ~tc + ~pred: root + (src, amount, spendable, delegatable, fee) + in + let delegate ?(tc=root.tezos_context) ?baker ?fee src delegate = + let fee = Option.unopt ~default:10 fee in + Apply.delegation_pred + ?baker + ~tc + ~pred: root + (src, delegate, fee) + in + + test_simple_origination originate >>=?? fun () -> + test_delegation + (originate ?fee: None ?baker: None ~spendable: true) + (delegate ?fee: None ?baker: None) >>=?? fun () -> + + Error_monad.return () + + +let tests = [ + "main", (fun _ -> main ()) ; +] + +let main () = + Test.run "origination." tests diff --git a/test/proto_alpha_isolate/test_isolate_transaction.ml b/test/proto_alpha_isolate/test_isolate_transaction.ml new file mode 100644 index 000000000..3a2fdb524 --- /dev/null +++ b/test/proto_alpha_isolate/test_isolate_transaction.ml @@ -0,0 +1,164 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +let name = "Isolate Transactions" +module Logger = Logging.Make(struct let name = name end) +let section = Lwt_log.Section.make name +let () = + Lwt_log.Section.set_level section Lwt_log.Warning(*.Debug*) +open Logger + +module Helpers = Isolate_helpers +open Helpers +open Proto_alpha.Error_monad + +let test_cycle_transfer (pred: Helpers.Block.result) = + let transfer = Helpers.Apply.transaction_pred ~pred in + let tc = pred.tezos_context in + let cycle n = + Helpers.Account.make_accounts ~tc n >>=? fun (accounts, tc) -> + let pairs = List.combine accounts @@ List.shift accounts in + let aux tc (src, dst) = + transfer ~tc (src, dst, 10000, Some(10)) >>=? fun (_, tc) -> return tc + in + fold_left_s aux tc pairs >>=? fun tc -> + let aux (account: Helpers.Account.t) = + Helpers.Assert.equal_cents_balance ~tc ~msg: __LOC__ (account.contract, Helpers.Account.init_amount * 100 - 10) + in + iter_s aux accounts + in + cycle 2 >>=? fun _ -> + cycle 13 >>=? fun _ -> + cycle 50 >>=? fun _ -> + return () + + + +let run (starting_block: Helpers.Block.result): unit tzresult Lwt.t = + let init_tc = starting_block.tezos_context in + + Helpers.Account.make_2_accounts ~tc: init_tc >>=? fun ((account_a, account_b), init_tc) -> + Helpers.Account.make_account ~tc: init_tc >>=? fun (_baker, init_tc) -> + let account_unknown_foo = Helpers.Account.new_account () in + debug "Accounts set" ; + + let transfer ?(tc=init_tc) ?fee (src, dst, amount) = + Helpers.Apply.transaction_pred + ~tc + ~pred: starting_block + (src, dst, amount, fee) + in + let originate ?(tc=init_tc) = + Helpers.Apply.origination_pred + ~tc + ~pred: starting_block + in + + let init_amount = Helpers.Account.init_amount in + + (* Send from a sender with no balance (never seen). *) + (* TODO: Is it OK to get Storage_error and not something more specific? *) + transfer (account_unknown_foo, account_b, 10000) >|= + Assert.unknown_contract ~msg: __LOC__ >>= fun _ -> + debug "Transfer from no balance V2" ; + + (* Send 10 tz to unknown account. *) + transfer (account_a, account_unknown_foo, 10000) >>= + Assert.ok_contract >>=? fun (_, tc) -> + Assert.equal_cents_balance ~msg: __LOC__ ~tc (account_unknown_foo.contract, 10000) >>=? fun () -> + debug "Reception" ; + + (* Unknown account transfers back tz. *) + transfer ~tc (account_unknown_foo, account_a, 9990) >>= + Assert.ok_contract >>=? fun _ -> + debug "Transfer back" ; + + (* Check that a basic transfer originates no contracts. *) + transfer (account_a, account_b, 1000) >>=? fun ((contracts, _), _) -> + Assert.equal_int ~msg: __LOC__ 0 (List.length contracts) ; + debug "No contracts originated" ; + + (* Check sender/receiver balance post transaction *) + transfer (account_a, account_b, 1000) >>= + Assert.ok_contract ~msg: __LOC__ >>=? fun (_,tc) -> + Proto_alpha.Tezos_context.Contract.get_balance tc account_a.contract >>=? fun _balance -> + Assert.equal_cents_balance ~msg: __LOC__ ~tc (account_a.contract, init_amount * 100 - 1000 - 10) >>=? fun () -> + Assert.equal_cents_balance ~msg: __LOC__ ~tc (account_b.contract, 1001000) >>=? fun () -> + debug "Transfer balances" ; + + (* Check balance too low. *) + transfer (account_a, account_b, 10000000) >|= + Assert.balance_too_low ~msg: __LOC__ >>= fun _ -> + debug "Too low" ; + + (* Check non-spendability of a non-spendable contract *) + (* TODO: Unspecified economic error: should be more specific. *) + originate (account_a, 1000, false, true, 0) + >>= Assert.ok_contract ~msg: __LOC__ >>=? fun ((contracts,_), tc) -> + Assert.equal_int (List.length contracts) 1 ; + let non_spendable = List.hd contracts in + let account = {account_a with contract = non_spendable} in + debug "Contract created" ; + + transfer (account, account_b, 50) ~tc >>= Assert.wrap >>= fun result -> + Assert.non_spendable ~msg: __LOC__ result ; + debug "Non Spendable" ; + + (* Check spendability of a spendable contract *) + originate (account_a, 1000, true, true, 100) + >>= Assert.ok_contract ~msg: __LOC__ >>=? fun ((contracts, _), spendable_tc) -> + Assert.equal_int (List.length contracts) 1 ; + let contract_spendable = List.hd contracts in + let account_spendable = {account_a with contract = contract_spendable} in + debug "Contract created" ; + transfer (account_spendable, account_b, 50) ~tc: spendable_tc >>= Assert.ok ~msg: __LOC__ >>=? fun _ -> + debug "Spendable" ; + + + (* Try spending a default account with unmatching pk/sk pairs. *) + let account = { account_a with ppk = account_b.ppk } in + transfer (account, account_b, 50) + >>= Assert.wrap >>= fun result -> + Assert.generic_economic_error ~msg: __LOC__ result ; + debug "Unmatching keys" ; + + (* Try spending a default account with keys not matching the + contract pkh. *) + let account = {account_a with contract = account_b.contract } in + transfer (account, account_unknown_foo, 50) + >>= Assert.wrap >>= fun result -> + Assert.inconsistent_pkh ~msg: __LOC__ result ; + debug "Unmatching contract" ; + + (* Try spending an originated contract without the manager's key. *) + let account = {account_b with contract = contract_spendable } in + transfer + ~tc: spendable_tc + (account, account_unknown_foo, 50) + >>= Assert.wrap >>= fun result -> + Assert.inconsistent_pkh ~msg: __LOC__ result ; + debug "No manager key" ; + + test_cycle_transfer starting_block >>=? fun _ -> + + return () + + +let main () = + let open Error_monad in + Helpers.Init.main () >>=? fun starting_block -> + run starting_block >>= Assert.wrap + + +let tests = [ + "main", (fun _ -> main ()) ; +] + +let main () = + Test.run "transactions." tests diff --git a/test/proto_alpha_isolate_helpers/helpers_account.ml b/test/proto_alpha_isolate_helpers/helpers_account.ml new file mode 100644 index 000000000..6fa6ad3c0 --- /dev/null +++ b/test/proto_alpha_isolate_helpers/helpers_account.ml @@ -0,0 +1,106 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + + +open Proto_alpha.Error_monad +open Proto_alpha.Tezos_context + +type account = { + hpub : Ed25519.Public_key_hash.t ; + pub : Ed25519.Public_key.t ; + ppk : Ed25519.Secret_key.t ; + contract : Contract.contract +} +type t = account + +let bootstrap_accounts = + let pubs = [ + "edpkuBknW28nW72KG6RoHtYW7p12T6GKc7nAbwYX5m8Wd9sDVC9yav"; + "edpktzNbDAUjUk697W7gYg2CRuBQjyPxbEg8dLccYYwKSKvkPvjtV9"; + "edpkuTXkJDGcFd5nh6VvMz8phXxU3Bi7h6hqgywNFi1vZTfQNnS1RV"; + "edpkuFrRoDSEbJYgxRtLx2ps82UdaYc1WwfS9sE11yhauZt5DgCHbU"; + "edpkv8EUUH68jmo3f7Um5PezmfGrRF24gnfLpH3sVNwJnV5bVCxL2n"; + ] in + let ppks = [ + "edskRuR1azSfboG86YPTyxrQgosh5zChf5bVDmptqLTb5EuXAm9\ + rsnDYfTKhq7rDQujdn5WWzwUMeV3agaZ6J2vPQT58jJAJPi"; + "edskRkJz4Rw2rM5NtabEWMbbg2bF4b1nfFajaqEuEk4SgU7eeDby\ + m9gVQtBTbYo32WUg2zb5sNBkD1whRN7zX43V9bftBbtaKc"; + "edskS3qsqsNgdjUqeMsVcEwBn8dkZ5iDRz6aF21KhcCtRiAkWByp\ + USbicccR4Vgqm9UdW2Vabuos6seezqgbXTrmcbLUG4rdAC"; + "edskRg9qcPqaVQa6jXWNMU5p71tseSuR7NzozgqZ9URsVDi81wTyP\ + JdFSBdeakobyHUi4Xgu61jgKRQvkhXrPmEdEUfiqfiJFL"; + "edskS7rLN2Df3nbS1EYvwJbWo4umD7yPM1SUeX7gp1WhCVpMFXjcC\ + yM58xs6xsnTsVqHQmJQ2RxoAjJGedWfvFmjQy6etA3dgZ"; + ] in + let pubs = List.map Ed25519.Public_key.of_b58check_exn pubs in + let ppks = List.map Ed25519.Secret_key.of_b58check_exn ppks in + let keys = List.combine pubs ppks in + let aux (pub, ppk) : account = + let hpub = Ed25519.Public_key.hash pub in { + pub ; + ppk ; + hpub ; + contract = Contract.default_contract hpub + } + in List.map aux keys + +let new_account () : account = + let (hpub, pub, ppk) = Ed25519.generate_key () in + let contract = Contract.default_contract hpub in + {hpub ; pub ; ppk ; contract} + +let init_amount = 10000 + +let init_account ~(tc : context) account = + Contract.credit + tc + account.contract + @@ Helpers_cast.tez_of_int init_amount + >>=? fun context -> return (account, context) + +let make_account ~(tc : context) = + let account = new_account () in + init_account ~tc account + +let make_accounts ~(tc : context) n = + let rec aux tc n acc = + if (n = 0) then + return (acc, tc) + else + make_account ~tc >>=? fun (account, tc) -> + aux tc (n - 1) @@ account :: acc + in + aux tc n [] + +let make_2_accounts ~(tc : context) = + make_account ~tc >>=? fun (src, tc) -> + make_account ~tc >>=? fun (dst, tc) -> + return ((src, dst), tc) + +let make_4_accounts ~(tc : context) = + make_account ~tc >>=? fun (a, tc) -> + make_account ~tc >>=? fun (b, tc) -> + make_account ~tc >>=? fun (c, tc) -> + make_account ~tc >>=? fun (d, tc) -> + return ((a, b, c, d), tc) + +let display_account ~tc account = + Contract.get_balance tc account.contract >>= function + | Ok balance -> ( + Helpers_logger.lwt_debug + "Account %a : (%a tz)" + Ed25519.Public_key_hash.pp account.hpub + Tez.pp balance + )| Error _ -> Helpers_logger.lwt_debug "Error in balance" + +let display_accounts ~tc accounts = + Helpers_logger.lwt_debug "Got accounts" >>= fun () -> + Lwt_list.iter_s (display_account ~tc) accounts + diff --git a/test/proto_alpha_isolate_helpers/helpers_account.mli b/test/proto_alpha_isolate_helpers/helpers_account.mli new file mode 100644 index 000000000..4e7ff6619 --- /dev/null +++ b/test/proto_alpha_isolate_helpers/helpers_account.mli @@ -0,0 +1,63 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Proto_alpha.Tezos_context + +(** Facilities to deal with accounts , bootstrap accounts and make new + accounts *) + +(** Explicit account type *) +type account = { + hpub : Ed25519.Public_key_hash.t; + pub : Ed25519.Public_key.t; + ppk : Ed25519.Secret_key.t; + contract : + Contract.contract; +} +type t = account + +(** Bootstrap accounts of the sandbox *) +val bootstrap_accounts : account list + +(** Generates a new (pub , ppk) pair and the associated default_contract *) +val new_account : unit -> account + +(** Amount of cents in a new account *) +val init_amount : int + +(** Credits a new account *) +val init_account : + tc:context -> account -> + (account * context) Proto_alpha.tzresult Lwt.t + +(** Generates a new account and credits it *) +val make_account : + tc:context -> + (account * context) Proto_alpha.tzresult Lwt.t + +(** Generates a list of new accounts and credits them *) +val make_accounts : + tc:context -> int -> + (account list * context) Proto_alpha.tzresult Lwt.t + +(** Better typed "make_accounts tc 2" *) +val make_2_accounts : + tc:context -> + ((account * account) * context) Proto_alpha.tzresult Lwt.t + +(** Better typed "make_accounts tc 4" *) +val make_4_accounts : + tc:context -> + ((t * t * t * t) * context) Proto_alpha.tzresult Lwt.t + +(** Debug : Displays an account and its balance *) +val display_account : tc:context -> account -> unit Lwt.t + +(** Debug : Displays several accounts and their balances *) +val display_accounts : tc:context -> account list -> unit Lwt.t diff --git a/test/proto_alpha_isolate_helpers/helpers_apply.ml b/test/proto_alpha_isolate_helpers/helpers_apply.ml new file mode 100644 index 000000000..0d24e0799 --- /dev/null +++ b/test/proto_alpha_isolate_helpers/helpers_apply.ml @@ -0,0 +1,88 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Proto_alpha.Error_monad + +let operation + ~tc ?(baker: Helpers_account.t option) ?(src: Helpers_account.t option) + pred_block_hash op_sh proto_op = + return @@ Helpers_operation.apply_of_proto src op_sh proto_op >>=? fun operation -> + Proto_alpha.Apply.apply_operation + tc + (Option.map ~f:(fun x -> x.Helpers_account.contract) baker) + pred_block_hash + 0 + operation >>=? fun (tc, contracts, err) -> return ((contracts, err), tc) + + +let transaction ~tc ?(fee = 0) ?baker + pbh opsh src (dst: Helpers_account.t) + amount = + Helpers_operation.transaction_full + src dst.contract + (Helpers_cast.cents_of_int amount) + ~fee: (Helpers_cast.cents_of_int fee) + @@ Helpers_cast.ctxt_of_tc tc + >>=? fun protop -> + operation ~tc ?baker ~src pbh opsh protop + + +let transaction_pred ?tc ~(pred: Helpers_block.result) ?baker (src, dst, amount, fee) = + let tc = Option.unopt ~default:pred.tezos_context tc in + let fee = Option.unopt ~default:10 fee in + transaction ~tc ~fee ?baker pred.hash (Helpers_block.get_op_header_res pred) src dst amount + + +let script_origination + ~tc pbh opsh script src amount = + Helpers_operation.script_origination_full + script src (Helpers_cast.cents_of_int amount) @@ Helpers_cast.ctxt_of_tc tc + >>=? fun protop -> operation ~tc ?baker: None ~src pbh opsh protop + + +let origination + ~tc ?baker ?(spendable = true) ?(fee = 0) ?(delegatable = true) + pbh opsh src amount = + Helpers_operation.origination_full + src ~spendable ~delegatable + (Helpers_cast.cents_of_int amount) ~fee:(Helpers_cast.tez_of_int fee) + @@ Helpers_cast.ctxt_of_tc tc + >>=? fun protop -> + operation ~tc ?baker ~src pbh opsh protop + + +let script_origination_pred + ?tc ~(pred: Helpers_block.result) (script, src, amount) = + let tc = Option.unopt ~default:pred.tezos_context tc in + script_origination ~tc pred.hash (Helpers_block.get_op_header_res pred) (Some script) src amount + + +let origination_pred + ?tc ?baker ~(pred: Helpers_block.result) (src, amount, spendable, delegatable, fee) = + let tc = Option.unopt ~default:pred.tezos_context tc in + origination ~tc ?baker ~spendable ~fee ~delegatable + pred.hash + (Helpers_block.get_op_header_res pred) + src amount + + +let delegation ~tc ?baker ?(fee = 0) pbh opsh src delegate = + Helpers_operation.delegation_full + src delegate ~fee:(Helpers_cast.cents_of_int fee) + @@ Helpers_cast.ctxt_of_tc tc + >>=? fun protop -> + operation ~tc ?baker ~src pbh opsh protop + + +let delegation_pred + ?tc ?baker ~(pred: Helpers_block.result) (src, delegate, fee) = + let tc = Option.unopt ~default:pred.tezos_context tc in + delegation ~tc ?baker ~fee pred.hash (Helpers_block.get_op_header_res pred) src delegate + + diff --git a/test/proto_alpha_isolate_helpers/helpers_apply.mli b/test/proto_alpha_isolate_helpers/helpers_apply.mli new file mode 100644 index 000000000..39eba1f27 --- /dev/null +++ b/test/proto_alpha_isolate_helpers/helpers_apply.mli @@ -0,0 +1,57 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(** Functions to build and apply operations *) + +open Proto_alpha.Tezos_context + +val operation : + tc:context -> ?baker:Helpers_account.t -> ?src:Helpers_account.t -> + Block_hash.t -> Tezos_base.Operation.shell_header -> proto_operation -> + ((Contract.contract list * Proto_alpha.error list option) * context) Proto_alpha.tzresult Lwt.t + +val transaction : + tc:context -> ?fee:int -> ?baker:Helpers_account.t -> Block_hash.t -> + Tezos_base.Operation.shell_header -> Helpers_account.t -> Helpers_account.t -> int -> + ((Contract.contract list * Proto_alpha.error list option) * context) Proto_alpha.tzresult Lwt.t + +val transaction_pred : + ?tc:t -> pred:Helpers_block.result -> ?baker:Helpers_account.t -> + Helpers_account.t * Helpers_account.t * int * int option -> + ((Contract.contract list * Proto_alpha.error list option) * context) Proto_alpha.tzresult Lwt.t + +val script_origination : + tc:context -> Block_hash.t -> Tezos_base.Operation.shell_header -> + Script.t option -> Helpers_account.t -> int -> + ((Contract.contract list * Proto_alpha.error list option) * context) Proto_alpha.tzresult Lwt.t + +val origination : + tc:context -> ?baker:Helpers_account.t -> ?spendable:bool -> ?fee:int -> + ?delegatable:bool -> Block_hash.t -> Tezos_base.Operation.shell_header -> + Helpers_account.t -> int -> + ((Contract.contract list * Proto_alpha.error list option) * context) Proto_alpha.tzresult Lwt.t + +val script_origination_pred : + ?tc:t -> pred:Helpers_block.result -> Script.t * Helpers_account.t * int -> + ((Contract.contract list * Proto_alpha.error list option) * context) Proto_alpha.tzresult Lwt.t + +val origination_pred : + ?tc:t -> ?baker:Helpers_account.t -> pred:Helpers_block.result -> + Helpers_account.t * int * bool * bool * int -> + ((Contract.contract list * Proto_alpha.error list option) * context) Proto_alpha.tzresult Lwt.t + +val delegation : + tc:context -> ?baker:Helpers_account.t -> ?fee:int -> Block_hash.t -> + Tezos_base.Operation.shell_header -> Helpers_account.t -> public_key_hash -> + ((Contract.contract list * Proto_alpha.error list option) * context) Proto_alpha.tzresult Lwt.t + +val delegation_pred : + ?tc:t -> ?baker:Helpers_account.t -> pred:Helpers_block.result -> + Helpers_account.t * public_key_hash * int -> + ((Contract.contract list * Proto_alpha.error list option) * context) Proto_alpha.tzresult Lwt.t diff --git a/test/proto_alpha_isolate_helpers/helpers_assert.ml b/test/proto_alpha_isolate_helpers/helpers_assert.ml new file mode 100644 index 000000000..b9d8a2acd --- /dev/null +++ b/test/proto_alpha_isolate_helpers/helpers_assert.ml @@ -0,0 +1,199 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +include Assert + +open Proto_alpha.Tezos_context + +let wrap_result = Proto_alpha.Environment.wrap_error + +let wrap = fun x -> Lwt.return @@ wrap_result x + +let (>>=??) x y = x >>= wrap >>=? y + +let (>>??) x y = wrap_result x >>? y + +let (>>?=) x y = x >>= wrap >>= y + +open Proto_alpha.Error_monad + +let tmp_map f lst = + let rec aux acc = function + | [] -> ok acc + | hd :: tl -> + f hd >>? fun fhd -> (aux (fhd :: acc) tl) + in + aux [] lst + + +let ok ?msg = function + | Ok x -> return x + | Error errs -> + Helpers_logger.log_error "Error : %a" pp @@ List.hd errs ; + Assert.is_true ~msg:(Option.unopt ~default:"not ok" msg) false ; + fail @@ List.hd errs + + +let ok_contract ?msg x = + ok x >>=? fun (((_, errs), _) as x) -> + Assert.is_none ?msg errs ; + return x + + +exception No_error + +let no_error ?msg = function + | Ok x -> x + | Error _ -> + Assert.is_true + ~msg: (Option.unopt ~default:"yes error" msg) + false ; + raise No_error + + +let equal_pkh ?msg pkh1 pkh2 = + let msg = Assert.format_msg msg in + let eq pkh1 pkh2 = + match pkh1, pkh2 with + | None, None -> true + | Some pkh1, Some pkh2 -> + Ed25519.Public_key_hash.equal pkh1 pkh2 + | _ -> false in + let prn = function + | None -> "none" + | Some pkh -> Ed25519.Public_key_hash.to_hex pkh in + Assert.equal ?msg ~prn ~eq pkh1 pkh2 + +let equal_int64 ?msg = + Assert.equal + ~eq: Int64.equal + ~prn: Int64.to_string + ~msg: (Option.unopt ~default:"int64_equal" msg) + + +let equal_int ?msg = + Assert.equal + ~eq: (=) + ~prn: string_of_int + ~msg: (Option.unopt ~default:"int_equal" msg) + + + +let equal_tez ?msg = + Assert.equal + ~eq: Tez .(=) + ~prn: Tez.to_string + ~msg: (Option.unopt ~default:"tez_equal" msg) + + +let equal_balance ~tc ?msg (contract, expected_balance) = + Contract.get_balance tc contract >>=? fun balance -> + return @@ + equal_tez + expected_balance balance + ~msg: (Option.unopt ~default:"balance_equal" msg) + + +let equal_cents_balance ~tc ?msg (contract, cents_balance) = + equal_balance + ~tc + ~msg: (Option.unopt ~default:"equal_cents_balance" msg) + (contract, Helpers_cast.cents_of_int cents_balance) + + +let ecoproto_error f = function + | Proto_alpha.Environment.Ecoproto_error errors -> + List.exists f errors + | _ -> false + + +let generic_economic_error ~msg = + Assert.contain_error ~msg ~f: (ecoproto_error (fun _ -> true)) + +let economic_error ~msg f = + Assert.contain_error ~msg ~f: (ecoproto_error f) + +let ill_typed_data_error ~msg = + let aux = function + | Proto_alpha.Script_ir_translator.Ill_typed_data _ -> true + | _ -> false in + economic_error ~msg aux + +let ill_typed_return_error ~msg = + let aux = function + | Proto_alpha.Script_ir_translator.Bad_return _ -> true + | _ -> false in + economic_error ~msg aux + +let double_endorsement ~msg = + let aux = function + | Proto_alpha.Apply.Duplicate_endorsement(_) -> true + | _ -> false + in + economic_error ~msg aux + +let contain_error_alpha ?msg ~f = function + | Ok _ -> () + | Error errs -> + if (not @@ List.exists f errs) + then Assert.is_true + ~msg:(Option.unopt ~default:"yes error" msg) false + + +let unknown_contract ~msg = + let f = function + | Proto_alpha.Raw_context.Storage_error _ -> true + | _ -> false + in + contain_error_alpha ~msg ~f + + +let non_existing_contract ~msg = + contain_error_alpha ~msg ~f: (function + | Proto_alpha.Contract_storage.Non_existing_contract _ -> true + | _ -> false) + + +let balance_too_low ~msg = + contain_error_alpha ~msg ~f: (function + | Contract.Balance_too_low _ -> true + | _ -> false) + + +let non_spendable ~msg = + Assert.contain_error ~msg ~f: begin ecoproto_error (function + | Proto_alpha.Contract_storage.Unspendable_contract _ -> true + | error -> + Helpers_logger.debug "Actual error: %a" pp error ; + false) + end + +let inconsistent_pkh ~msg = + Assert.contain_error ~msg ~f: begin ecoproto_error (function + | Proto_alpha.Contract_storage.Inconsistent_hash _ -> true + | _ -> false) + end + +let initial_amount_too_low ~msg = + Assert.contain_error ~msg ~f: begin ecoproto_error (function + | Contract.Initial_amount_too_low _ -> true + | _ -> false) + end + +let non_delegatable ~msg = + Assert.contain_error ~msg ~f: begin ecoproto_error (function + | Proto_alpha.Contract_storage.Non_delegatable_contract _ -> true + | _ -> false) + end + +let wrong_delegate ~msg = + Assert.contain_error ~msg ~f: begin ecoproto_error (function + | Proto_alpha.Baking.Wrong_delegate _ -> true + | _ -> false) + end diff --git a/test/proto_alpha_isolate_helpers/helpers_assert.mli b/test/proto_alpha_isolate_helpers/helpers_assert.mli new file mode 100644 index 000000000..fae694687 --- /dev/null +++ b/test/proto_alpha_isolate_helpers/helpers_assert.mli @@ -0,0 +1,81 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Proto_alpha.Tezos_context + +include module type of Assert + +(** Functions capturing common assertion scenarios and error monads helpers *) + +(** Converts a tzresult from the Environment's error monad to a tzresult of the + top level error monad *) +val wrap_result : 'a Proto_alpha.tzresult -> 'a tzresult + +(** Converts a tzresult Lwt.t from the Environment's error monad to a tzresult Lwt.t + of the top level error monad *) +val wrap : 'a Proto_alpha.tzresult -> 'a tzresult Lwt.t + +(** Binds a top level error monad function with an Environment's error monad + tzresult Lwt.t *) +val ( >>=?? ) : + 'a Proto_alpha.tzresult Lwt.t -> ('a -> 'b tzresult Lwt.t) -> 'b tzresult Lwt.t + +(** Binds a top level error monad function with an Environment's error monad + tzresult *) +val ( >>?? ) : 'a Proto_alpha.tzresult -> ('a -> 'b tzresult) -> 'b tzresult + +(** Partially binds a top level error monad function with an Environment's + error monad tzresult *) +val ( >>?= ) : 'a Proto_alpha.tzresult Lwt.t -> ('a tzresult -> 'b Lwt.t) -> 'b Lwt.t + +val tmp_map : ('a -> 'b Proto_alpha.tzresult) -> 'a list -> 'b list Proto_alpha.tzresult + +val ok : ?msg:string -> 'a Proto_alpha.tzresult -> 'a Proto_alpha.tzresult Lwt.t + +val ok_contract : ?msg:string -> + (('a * 'b option) * 'c) Proto_alpha.tzresult -> + (('a * 'b option) * 'c) Proto_alpha.tzresult Lwt.t + +exception No_error + +val no_error : ?msg:string -> ('a, 'b) result -> 'a +val equal_pkh : + ?msg:string -> Ed25519.Public_key_hash.t option -> + Ed25519.Public_key_hash.t option -> unit +val equal_int64 : ?msg:string -> Int64.t -> Int64.t -> unit +val equal_int : ?msg:string -> int -> int -> unit +val equal_tez : ?msg:string -> Tez.t -> Tez.t -> unit +val equal_balance : + tc:context -> ?msg:string -> + Contract.contract * Tez.t -> + unit Proto_alpha.tzresult Lwt.t +val equal_cents_balance : + tc:context -> ?msg:string -> + Contract.contract * int -> + unit Proto_alpha.tzresult Lwt.t +val ecoproto_error : + (Proto_alpha.error -> bool) -> Error_monad.error -> bool + +val generic_economic_error : msg:string -> 'a tzresult -> unit +val economic_error : + msg:string -> (Proto_alpha.error -> bool) -> 'a tzresult -> unit +val ill_typed_data_error : msg:string -> 'a tzresult -> unit +val ill_typed_return_error : msg:string -> 'a tzresult -> unit +val double_endorsement : msg:string -> 'a tzresult -> unit +val contain_error_alpha : + ?msg:string -> f:('a -> bool) -> ('b, 'a list) result -> unit +val unknown_contract : msg:string -> 'a Proto_alpha.tzresult -> unit +val non_existing_contract : msg:string -> 'a Proto_alpha.tzresult -> unit +val balance_too_low : msg:string -> 'a Proto_alpha.tzresult -> unit +val non_spendable : msg:string -> 'a tzresult -> unit +val inconsistent_pkh : msg:string -> 'a tzresult -> unit +val initial_amount_too_low : msg:string -> 'a tzresult -> unit +val non_delegatable : msg:string -> 'a tzresult -> unit +val wrong_delegate : msg:string -> 'a tzresult -> unit + diff --git a/test/proto_alpha_isolate_helpers/helpers_block.ml b/test/proto_alpha_isolate_helpers/helpers_block.ml new file mode 100644 index 000000000..756bcafb9 --- /dev/null +++ b/test/proto_alpha_isolate_helpers/helpers_block.ml @@ -0,0 +1,188 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Proto_alpha.Error_monad + +type shell_header = Block_header.shell_header +type tezos_header = Block_header.t +type protocol_header = Proto_alpha.Tezos_context.Block_header.proto_header +type operation_header = Operation.shell_header + +type init_block = { + pred_block_hash : Block_hash.t ; + pred_shell_header : shell_header ; + proto_header : protocol_header ; + op_header : operation_header ; + sourced_operations : (Proto_alpha.Main.operation * Helpers_account.t) list ; + operation_hashs : Operation_hash.t list ; + proto_header_bytes : MBytes.t ; + timestamp : Time.t ; + level : Int32.t ; + context : Tezos_storage.Context.t +} + +type result = { + tezos_header : tezos_header ; + hash : Block_hash.t ; + level : Int32.t ; + validation : Tezos_protocol_updater.Updater.validation_result ; + tezos_context : Proto_alpha.Tezos_context.t +} + +let get_op_header_res (res : result) : operation_header = { + branch = res.hash +} + +let get_proto_header priority : protocol_header = { + priority ; + proof_of_work_nonce = Helpers_sodium.generate_proof_of_work_nonce (); + seed_nonce_hash = Proto_alpha.Tezos_context.Nonce.hash @@ Helpers_sodium.generate_seed_nonce () +} + +let get_op_header pbh : operation_header = { + branch = pbh +} + + +let make_sourced_operation op_header (proto_operation, source) = + Helpers_operation.main_of_proto source op_header proto_operation >>? fun (a, b) -> + ok ((a, source), b) + + +let init (pred_shell_header : shell_header) pred_block_hash + level priority src_protops context = + let op_header : operation_header = + get_op_header pred_block_hash in + Helpers_assert.tmp_map (make_sourced_operation op_header) src_protops >>? fun src_ops_hashs -> + let (sourced_operations, operation_hashs) = List.split src_ops_hashs in + let proto_header = get_proto_header priority in + let proto_header_bytes = + Proto_alpha.Tezos_context.Block_header.forge_unsigned_proto_header + proto_header + in + let timestamp = + Time.add + pred_shell_header.timestamp + @@ Int64.mul 60L @@ Int64.of_int (priority + 1) + in + ok { + pred_block_hash ; + pred_shell_header ; + proto_header ; + op_header ; + proto_header_bytes ; + sourced_operations ; + operation_hashs ; + timestamp ; + level ; + context + } + + +let init_of_result ?(priority = 15) ~(res : result) ~ops = + init + res.tezos_header.shell + res.hash + res.level + priority + ops + res.validation.context + + +let get_level opt_msg = + let msg = Option.unopt ~default: "level 1" opt_msg in + let parts = String.split_on_char ',' msg in + let level_part = List.hd parts in + let parts = String.split_on_char ' ' level_part in + let level_str = List.nth parts 1 in + Int32.of_int @@ int_of_string level_str + + +let get_header_hash + (init_block : init_block) + (validation_result : Tezos_protocol_updater.Updater.validation_result) + : result tzresult Lwt.t + = + let op_hashs = init_block.operation_hashs in + let hash = Operation_list_list_hash.compute + [Operation_list_hash.compute op_hashs] in + let level = Int32.succ init_block.pred_shell_header.level in + let timestamp = init_block.timestamp in + let shell_header = { + init_block.pred_shell_header with + level ; + predecessor = init_block.pred_block_hash ; + operations_hash = hash ; + timestamp ; + fitness = validation_result.fitness + } in + let tezos_header : tezos_header = { + shell = shell_header ; + proto = init_block.proto_header_bytes + } in + Proto_alpha.Tezos_context.init + validation_result.context + ~level + ~timestamp + ~fitness: validation_result.fitness + >>=? fun tezos_context -> + let hash = Block_header.hash tezos_header in + return { + tezos_header ; + hash ; + validation = validation_result ; + level ; + tezos_context + } + + +let begin_construction_pre (init_block: init_block) = + Proto_alpha.Main.begin_construction + ~predecessor_context: init_block.context + ~predecessor_timestamp: init_block.pred_shell_header.timestamp + ~predecessor_level: init_block.level + ~predecessor_fitness: init_block.pred_shell_header.fitness + ~predecessor: init_block.pred_block_hash + ~timestamp: init_block.timestamp + ~proto_header: init_block.proto_header_bytes + () + + +let make init_block = + let (operations,_) = List.split init_block.sourced_operations in + begin_construction_pre init_block >>=? fun vs -> + Proto_alpha.Error_monad.fold_left_s + Main.apply_operation + vs + operations + >>=? Main.finalize_block >>=? get_header_hash init_block + + +let make_init psh pbh lvl prio ops ctxt = + Lwt.return @@ init psh pbh lvl prio ops ctxt >>=? make + + +let of_res ?priority ?(ops =[]) ~(res: result) () = + Lwt.return @@ init_of_result ?priority ~res ~ops >>=? make + + +let endorsement + psh pbh level priority src ctxt slot = + make_init + psh pbh level priority + [Helpers_operation.endorsement_full src pbh ~slot, src] + ctxt + + +let endorsement_of_res (pred: result) (src: Helpers_account.t) slot = + of_res ~ops: [Helpers_operation.endorsement_full src pred.hash ~slot, src] + + +let empty psh pbh level prio ctxt = + make_init psh pbh level prio [] ctxt diff --git a/test/proto_alpha_isolate_helpers/helpers_block.mli b/test/proto_alpha_isolate_helpers/helpers_block.mli new file mode 100644 index 000000000..f25e1dfc6 --- /dev/null +++ b/test/proto_alpha_isolate_helpers/helpers_block.mli @@ -0,0 +1,81 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(** Representation of blocks independent from the State module *) + +type shell_header = Block_header.shell_header +type tezos_header = Block_header.t +type protocol_header = Tezos_context.Block_header.proto_header +type operation_header = Operation.shell_header + +(** Block before application *) +type init_block = { + pred_block_hash : Block_hash.t; + pred_shell_header : shell_header; + proto_header : protocol_header; + op_header : operation_header; + sourced_operations : + (Main.operation * Helpers_account.t) list; + operation_hashs : Operation_hash.t list; + proto_header_bytes : MBytes.t; + timestamp : Time.t; + level : Int32.t; + context : Tezos_storage.Context.t; +} + +(** Result of the application of a block *) +type result = { + tezos_header : tezos_header; + hash : Block_hash.t; + level : Int32.t; + validation : Tezos_protocol_updater.Updater.validation_result; + tezos_context : Tezos_context.t; +} +val get_op_header_res : result -> operation_header +val get_proto_header : int -> protocol_header +val get_op_header : Block_hash.t -> operation_header +val make_sourced_operation : + Operation.shell_header -> + Tezos_context.proto_operation * + Helpers_account.t -> + ((Proto_alpha.Main.operation * Helpers_account.t) * Operation_hash.t) Proto_alpha.Error_monad.tzresult +val init : + shell_header -> Block_hash.t -> Int32.t -> int -> + (Tezos_context.proto_operation * Helpers_account.t) list -> + Tezos_storage.Context.t -> init_block Proto_alpha.Error_monad.tzresult +val init_of_result : + ?priority:int -> res:result -> + ops:(Tezos_context.proto_operation * Helpers_account.t) list -> + init_block Proto_alpha.Error_monad.tzresult +val get_level : string option -> int32 +val get_header_hash : + init_block -> Tezos_protocol_updater.Updater.validation_result -> + result Proto_alpha.Error_monad.tzresult Lwt.t +val begin_construction_pre : + init_block -> Main.validation_state Proto_alpha.Error_monad.tzresult Lwt.t +val make : init_block -> result Proto_alpha.Error_monad.tzresult Lwt.t +val make_init : + shell_header -> Block_hash.t -> Int32.t -> int -> + (Tezos_context.proto_operation * Helpers_account.t) list -> + Tezos_storage.Context.t -> result Proto_alpha.Error_monad.tzresult Lwt.t +val of_res : + ?priority:int -> + ?ops:(Tezos_context.proto_operation * Helpers_account.t) list -> + res:result -> + unit -> result Proto_alpha.Error_monad.tzresult Lwt.t +val endorsement : + shell_header -> Block_hash.t -> Int32.t -> int -> + Helpers_account.t -> Tezos_storage.Context.t -> int -> + result Proto_alpha.Error_monad.tzresult Lwt.t +val endorsement_of_res : + result -> Helpers_account.t -> int -> ?priority:int -> res:result -> + unit -> result Proto_alpha.Error_monad.tzresult Lwt.t +val empty : + shell_header -> Block_hash.t -> Int32.t -> int -> + Tezos_storage.Context.t -> result Proto_alpha.Error_monad.tzresult Lwt.t diff --git a/test/proto_alpha_isolate_helpers/helpers_cast.ml b/test/proto_alpha_isolate_helpers/helpers_cast.ml new file mode 100644 index 000000000..055a72a7e --- /dev/null +++ b/test/proto_alpha_isolate_helpers/helpers_cast.ml @@ -0,0 +1,40 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Proto_alpha.Tezos_context + +exception Tez_error + +let tez_of_int x = Option.unopt_exn Tez_error @@ ( + match (Tez.( *?) Tez.one (Int64.of_int x)) with + | Error _ -> None + | Ok x -> Some x + ) + +let cents_of_int x = Option.unopt_exn Tez_error @@ ( + match (Tez.( *?) Tez.one_cent (Int64.of_int x)) with + | Error _ -> None + | Ok x -> Some x + ) + +let tez_add x y = match Tez.(+?) x y with + | Ok x -> x + | Error _ -> raise Tez_error + + +let tez_add_int x y = tez_add x @@ tez_of_int y + +let tez_sub x y = match Tez.(-?) x y with + | Ok x -> x + | Error _ -> raise Tez_error + + +let tez_sub_int x y = tez_add x @@ tez_of_int y + +let ctxt_of_tc tc = (finalize tc).context diff --git a/test/proto_alpha_isolate_helpers/helpers_cast.mli b/test/proto_alpha_isolate_helpers/helpers_cast.mli new file mode 100644 index 000000000..17b88b961 --- /dev/null +++ b/test/proto_alpha_isolate_helpers/helpers_cast.mli @@ -0,0 +1,27 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Proto_alpha.Tezos_context + +exception Tez_error + +(** Common casts between Tezos_context types *) + +val tez_of_int : int -> Tez.tez +val cents_of_int : int -> Tez.tez + +(** Tez.(+?) with a top - level error instead *) +val tez_add : Tez.tez -> Tez.tez -> Tez.tez +val tez_add_int : Tez.tez -> int -> Tez.tez + +(** Tez.(-?) with a top - level error instead *) +val tez_sub : Tez.tez -> Tez.tez -> Tez.tez +val tez_sub_int : Tez.tez -> int -> Tez.tez +val ctxt_of_tc : context -> Tezos_storage.Context.t + diff --git a/test/proto_alpha_isolate_helpers/helpers_constants.ml b/test/proto_alpha_isolate_helpers/helpers_constants.ml new file mode 100644 index 000000000..350b9fbfe --- /dev/null +++ b/test/proto_alpha_isolate_helpers/helpers_constants.ml @@ -0,0 +1,32 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Tezos_shell + +let genesis : State.Net.genesis = { + time = + Time.of_notation_exn "2017-09-22T00:00:00Z" ; + block = + Block_hash.of_b58check_exn + "BLockGenesisGenesisGenesisGenesisGenesisCCCCCeZiLHU" ; + protocol = + Protocol_hash.of_b58check_exn + "ProtoGenesisGenesisGenesisGenesisGenesisGenesk612im" ; +} + +let alpha_hash : Tezos_base.TzPervasives.Protocol_hash.t = + Protocol_hash.of_b58check_exn + "ProtoALphaALphaALphaALphaALphaALphaALphaALphaDdp3zK" + +let test_folder = + let home = Sys.getenv "HOME" in + Filename.concat home ".tezos-test" + +let store_root = Filename.concat test_folder "store" +let context_root = Filename.concat test_folder "context" diff --git a/test/proto_alpha_isolate_helpers/helpers_constants.mli b/test/proto_alpha_isolate_helpers/helpers_constants.mli new file mode 100644 index 000000000..a62de44d9 --- /dev/null +++ b/test/proto_alpha_isolate_helpers/helpers_constants.mli @@ -0,0 +1,19 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(** Constants used for testing *) + +val genesis : Tezos_shell.State.Net.genesis +val alpha_hash : Protocol_hash.t + +(** Folder in which the temporary files for testing are put *) +val test_folder : string + +val store_root : string +val context_root : string diff --git a/test/proto_alpha_isolate_helpers/helpers_init.ml b/test/proto_alpha_isolate_helpers/helpers_init.ml new file mode 100644 index 000000000..cdec77ad5 --- /dev/null +++ b/test/proto_alpha_isolate_helpers/helpers_init.ml @@ -0,0 +1,123 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Tezos_shell +open Helpers_logger + +let previous_gs = ref None + +let cleanup () = + ignore @@ Sys.command @@ "rm -rf " ^ Helpers_constants.test_folder + +let get_global_state () = + match !previous_gs with + | Some gs -> + State.Net.all gs >>= fun ls -> + Lwt_list.iter_p (State.Net.destroy gs) ls >>= fun () -> + return gs + | None -> + Lwt.catch ( + fun () -> + State.read + ~store_root: Helpers_constants.store_root + ~context_root: Helpers_constants.context_root + () >>= function + | Ok init_state -> ( + previous_gs := Some init_state ; + Lwt.return @@ Ok init_state + )| Error errors -> ( + lwt_warn "Errors !" >>= fun () -> + lwt_warn "Error when building global state ...%a" pp_print_error errors >>= fun () -> + Lwt.return @@ Error errors + ) + ) (function + | e -> Logger.lwt_warn "Error !" >>= fun () -> + Lwt.fail e + ) + +let get_activation_block baker context_hash head = + let open Tezos_embedded_raw_protocol_genesis in + State.Block.context head >>= fun context -> + Data.Pubkey.set_pubkey context baker.Helpers_account.pub >>= fun context -> + let shell_header = + Helpers_misc.get_block_header + head + Helpers_misc.no_ops_hash + (State.Block.fitness head) + context_hash + (Time.now ()) + in + let fitness = + Tezos_embedded_raw_protocol_alpha.Fitness_repr.from_int64 100L in + let command: Data.Command.t = + Data.Command.Activate({protocol = Helpers_constants.alpha_hash ; validation_passes = 0 ; fitness}) in + let content_bytes = Data.Command.forge shell_header command in + let signature = Ed25519.sign baker.ppk content_bytes in + let proto = (command , signature) in + let proto_bytes = + Data_encoding.Binary.to_bytes + Data.Command.signed_encoding + proto in + let raw_block: Block_header.t = { + shell = shell_header ; + proto = proto_bytes + } in + return (context , raw_block) + +let get_alpha () = + get_global_state () >>=? fun global_state -> + State.Net.create global_state Helpers_constants.genesis >>= fun state -> + Tezos_shell.Chain.head state >>= fun head -> + let baker = Helpers_account.new_account () in + let rec attempt context_hash = + begin + get_activation_block baker context_hash head >>=? fun (context , raw_block) -> + Tezos_storage.Context.get_protocol context >>= fun protocol_hash -> + let (module Protocol) = Helpers_misc.get_protocol protocol_hash in + Protocol.begin_application + ~predecessor_context: context + ~predecessor_timestamp: (State.Block.timestamp head) + ~predecessor_fitness: (State.Block.fitness head) + raw_block + >>=? fun app -> + Protocol.finalize_block app >>=? fun result -> + State.Block.store state raw_block [[]] result >>=? fun opt_block -> + return (opt_block , result) + end >>= function + | Ok v -> return v + | Error [ State.Block.Inconsistent_hash (got , _) ] -> + attempt got + | Error err -> + Error_monad.pp_print_error Format.err_formatter err ; + Lwt.return (Error err) in + attempt Context_hash.zero >>=? fun (opt_block , result) -> + Error_monad.protect (fun () -> return (Option.unopt_exn (Failure "get_alpha") opt_block)) >>=? fun block -> + Tezos_shell.Chain.set_head state block >>= fun _ -> + return (global_state , state , result) + +let get_sandbox () = + Data_encoding_ezjsonm.read_file "test/proto_alpha/sandbox.json" >>= fun x -> + Lwt.return @@ Helpers_assert.no_error ~msg:__LOC__ x + +open Helpers_assert + +let main () = + cleanup () ; + ignore @@ Unix.mkdir Helpers_constants.test_folder 0o777 ; + ignore @@ Unix.mkdir Helpers_constants.store_root 0o777 ; + get_alpha () >>=? fun (_gs, s, r) -> + let context = r.context in + Tezos_shell.Chain.head s >>= fun head -> + let hash = State.Block.hash head in + let block_shell_header = State.Block.shell_header head in + get_sandbox () >>= fun json -> + Main.configure_sandbox context @@ Some json >>=?? fun context -> + Helpers_block.empty block_shell_header hash Int32.zero 0 context >>= Helpers_assert.wrap + +let () = at_exit cleanup diff --git a/test/proto_alpha_isolate_helpers/helpers_init.mli b/test/proto_alpha_isolate_helpers/helpers_init.mli new file mode 100644 index 000000000..51f955955 --- /dev/null +++ b/test/proto_alpha_isolate_helpers/helpers_init.mli @@ -0,0 +1,12 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(** Functions used to build the first tezos_context and first block *) + +val main : unit -> Helpers_block.result tzresult Lwt.t diff --git a/test/proto_alpha_isolate_helpers/helpers_logger.ml b/test/proto_alpha_isolate_helpers/helpers_logger.ml new file mode 100644 index 000000000..104623da9 --- /dev/null +++ b/test/proto_alpha_isolate_helpers/helpers_logger.ml @@ -0,0 +1,16 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions , Inc.< contact@tezos.com > *) +(* *) +(* All rights reserved.No warranty , explicit or implicit , provided. *) +(* *) +(**************************************************************************) + +let name = "Isolate Helpers" +module Logger = Logging.Make(struct let name = name end) +let section = Lwt_log.Section.make name +let () = + Lwt_log.Section.set_level section Lwt_log.Debug + +include Logger diff --git a/test/proto_alpha_isolate_helpers/helpers_logger.mli b/test/proto_alpha_isolate_helpers/helpers_logger.mli new file mode 100644 index 000000000..58b2acebb --- /dev/null +++ b/test/proto_alpha_isolate_helpers/helpers_logger.mli @@ -0,0 +1,12 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions , Inc.< contact@tezos.com > *) +(* *) +(* All rights reserved.No warranty , explicit or implicit , provided. *) +(* *) +(**************************************************************************) + +val name : string +module Logger : Logging.LOG +include Logging.LOG diff --git a/test/proto_alpha_isolate_helpers/helpers_misc.ml b/test/proto_alpha_isolate_helpers/helpers_misc.ml new file mode 100644 index 000000000..3839e3f69 --- /dev/null +++ b/test/proto_alpha_isolate_helpers/helpers_misc.ml @@ -0,0 +1,78 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Tezos_shell + +exception Unknown_protocol + +let no_ops_hash = + Operation_list_list_hash.compute + [Operation_list_hash.empty] + + +let get_protocol hash : (module State.Registred_protocol.T) = + let (module Protocol): (module State.Registred_protocol.T) = + Option.unopt_exn + Unknown_protocol + @@ State.Registred_protocol.get hash + in + (module Protocol) + + +let get_shell_header head = + let shell_header : Operation.shell_header = { + branch = State.Block.hash head + } in + shell_header + + +let get_block_header pred operations_hash fitness context timestamp = + let pred_header = State.Block.header pred in + let pred_hash = State.Block.hash pred in + let shell_header : Block_header.shell_header = { + level = Int32.succ pred_header.shell.level ; + proto_level = 0 ; + predecessor = pred_hash ; + timestamp ; + validation_passes = 1 ; + operations_hash ; + context ; + fitness + } in + shell_header + + +let find_account accounts hpub = + let hpub_pred (x : Helpers_account.t) = + Ed25519.Public_key_hash.equal x.hpub hpub in + List.find hpub_pred accounts + + +let get_dummy_tezos_context context = + Proto_alpha.Tezos_context.init + context + ~level: Int32.one + ~timestamp:(Time.now ()) + ~fitness:([]) + + +let read_file path = + let (//) = Filename.concat in + let executable_path = Sys.getcwd () in + let path = + if Filename.is_relative path + then executable_path // path + else path + in + let ic = open_in path in + let n = in_channel_length ic in + let s = Bytes.create n in + really_input ic s 0 n ; + close_in ic ; + (Bytes.to_string s) diff --git a/test/proto_alpha_isolate_helpers/helpers_misc.mli b/test/proto_alpha_isolate_helpers/helpers_misc.mli new file mode 100644 index 000000000..96d61b70f --- /dev/null +++ b/test/proto_alpha_isolate_helpers/helpers_misc.mli @@ -0,0 +1,29 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Tezos_shell +open Proto_alpha.Tezos_context + +exception Unknown_protocol + +(** Miscellaneous self-descriptive functions *) + +val no_ops_hash : Operation_list_list_hash.t +val get_protocol : Protocol_hash.t -> (module State.Registred_protocol.T) +val get_shell_header : + State.Block.t -> Tezos_base.Operation.shell_header +val get_block_header : + State.Block.t -> Operation_list_list_hash.t -> + Tezos_stdlib.MBytes.t list -> Context_hash.t -> + Tezos_base.Time.t -> Block_header.shell_header +val find_account : Helpers_account.t list -> Ed25519.Public_key_hash.t -> Helpers_account.t +val get_dummy_tezos_context : + Proto_alpha.Environment.Context.t -> Proto_alpha.Tezos_context.context Proto_alpha.Environment.Error_monad.tzresult Lwt.t +val read_file : string -> string + diff --git a/test/proto_alpha_isolate_helpers/helpers_operation.ml b/test/proto_alpha_isolate_helpers/helpers_operation.ml new file mode 100644 index 000000000..d13238472 --- /dev/null +++ b/test/proto_alpha_isolate_helpers/helpers_operation.ml @@ -0,0 +1,137 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Proto_alpha.Tezos_context +open Proto_alpha.Environment.Error_monad + +let sourced ops = Sourced_operations ops + +let manager (src : Helpers_account.t) ?(fee = Tez.zero) operations context = + Helpers_misc.get_dummy_tezos_context context >>=? fun context -> + Contract.get_counter context src.contract >>=? fun counter -> + let counter = Int32.succ counter in + return @@ + Manager_operations { + source = src.contract ; + public_key = Some src.pub ; + fee ; + counter ; + operations + } + + +let manager_full src ?(fee = Tez.zero) ops context = + manager src ~fee ops context >>=? fun ops -> return @@ sourced ops + + +let transaction ?(parameters = None) amount destination = + Transaction { + amount ; + parameters ; + destination + } + + +let origination + ?(delegatable = true) ?(script = None) + ?(spendable = true) ?(delegate = None) + (manager: Helpers_account.t) credit + = + Origination { + manager = manager.hpub ; + delegate ; + spendable ; + delegatable ; + script ; + credit + } + + +let delegation delegate = + Delegation (Some delegate) + + +let delegation_full ?(fee = Tez.zero) src delegate context = + manager_full src ~fee [delegation delegate] context + + +let script_origination_full script src credit context = + manager_full src ~fee: Tez.zero [origination ~script src credit] context + + +let origination_full ?(spendable = true) ?(delegatable = true) ?(fee = Tez.zero) src credit context = + manager_full src ~fee [origination ~spendable ~delegatable src credit] context + + +let transaction_full ?(fee = Tez.zero) src dst amount context = + manager src ~fee [transaction amount dst] context + >>=? fun manager_op -> + return @@ sourced manager_op + + +let delegate (src: Helpers_account.t) operations = + Delegate_operations { + source = src.pub ; + operations + } + + +let endorsement ?(slot = 0) block = + Endorsement { + block ; + slot + } + + +let endorsement_full ?(slot = 0) src block = + sourced + @@ delegate + src + [endorsement block ~slot] + + +let sign src oph protop = + let signature_content = Operation.forge oph protop in + let signature = match src with + | None -> None + | Some(src: Helpers_account.t) -> Some (Ed25519.sign src.ppk signature_content) in + let open Data_encoding in + let signed_proto_operation_encoding = + Data_encoding.merge_objs + Operation.proto_operation_encoding + (obj1 @@ varopt "signature" Ed25519.Signature.encoding) in + let proto_bytes = + Data_encoding.Binary.to_bytes + signed_proto_operation_encoding + (protop, signature) in + (proto_bytes, signature) + + +let main_of_proto (src: Helpers_account.t) operation_header protocol_operation = + let (proto,_) = sign (Some src) operation_header protocol_operation in + let data_operation: Tezos_base.Operation.t = + {shell = operation_header ; proto} in + let hash = Tezos_base.Operation.hash data_operation in + Proto_alpha.Main.parse_operation hash data_operation >>? fun op -> + ok (op, hash) + + +let apply_of_proto + (source: Helpers_account.t option) operation_header protocol_operation = + let (proto, signature) = sign source operation_header protocol_operation in + let data_operation: Tezos_base.Operation.t = + {shell = operation_header ; proto} in + let hash = Tezos_base.Operation.hash data_operation in + { + hash ; + shell = operation_header ; + contents = protocol_operation ; + signature + } + diff --git a/test/proto_alpha_isolate_helpers/helpers_operation.mli b/test/proto_alpha_isolate_helpers/helpers_operation.mli new file mode 100644 index 000000000..5453be960 --- /dev/null +++ b/test/proto_alpha_isolate_helpers/helpers_operation.mli @@ -0,0 +1,71 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Proto_alpha.Tezos_context + +(** Functions building operations *) + +val sourced : sourced_operations -> proto_operation + +val manager : + Helpers_account.t -> ?fee:Tez.tez -> manager_operation list -> + Proto_alpha.Environment.Context.t -> sourced_operations Proto_alpha.tzresult Lwt.t + +val manager_full : + Helpers_account.t -> ?fee:Tez.tez -> manager_operation list -> + Proto_alpha.Environment.Context.t -> proto_operation Proto_alpha.tzresult Lwt.t + +val transaction : + ?parameters:Script.expr option -> Tez.t -> Contract.contract -> + manager_operation + +val origination : + ?delegatable:bool -> ?script:Script.t option -> ?spendable:bool -> + ?delegate:public_key_hash option -> Helpers_account.t -> Tez.t -> manager_operation + +val delegation : public_key_hash -> manager_operation + +val delegation_full : + ?fee:Tez.tez -> Helpers_account.t -> public_key_hash -> Proto_alpha.Environment.Context.t -> + proto_operation Proto_alpha.tzresult Lwt.t + +val script_origination_full : + Script.t option -> Helpers_account.t -> Tez.t -> Proto_alpha.Environment.Context.t -> + proto_operation Proto_alpha.tzresult Lwt.t + +val origination_full : + ?spendable:bool -> ?delegatable:bool -> ?fee:Tez.tez -> + Helpers_account.t -> Tez.t -> Proto_alpha.Environment.Context.t -> + proto_operation Proto_alpha.tzresult Lwt.t + +val transaction_full : + ?fee:Tez.tez -> Helpers_account.t -> Contract.contract -> Tez.t -> + Proto_alpha.Environment.Context.t -> proto_operation Proto_alpha.tzresult Lwt.t + +val delegate : + Helpers_account.t -> delegate_operation list -> sourced_operations + +val endorsement : + ?slot:int -> Block_hash.t -> delegate_operation + +val endorsement_full : + ?slot:int -> Helpers_account.t -> Block_hash.t -> proto_operation + +val sign : + Helpers_account.t option -> Tezos_base.Operation.shell_header -> + proto_operation -> MBytes.t * Ed25519.Signature.t option + +val main_of_proto : + Helpers_account.t -> Tezos_base.Operation.shell_header -> + proto_operation -> (Main.operation * Tezos_base.Operation_hash.t) Proto_alpha.tzresult + +val apply_of_proto : + Helpers_account.t option -> Tezos_base.Operation.shell_header -> + proto_operation -> operation + diff --git a/test/proto_alpha_isolate_helpers/helpers_script.ml b/test/proto_alpha_isolate_helpers/helpers_script.ml new file mode 100644 index 000000000..7fc0a0768 --- /dev/null +++ b/test/proto_alpha_isolate_helpers/helpers_script.ml @@ -0,0 +1,36 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Proto_alpha.Error_monad +open Proto_alpha.Tezos_context + +let init_amount = 20000 + +let execute_code_pred + ?tc (pred : Helpers_block.result) (script : Script.t) (argument : Script.expr) = + let op = List.nth Helpers_account.bootstrap_accounts 0 in + let tc = Option.unopt ~default:pred.tezos_context tc in + Helpers_apply.script_origination_pred ~tc ~pred (script, op, init_amount) + >>=? fun ((dst, _), tc) -> + let dst = List.hd dst in + let ctxt = Helpers_cast.ctxt_of_tc tc in + Helpers_operation.transaction_full op dst Tez.zero ctxt + >>=? fun dummy_protop -> + let op_header = Helpers_block.get_op_header_res pred in + let apply_op = Helpers_operation.apply_of_proto + (Some op) op_header dummy_protop in + let dummy_nonce = Contract.initial_origination_nonce apply_op.hash in + let amount = Tez.zero in + let gaz = Gas.of_int (Tezos_context.Constants.max_gas tc) in + let return = Script_interpreter.execute + dummy_nonce op.contract dst + tc script amount argument gaz in + return + + diff --git a/test/proto_alpha_isolate_helpers/helpers_script.mli b/test/proto_alpha_isolate_helpers/helpers_script.mli new file mode 100644 index 000000000..56aede4c2 --- /dev/null +++ b/test/proto_alpha_isolate_helpers/helpers_script.mli @@ -0,0 +1,17 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Proto_alpha.Tezos_context + +val init_amount : int +val execute_code_pred : + ?tc:Tezos_context.t -> Helpers_block.result -> Script.t -> Script.expr -> + (Script.expr * Script.expr * Gas.t * context * Contract.origination_nonce) + Proto_alpha.tzresult Lwt.t + diff --git a/test/proto_alpha_isolate_helpers/helpers_services.ml b/test/proto_alpha_isolate_helpers/helpers_services.ml new file mode 100644 index 000000000..0e4ee013f --- /dev/null +++ b/test/proto_alpha_isolate_helpers/helpers_services.ml @@ -0,0 +1,23 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Proto_alpha.Tezos_context +open Helpers_assert + +let endorsement_rights ~tc () = + let level = Level.current tc in + Proto_alpha.Services_registration.endorsement_rights tc level None >>=?? fun (_, endorsers) -> + return @@ List.mapi (fun x i -> x, i) endorsers + + +let baking_rights ~tc () = + let level = Level.succ tc @@ Level.current tc in + Proto_alpha.Services_registration.baking_rights tc level None >>=?? fun (_, bakers) -> + return @@ List.mapi (fun x i -> x, i) bakers + diff --git a/test/proto_alpha_isolate_helpers/helpers_services.mli b/test/proto_alpha_isolate_helpers/helpers_services.mli new file mode 100644 index 000000000..8a6cc234a --- /dev/null +++ b/test/proto_alpha_isolate_helpers/helpers_services.mli @@ -0,0 +1,18 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(** Wrappers around Services_registration calls *) + +val endorsement_rights : + tc:Proto_alpha.Tezos_context.context -> unit -> + (int * Tezos_context.public_key_hash) list tzresult Lwt.t + +val baking_rights : + tc:Proto_alpha.Tezos_context.context -> unit -> + (int * Tezos_context.public_key_hash) list tzresult Lwt.t diff --git a/test/proto_alpha_isolate_helpers/helpers_sodium.ml b/test/proto_alpha_isolate_helpers/helpers_sodium.ml new file mode 100644 index 000000000..c5f3cb6f0 --- /dev/null +++ b/test/proto_alpha_isolate_helpers/helpers_sodium.ml @@ -0,0 +1,19 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc.< contact@tezos.com > *) +(* *) +(* All rights reserved.No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Proto_alpha.Tezos_context + +let generate_proof_of_work_nonce () = + Sodium.Random.Bigbytes.generate Constants.proof_of_work_nonce_size + +let generate_seed_nonce () = + match Nonce.of_bytes @@ + Sodium.Random.Bigbytes.generate Constants.nonce_length with + | Error _ -> assert false + | Ok nonce -> nonce diff --git a/test/proto_alpha_isolate_helpers/helpers_sodium.mli b/test/proto_alpha_isolate_helpers/helpers_sodium.mli new file mode 100644 index 000000000..3976054d1 --- /dev/null +++ b/test/proto_alpha_isolate_helpers/helpers_sodium.mli @@ -0,0 +1,13 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc.< contact@tezos.com > *) +(* *) +(* All rights reserved.No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(** Extension of the Sodium module with helpers functions *) + +val generate_proof_of_work_nonce : unit -> MBytes.t +val generate_seed_nonce : unit -> Proto_alpha.Tezos_context.Nonce.nonce diff --git a/test/proto_alpha_isolate_helpers/isolate_helpers.ml b/test/proto_alpha_isolate_helpers/isolate_helpers.ml new file mode 100644 index 000000000..1646b59e1 --- /dev/null +++ b/test/proto_alpha_isolate_helpers/isolate_helpers.ml @@ -0,0 +1,57 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +module Sodium = Helpers_sodium +module Cast = Helpers_cast +module Assert = Helpers_assert +module Services = Helpers_services +module Constants = Helpers_constants +module Account = Helpers_account +module Misc = Helpers_misc +module Operation = Helpers_operation +module Block = Helpers_block +module Init = Helpers_init +module Apply = Helpers_apply +module Script = Helpers_script + +module Shorthands = struct + + let to_tc ctxt = Misc.get_dummy_tezos_context ctxt + + let to_tc_full ctxt level fitness = + Tezos_context.init + ctxt + ~level + ~fitness + ~timestamp:(Time.now()) + + let get_tc (res:Block.result) = + to_tc res.validation.context + + let get_tc_full (res:Block.result) = + Tezos_context.init + res.validation.context + ~level:res.level + ~timestamp:res.tezos_header.shell.timestamp + ~fitness:res.validation.fitness + + let get_balance_res (account:Account.t) (result:Block.result) = + let open Proto_alpha.Error_monad in + get_tc_full result >>=? fun tc -> + Proto_alpha.Tezos_context.Contract.get_balance tc account.contract + + let chain_empty_block (result:Block.result) = + Block.empty + result.tezos_header.shell + result.hash + result.level + 15 + result.validation.context + +end diff --git a/test/proto_alpha_isolate_helpers/jbuild b/test/proto_alpha_isolate_helpers/jbuild new file mode 100644 index 000000000..fd952ef58 --- /dev/null +++ b/test/proto_alpha_isolate_helpers/jbuild @@ -0,0 +1,19 @@ +(jbuild_version 1) + +(library + ((name tezos_proto_alpha_isolate_helpers) + (libraries (kaputt + test_lib + tezos-base + tezos-shell + tezos-embedded-protocol-genesis + tezos-embedded-protocol-alpha)) + (wrapped false) + (flags (:standard -w -9-32 -safe-string + -open Tezos_base__TzPervasives + -open Tezos_embedded_raw_protocol_alpha)))) + +(alias + ((name runtest_indent) + (deps ((glob_files *.ml) (glob_files *.mli))) + (action (run bash ${libexec:tezos-stdlib:test-ocp-indent.sh} ${^})))) diff --git a/test/proto_alpha_isolate_helpers/proto_alpha.ml b/test/proto_alpha_isolate_helpers/proto_alpha.ml new file mode 100644 index 000000000..1bf182dde --- /dev/null +++ b/test/proto_alpha_isolate_helpers/proto_alpha.ml @@ -0,0 +1,5 @@ +include Tezos_embedded_raw_protocol_alpha +module Environment = Tezos_embedded_protocol_environment_alpha.Environment +module Error_monad = Environment.Error_monad +type error = Error_monad.error +type 'a tzresult = 'a Error_monad.tzresult