Update test framework

We now use Kaputt for our tests.
This commit is contained in:
Çağdaş Bozman 2016-09-30 11:43:50 +02:00 committed by Grégoire Henry
parent d0f78a5662
commit 03d37bfdeb
17 changed files with 352 additions and 275 deletions

View File

@ -52,7 +52,7 @@ fi
if [ ! -z "$install" ] ; then
if opam list --installed tezos-deps ; then
opam upgrade $(opam list -s --required-by tezos-deps | grep -ve '^ocaml *$')
opam upgrade $(opam list -s --required-by tezos-deps --test | grep -ve '^ocaml *$')
else
opam install tezos-deps
fi

View File

@ -28,4 +28,5 @@ depends: [
"ocplib-json-typed"
"ocplib-resto" {>= "dev"}
"sodium" {>= "0.3.0"}
"kaputt" {test}
]

View File

@ -20,3 +20,4 @@ B ../src/client/embedded
FLG -w -40
PKG lwt
PKG sodium
PKG kaputt

View File

@ -3,7 +3,7 @@ TESTS := store context state basic basic.sh
all: test
INCLUDES = $(patsubst %, -I %, $(SOURCE_DIRECTORIES))
INCLUDES = $(patsubst %, -I %, $(SOURCE_DIRECTORIES) lib)
OCAMLFLAGS = \
-g -safe-string -w -40 \
${INCLUDES} \
@ -39,7 +39,8 @@ PACKAGES := \
ocplib-json-typed \
ocplib-resto.directory \
sodium \
unix
unix \
kaputt
############################################################################
## External packages
@ -76,8 +77,9 @@ run-test-store:
TEST_STORE_INTFS =
TEST_STORE_IMPLS = \
test.ml \
test_store.ml \
lib/assert.ml \
lib/test.ml \
test_store.ml
${TEST_STORE_IMPLS:.ml=.cmx}: ${NODELIB}
test-store: ${NODELIB} ${TEST_STORE_IMPLS:.ml=.cmx}
@ -98,8 +100,9 @@ run-test-context:
TEST_CONTEXT_INTFS =
TEST_CONTEXT_IMPLS = \
test.ml \
test_context.ml \
lib/assert.ml \
lib/test.ml \
test_context.ml
${TEST_CONTEXT_IMPLS:.ml=.cmx}: ${NODELIB}
test-context: ${NODELIB} ${TEST_CONTEXT_IMPLS:.ml=.cmx}
@ -120,8 +123,9 @@ run-test-state:
TEST_STATE_INTFS =
TEST_STATE_IMPLS = \
test.ml \
test_state.ml \
lib/assert.ml \
lib/test.ml \
test_state.ml
${TEST_STATE_IMPLS:.ml=.cmx}: ${NODELIB}
test-state: ${NODELIB} ../src/proto/embedded_proto_demo.cmxa ${TEST_STATE_IMPLS:.ml=.cmx}
@ -147,8 +151,9 @@ run-test-basic:
TEST_BASIC_INTFS =
TEST_BASIC_IMPLS = \
test.ml \
test_basic.ml \
lib/assert.ml \
lib/test.ml \
test_basic.ml
test-basic \
${TEST_BASIC_IMPLS:.ml=.cmx}: \
@ -180,7 +185,7 @@ clean::
-rm -f *.cm*
-include .depend
.depend: $(wildcard *.ml *.mli)
.depend: $(wildcard *.ml *.mli lib/*.ml lib/*.mli)
ocamldep $^ > .depend
clean::

75
test/lib/assert.ml Normal file
View File

@ -0,0 +1,75 @@
open Kaputt.Abbreviations
include Kaputt.Assertion
let fail_msg fmt =
Format.kasprintf Assert.fail_msg fmt
let fail expected given fmt =
Format.kasprintf (Assert.fail expected given) fmt
let format_msg = function None -> None | Some msg -> Some (msg ^ "\n")
let equal_persist_list ?msg l1 l2 =
let msg = format_msg msg in
let pr_persist l =
let res =
String.concat ";" (List.map (fun s -> Printf.sprintf "%S" s) l) in
Printf.sprintf "[%s]" res in
Assert.make_equal_list ?msg (=) pr_persist l1 l2
let equal_string_option ?msg o1 o2 =
let msg = format_msg msg in
let prn = function
| None -> "None"
| Some s -> s in
Assert.equal ?msg ~prn o1 o2
let equal_error_monad ?msg exn1 exn2 =
let msg = format_msg msg in
let prn exn = match exn with
| Error_monad.Exn err -> Printexc.to_string err
| Error_monad.Unclassified err -> err in
Assert.equal ?msg ~prn exn1 exn2
let equal_block_map ?msg ~eq map1 map2 =
let msg = format_msg msg in
let open Hash in
let module BlockMap = Hash_map(Block_hash) in
Assert.equal ?msg ~eq map1 map2
let equal_operation ?msg op1 op2 =
let msg = format_msg msg in
let eq op1 op2 =
match op1, op2 with
| None, None -> true
| Some (h1, op1), Some (h2, op2) ->
Hash.Operation_hash.equal h1 h2 && op1 = op2
| _ -> false in
let prn = function
| None -> "none"
| Some (h, op) -> Hash.Operation_hash.to_hex h in
Assert.equal ?msg ~prn ~eq op1 op2
let equal_block ?msg st1 st2 =
let msg = format_msg msg in
let eq st1 st2 =
match st1, st2 with
| None, None -> true
| Some (h1, st1), Some (h2, st2) ->
Hash.Block_hash.equal h1 h2 && st1 = st2
| _ -> false in
let prn = function
| None -> "none"
| Some (h, st) -> Hash.Block_hash.to_hex h in
Assert.equal ?msg ~prn ~eq st1 st2
let equal_result ?msg r1 r2 ~equal_ok ~equal_err =
let msg = format_msg msg in
match r1, r2 with
| Ok r1, Ok r2 -> equal_ok ?msg r1 r2
| Error e1, Error e2 -> equal_err ?msg e1 e2
| Ok r, Error e | Error e, Ok r ->
Assert.fail_msg "Results are not the same"

35
test/lib/assert.mli Normal file
View File

@ -0,0 +1,35 @@
include (module type of struct include Kaputt.Assertion end)
val fail_msg : ('a, Format.formatter, unit, 'b) format4 -> 'a
val fail : string -> string -> ('a, Format.formatter, unit, 'b) format4 -> 'a
val equal_persist_list :
?msg:string -> Persist.key list -> Persist.key list -> unit
val equal_string_option : ?msg:string -> string option -> string option -> unit
val equal_error_monad :
?msg:string -> Error_monad.error -> Error_monad.error -> unit
val equal_block_map : ?msg:string -> eq:('a -> 'a -> bool) -> 'a -> 'a -> unit
val equal_operation :
?msg:string ->
(Hash.Operation_hash.t * State.Operation.operation) option ->
(Hash.Operation_hash.t * State.Operation.operation) option ->
unit
val equal_block :
?msg:string ->
(Hash.Block_hash.t * Store.block_header) option ->
(Hash.Block_hash.t * Store.block_header) option ->
unit
val equal_result :
?msg:string ->
('a, 'b) result ->
('a, 'b) result ->
equal_ok:(?msg:string -> 'a -> 'a -> 'c) ->
equal_err:(?msg:string -> 'b -> 'b -> 'c) -> 'c

27
test/lib/test.ml Normal file
View File

@ -0,0 +1,27 @@
open Kaputt.Abbreviations
let keep_dir = try ignore (Sys.getenv "KEEPDIR") ; true with _ -> false
let make_test ~title test =
Test.add_simple_test ~title (fun () -> Lwt_main.run test)
let rec remove_dir dir =
Array.iter (fun file ->
let f = Filename.concat dir file in
if Sys.is_directory f then remove_dir f
else Sys.remove f)
(Sys.readdir dir);
Unix.rmdir dir
let run prefix tests =
let dirs =
List.fold_left (fun dirs (title, f) ->
let base_dir = Filename.temp_file "tezos_test_" "" in
Unix.unlink base_dir;
Unix.mkdir base_dir 0o777;
make_test ~title:(prefix ^ title) (f base_dir);
base_dir :: dirs)
[] tests in
Test.launch_tests ();
if not keep_dir then
List.iter remove_dir dirs

1
test/lib/test.mli Normal file
View File

@ -0,0 +1 @@
val run : string -> (string * (string -> unit Lwt.t)) list -> unit

View File

@ -1,9 +0,0 @@
#! /bin/sh
TESTDIR="$(dirname $0)"
TEZOSDIR="$(dirname $TESTDIR)"
export OCAMLRUNPARAM=b
export LWT_LOG="* -> debug"
opam config --switch 4.01.0 exec -- make -C ${TEZOSDIR} top-parser

View File

@ -1,57 +0,0 @@
let (>>=) = Lwt.bind
let keep_dir = try ignore (Sys.getenv "KEEPDIR") ; true with _ -> false
let () = Printexc.record_backtrace true
(** Helpers for tests *)
let log fmt = Format.eprintf fmt
let fail fmt = Format.kasprintf failwith fmt
let run_test name f =
let base_dir = Filename.temp_file "tezos_test_" "" in
log "---- beginning of test %S in %s ----\n%!" name base_dir ;
Lwt_unix.unlink base_dir >>= fun () ->
Lwt_unix.mkdir base_dir 0o777 >>= fun () ->
Lwt.catch
(fun () -> f base_dir >>= fun () ->
log "[test succeeded]\n%!" ;
Lwt.return (Ok ()))
(function
| Failure msg ->
log "[test FAILED with %s]\n%!" msg ;
Printexc.print_backtrace stderr ;
flush stderr ;
Lwt.return (Error name)
| e ->
log "[test FAILED with exception %s]\n%!" (Printexc.to_string e) ;
Printexc.print_backtrace stderr ;
flush stderr ;
Lwt.return (Error name)) >>= fun r ->
(if not keep_dir then
Utils.remove_dir base_dir
else
Lwt.return_unit) >>= fun () ->
log "---- end of test %S ----\n%!" name ;
Lwt.return r
let run prefix l =
let results =
List.map (fun (name, f) -> Lwt_main.run (run_test (prefix ^ name) f)) l in
let failed =
List.fold_left
(fun acc r ->
match r with
| Ok () -> acc
| Error name -> name :: acc)
[] results in
match failed with
| [] ->
Printf.printf "All tests succeeded\n%!"
| failed ->
Printf.printf "Some tests failed:\n";
List.iter (Printf.printf "- %s\n") failed;
Printf.printf "%!";
exit 1

View File

@ -1,3 +0,0 @@
val log : ('a, Format.formatter, unit) format -> 'a
val fail : ('a, Format.formatter, unit, 'b) format4 -> 'a
val run : string -> (string * (string -> unit Lwt.t)) list -> unit

View File

@ -13,10 +13,8 @@ let should_fail f t =
| Error error ->
if not (List.exists f error) then
failwith "@[<v 2>Unexpected error@ %a@]" pp_print_error error
else begin
Format.printf "-> Failure (as expected)\n%!" ;
else
return ()
end
let fork_node () =
let init_timeout = 4 in
@ -77,16 +75,18 @@ let create_account name =
Lwt.return { name ; contract ; public_key_hash ; public_key ; secret_key }
let transfer ?(block = `Prevalidation) ?(fee = 5L) ~src ~target amount =
Cli_entries.message "Transfer %Ld from %s to %s (fee: %Ld)"
amount src.name target.name fee;
let fee =
match Tez.of_cents fee with
let fee = Tez.of_cents fee in
Assert.is_some ~msg:__LOC__ fee ;
match fee with
| Some x -> x
| None -> assert false in
| None -> assert false in (* will be captured by the previous assert *)
let amount =
match Tez.of_cents amount with
let amount = Tez.of_cents amount in
Assert.is_some ~msg:__LOC__ amount ;
match amount with
| Some x -> x
| None -> assert false in
| None -> assert false in (* will be captured by the previous assert *)
Client_proto_context.transfer
block
~source:src.contract
@ -96,16 +96,11 @@ let transfer ?(block = `Prevalidation) ?(fee = 5L) ~src ~target amount =
~amount ~fee ()
let check_balance ?(block = `Prevalidation) account expected =
Client_proto_rpcs.Context.Contract.balance block account.contract >>=? fun balance ->
Client_proto_rpcs.Context.Contract.balance
block account.contract >>=? fun balance ->
let balance = Tez.to_cents balance in
if balance <> expected then
failwith
"Unexpected balance for %s: %Ld (expected: %Ld)"
account.name balance expected
else begin
Cli_entries.message "Balance for %s: %Ld" account.name balance ;
Assert.equal_int64 ~msg:__LOC__ expected balance ;
return ()
end
let mine contract =
let block = `Head 0 in
@ -114,19 +109,17 @@ let mine contract =
Client_mining_forge.forge_block
~timestamp:(Time.now ()) ~seed_nonce ~src_sk:contract.secret_key
block contract.public_key_hash >>=? fun block_hash ->
Cli_entries.message "Injected %a" Block_hash.pp_short block_hash ;
return ()
let ecoproto_error f = function
| Register_client_embedded_proto_bootstrap.Ecoproto_error errors -> List.exists f errors
| Register_client_embedded_proto_bootstrap.Ecoproto_error errors ->
List.exists f errors
| _ -> false
let main () =
fork_node () ;
bootstrap_accounts () >>= fun bootstrap_accounts ->
let bootstrap = List.hd bootstrap_accounts in
Format.printf "Received bootstrap key %a@."
Ed25519.Public_key_hash.pp_short bootstrap.public_key_hash ;
create_account "foo" >>= fun foo ->
create_account "bar" >>= fun bar ->
transfer ~src:bootstrap ~target:foo 1000_00L >>=? fun () ->
@ -138,17 +131,10 @@ let main () =
should_fail
(ecoproto_error (function Contract.Too_low_balance -> true | _ -> false))
@@ transfer ~src:bar ~target:foo 1000_00L >>=? fun () ->
mine bootstrap >>=? fun () ->
print_endline "\nEnd of test\n" ;
return ()
mine bootstrap
let tests =
[ "main", (fun _ -> main () >>= fun _ -> Lwt.return_unit) ]
let () =
try
Lwt_main.run (
main () >>= function
| Error exns ->
Format.eprintf "%a@." pp_print_error exns ;
exit 1
| Ok () -> Lwt.return_unit)
with Cli_entries.Command_failed msg ->
Format.eprintf "Error: %s@." msg ;
Test.run "basic." tests

View File

@ -1,5 +1,3 @@
open Utils
open Hash
open Context
@ -46,7 +44,7 @@ let faked_block : Store.block_header = {
let create_block2 idx =
checkout idx genesis_block >>= function
| None | Some (Error _) ->
Test.fail "checkout genesis_block"
Assert.fail_msg "checkout genesis_block"
| Some (Ok ctxt) ->
set ctxt ["a"; "b"] (MBytes.of_string "Novembre") >>= fun ctxt ->
set ctxt ["a"; "c"] (MBytes.of_string "Juin") >>= fun ctxt ->
@ -60,7 +58,7 @@ let block3a =
let create_block3a idx =
checkout idx block2 >>= function
| None | Some (Error _) ->
Test.fail "checkout block2"
Assert.fail_msg "checkout block2"
| Some (Ok ctxt) ->
del ctxt ["a"; "b"] >>= fun ctxt ->
set ctxt ["a"; "d"] (MBytes.of_string "Mars") >>= fun ctxt ->
@ -77,7 +75,7 @@ let block3c =
let create_block3b idx =
checkout idx block2 >>= function
| None | Some (Error _) ->
Test.fail "checkout block3b"
Assert.fail_msg "checkout block3b"
| Some (Ok ctxt) ->
del ctxt ["a"; "c"] >>= fun ctxt ->
set ctxt ["a"; "d"] (MBytes.of_string "Février") >>= fun ctxt ->
@ -93,7 +91,6 @@ let wrap_context_init f base_dir =
commit_invalid idx faked_block block3c [Error_monad.Unclassified "TEST"] >>= fun () ->
f idx
(** Simple test *)
let c = function
@ -103,50 +100,50 @@ let c = function
let test_simple idx =
checkout idx block2 >>= function
| None | Some (Error _) ->
Test.fail "checkout block2"
Assert.fail_msg "checkout block2"
| Some (Ok ctxt) ->
get ctxt ["version"] >>= fun version ->
assert (c version = Some "0.0");
Assert.equal_string_option ~msg:__LOC__ (c version) (Some "0.0") ;
get ctxt ["a";"b"] >>= fun novembre ->
assert (c novembre = Some "Novembre");
Assert.equal_string_option (Some "Novembre") (c novembre) ;
get ctxt ["a";"c"] >>= fun juin ->
assert (c juin = Some "Juin");
Assert.equal_string_option ~msg:__LOC__ (Some "Juin") (c juin) ;
Lwt.return ()
let test_continuation idx =
checkout idx block3a >>= function
| None | Some (Error _) ->
Test.fail "checkout block3a"
Assert.fail_msg "checkout block3a"
| Some (Ok ctxt) ->
get ctxt ["version"] >>= fun version ->
assert (c version = Some "0.0");
Assert.equal_string_option ~msg:__LOC__ (Some "0.0") (c version) ;
get ctxt ["a";"b"] >>= fun novembre ->
assert (c novembre = None);
Assert.is_none ~msg:__LOC__ (c novembre) ;
get ctxt ["a";"c"] >>= fun juin ->
assert (c juin = Some "Juin");
Assert.equal_string_option ~msg:__LOC__ (Some "Juin") (c juin) ;
get ctxt ["a";"d"] >>= fun mars ->
assert (c mars = Some "Mars");
Assert.equal_string_option ~msg:__LOC__ (Some "Mars") (c mars) ;
Lwt.return ()
let test_fork idx =
checkout idx block3b >>= function
| None | Some (Error _) ->
Test.fail "checkout block3b"
Assert.fail_msg "checkout block3b"
| Some (Ok ctxt) ->
get ctxt ["version"] >>= fun version ->
assert (c version = Some "0.0");
Assert.equal_string_option ~msg:__LOC__ (Some "0.0") (c version) ;
get ctxt ["a";"b"] >>= fun novembre ->
assert (c novembre = Some "Novembre");
Assert.equal_string_option ~msg:__LOC__ (Some "Novembre") (c novembre) ;
get ctxt ["a";"c"] >>= fun juin ->
assert (c juin = None);
Assert.is_none ~msg:__LOC__ (c juin) ;
get ctxt ["a";"d"] >>= fun mars ->
assert (c mars = Some "Février");
Assert.equal_string_option ~msg:__LOC__ (Some "Février") (c mars) ;
Lwt.return ()
let test_replay idx =
checkout idx genesis_block >>= function
| None | Some (Error _) ->
Test.fail "checkout genesis_block"
Assert.fail_msg "checkout genesis_block"
| Some (Ok ctxt0) ->
set ctxt0 ["version"] (MBytes.of_string "0.0") >>= fun ctxt1 ->
set ctxt1 ["a"; "b"] (MBytes.of_string "Novembre") >>= fun ctxt2 ->
@ -155,21 +152,21 @@ let test_replay idx =
set ctxt3 ["a"; "d"] (MBytes.of_string "Juillet") >>= fun ctxt4b ->
set ctxt4a ["a"; "b"] (MBytes.of_string "November") >>= fun ctxt5a ->
get ctxt4a ["a";"b"] >>= fun novembre ->
assert (c novembre = Some "Novembre");
Assert.equal_string_option ~msg:__LOC__ (Some "Novembre") (c novembre) ;
get ctxt5a ["a";"b"] >>= fun november ->
assert (c november = Some "November");
Assert.equal_string_option ~msg:__LOC__ (Some "November") (c november) ;
get ctxt5a ["a";"d"] >>= fun july ->
assert (c july = Some "July");
Assert.equal_string_option ~msg:__LOC__ (Some "July") (c july) ;
get ctxt4b ["a";"b"] >>= fun novembre ->
assert (c novembre = Some "Novembre");
Assert.equal_string_option ~msg:__LOC__ (Some "Novembre") (c novembre) ;
get ctxt4b ["a";"d"] >>= fun juillet ->
assert (c juillet = Some "Juillet");
Assert.equal_string_option ~msg:__LOC__ (Some "Juillet") (c juillet) ;
Lwt.return ()
let test_list idx =
checkout idx genesis_block >>= function
| None | Some (Error _) ->
Test.fail "checkout genesis_block"
Assert.fail_msg "checkout genesis_block"
| Some (Ok ctxt) ->
set ctxt ["a"; "b"] (MBytes.of_string "Novembre") >>= fun ctxt ->
set ctxt ["a"; "c"] (MBytes.of_string "Juin") >>= fun ctxt ->
@ -177,31 +174,33 @@ let test_list idx =
set ctxt ["f";] (MBytes.of_string "Avril") >>= fun ctxt ->
set ctxt ["g"; "h"] (MBytes.of_string "Avril") >>= fun ctxt ->
list ctxt [[]] >>= fun l ->
assert (l = [["a"];["f"];["g"]]);
Assert.equal_persist_list ~msg:__LOC__ [["a"];["f"];["g"]] l ;
list ctxt [["a"]] >>= fun l ->
assert (l = [["a";"b"]; ["a";"c"]; ["a";"d"]]);
Assert.equal_persist_list
~msg:__LOC__ [["a";"b"]; ["a";"c"]; ["a";"d"]] l ;
list ctxt [["f"]] >>= fun l ->
assert (l = []);
Assert.equal_persist_list ~msg:__LOC__ [] l ;
list ctxt [["g"]] >>= fun l ->
assert (l = [["g";"h"]]);
Assert.equal_persist_list ~msg:__LOC__ [["g";"h"]] l ;
list ctxt [["i"]] >>= fun l ->
assert (l = []);
Assert.equal_persist_list ~msg:__LOC__ [] l ;
list ctxt [["a"];["g"]] >>= fun l ->
assert (l = [["a"; "b"]; ["a"; "c"]; ["a"; "d"]; ["g"; "h"]]);
Assert.equal_persist_list ~msg:__LOC__
[["a"; "b"]; ["a"; "c"]; ["a"; "d"]; ["g"; "h"]] l ;
Lwt.return ()
let test_invalid idx =
checkout idx block3c >>= function
| Some (Error [exn]) ->
assert (exn = Error_monad.Unclassified "TEST") ;
Assert.equal_error_monad
~msg:__LOC__(Error_monad.Unclassified "TEST") exn ;
Lwt.return_unit
| Some (Error _) ->
Test.fail "checkout unexpected error in block3c"
Assert.fail_msg "checkout unexpected error in block3c"
| Some (Ok _) ->
Test.fail "checkout valid block3c"
Assert.fail_msg "checkout valid block3c"
| None ->
Test.fail "checkout absent block3c"
Assert.fail_msg "checkout absent block3c"
(******************************************************************************)
@ -215,5 +214,5 @@ let tests : (string * (index -> unit Lwt.t)) list = [
"invalid", test_invalid ;
]
let res =
let () =
Test.run "context." (List.map (fun (s, f) -> s, wrap_context_init f) tests)

View File

@ -1,6 +1,4 @@
open Utils
open Hash
open Error_monad
@ -31,10 +29,12 @@ let incr_fitness fitness =
let new_fitness =
match fitness with
| [ _ ; fitness ] ->
Pervasives.(
Data_encoding.Binary.of_bytes Data_encoding.int64 fitness
|> Utils.unopt 0L
|> Int64.succ
|> Data_encoding.Binary.to_bytes Data_encoding.int64
)
| _ -> Data_encoding.Binary.to_bytes Data_encoding.int64 1L
in
[ MBytes.of_string "\000" ; new_fitness ]
@ -66,17 +66,17 @@ let build_chain state tbl otbl pred names =
(fun (pred_hash, pred) name ->
begin
let oph, op, bytes = operation name in
State.Operation.store state bytes >>=? fun _changed ->
assert (_changed = Some (oph, op)) ;
State.Operation.mark_invalid state oph [] >>= fun _changed ->
assert _changed;
State.Operation.store state bytes >>=? fun op' ->
Assert.equal_operation ~msg:__LOC__ (Some (oph, op)) op' ;
State.Operation.mark_invalid state oph [] >>= fun state_invalid ->
Assert.is_true ~msg:__LOC__ state_invalid ;
Hashtbl.add otbl name (oph, Error []) ;
let block = block ~operations:[oph] state pred_hash pred name in
let hash = Store.Block.hash block in
State.Block.store state (Store.Block.to_bytes block) >>=? fun _changed ->
assert (_changed = Some (hash, block)) ;
State.Valid_block.store_invalid state hash [] >>= fun _changed ->
assert _changed ;
State.Block.store state (Store.Block.to_bytes block) >>=? fun block' ->
Assert.equal_block ~msg:__LOC__ (Some (hash, block)) block' ;
State.Valid_block.store_invalid state hash [] >>= fun store_invalid ->
Assert.is_true ~msg:__LOC__ store_invalid ;
Hashtbl.add tbl name (hash, block) ;
return (hash, block)
end >>= function
@ -103,15 +103,15 @@ let build_valid_chain state net tbl vtbl otbl pred names =
(fun pred name ->
begin
let oph, op, bytes = operation name in
State.Operation.store state bytes >>=? fun _changed ->
assert (_changed = Some (oph, op)) ;
State.Net.Mempool.add net oph >>= fun _changed ->
assert _changed ;
State.Operation.store state bytes >>=? fun op' ->
Assert.equal_operation ~msg:__LOC__ (Some (oph, op)) op' ;
State.Net.Mempool.add net oph >>= fun add_status ->
Assert.is_true ~msg:__LOC__ add_status ;
Hashtbl.add otbl name (oph, Ok op) ;
let block = block state ~operations:[oph] pred name in
let hash = Store.Block.hash block in
State.Block.store state (Store.Block.to_bytes block) >>=? fun _changed ->
assert (_changed = Some (hash, block)) ;
State.Block.store state (Store.Block.to_bytes block) >>=? fun block' ->
Assert.equal_block ~msg:__LOC__ (Some (hash, block)) block' ;
Hashtbl.add tbl name (hash, block) ;
Lwt.return (Proto.parse_block_header block) >>=? fun block_header ->
Proto.apply pred.context block_header [] >>=? fun ctxt ->
@ -142,11 +142,16 @@ let build_example_tree state net =
build_chain state tbl otbl b7 chain >>= fun () ->
let pending_op = "PP" in
let oph, op, bytes = operation pending_op in
State.Operation.store state bytes >>= fun _changed ->
assert (_changed = Ok (Some (oph, op))) ;
State.Operation.store state bytes >>= fun op' ->
Assert.equal_result
~msg:__LOC__
(Ok (Some (oph, op)))
op'
~equal_ok:Assert.equal_operation
~equal_err:(fun ?msg _ _ -> Assert.fail_msg "Operations differs") ;
Hashtbl.add otbl pending_op (oph, Ok op) ;
State.Net.Mempool.add net oph >>= fun _changed ->
assert _changed ;
State.Net.Mempool.add net oph >>= fun add_status ->
Assert.is_true ~msg:__LOC__ add_status ;
Lwt.return (tbl, vtbl, otbl)
type state = {
@ -172,16 +177,19 @@ let rev_find s h =
with Found s -> s
let blocks s =
Pervasives.(
Hashtbl.fold (fun k v acc -> (k,v) :: acc) s.block []
|> List.sort Pervasives.compare
|> List.sort Pervasives.compare)
let vblocks s =
Pervasives.(
Hashtbl.fold (fun k v acc -> (k,v) :: acc) s.vblock []
|> List.sort Pervasives.compare
|> List.sort Pervasives.compare)
let operations s =
Pervasives.(
Hashtbl.fold (fun k v acc -> (k,v) :: acc) s.operation []
|> List.sort Pervasives.compare
|> List.sort Pervasives.compare)
let wrap_state_init f base_dir =
begin
@ -205,7 +213,7 @@ let wrap_state_init f base_dir =
end >>= function
| Ok () -> Lwt.return_unit
| Error err ->
Test.fail "%a@." Error_monad.pp_print_error err
Lwt.return (Error_monad.pp_print_error Format.err_formatter err)
let save_reload s =
State.shutdown s.state >>= fun () ->
@ -221,10 +229,10 @@ let test_read_operation (s: state) =
Lwt_list.iter_s (fun (name, (oph, op)) ->
State.Operation.read s.state oph >>= function
| None ->
Test.fail "Cannot read block %s" name
Assert.fail_msg "Cannot read block %s" name
| Some { Time.data } ->
if op <> data then
Test.fail "Incorrect operation read %s" name ;
Assert.fail_msg "Incorrect operation read %s" name ;
Lwt.return_unit)
(operations s) >>= fun () ->
return s
@ -240,11 +248,10 @@ let test_read_block (s: state) =
begin
State.Block.read s.state hash >>= function
| None ->
Test.fail "Cannot read block %s" name
Assert.fail_msg "Cannot read block %s" name
| Some { Time.data = block' ; time } ->
if not (Store.Block.equal block block') then
Test.fail "Error while reading block %s" name ;
Test.log "Read block %s %a\n" name Time.pp_hum time;
Assert.fail_msg "Error while reading block %s" name ;
Lwt.return_unit
end >>= fun () ->
let vblock =
@ -252,18 +259,16 @@ let test_read_block (s: state) =
with Not_found -> None in
State.Valid_block.read s.state hash >>= function
| None ->
Test.fail "Cannot read %s" name
Assert.fail_msg "Cannot read %s" name
| Some (Error _) ->
if vblock <> None then
Test.fail "Error while reading valid block %s" name ;
Test.log "Read invalid block %s\n" name ;
Assert.fail_msg "Error while reading valid block %s" name ;
Lwt.return_unit
| Some (Ok _vblock') ->
match vblock with
| None ->
Test.fail "Error while reading invalid block %s" name
Assert.fail_msg "Error while reading invalid block %s" name
| Some _vblock ->
Test.log "Read valid block %s\n" name ;
Lwt.return_unit
) (blocks s) >>= fun () ->
return s
@ -275,20 +280,23 @@ let test_read_block (s: state) =
let compare s kind name succs l =
if Block_hash_set.cardinal succs <> List.length l then
Test.fail "unexpected %ssuccessors size (%s: %d %d)"
Assert.fail_msg
"unexpected %ssuccessors size (%s: %d %d)"
kind name (Block_hash_set.cardinal succs) (List.length l) ;
List.iter
(fun bname ->
let bh = fst @@ block s bname in
if not (Block_hash_set.mem bh succs) then
Test.fail "missing block in %ssuccessors (%s: %s)" kind name bname)
Assert.fail_msg
"missing block in %ssuccessors (%s: %s)" kind name bname)
l
let test_successors s =
let test s name expected invalid_expected =
let b = vblock s name in
State.Valid_block.read s.state b.hash >>= function
| None | Some (Error _) ->
Test.fail "Failed while reading block %s" name
Assert.fail_msg "Failed while reading block %s" name
| Some (Ok { successors ; invalid_successors}) ->
compare s "" name successors expected ;
compare s "invalid " name invalid_successors invalid_expected ;
@ -314,13 +322,13 @@ let rec compare_path p1 p2 = match p1, p2 with
let test_path (s: state) =
let check_path h1 h2 p2 =
Test.log "check_path %s -> %s\n" h1 h2 ;
State.Block.path s.state (fst @@ block s h1) (fst @@ block s h2) >>= function
| Error _ ->
Test.fail "cannot compute path %s -> %s" h1 h2 ;
Assert.fail_msg "cannot compute path %s -> %s" h1 h2
| Ok p1 ->
let p2 = List.map (fun b -> fst (block s b)) p2 in
if not (compare_path p1 p2) then Test.fail "bad path %s -> %s" h1 h2 ;
if not (compare_path p1 p2) then
Assert.fail_msg "bad path %s -> %s" h1 h2 ;
Lwt.return_unit in
check_path "A2" "A6" ["A3"; "A4"; "A5"; "A6"] >>= fun () ->
check_path "B2" "B6" ["B3"; "B4"; "B5"; "B6"] >>= fun () ->
@ -331,14 +339,14 @@ let test_path (s: state) =
let test_valid_path (s: state) =
let check_path h1 h2 p2 =
Test.log "check_path %s -> %s\n" h1 h2 ;
State.Valid_block.path s.state (vblock s h1) (vblock s h2) >>= function
| None ->
Test.fail "cannot compute path %s -> %s" h1 h2 ;
Assert.fail_msg "cannot compute path %s -> %s" h1 h2 ;
| Some (p: State.Valid_block.t list) ->
let p = List.map (fun b -> b.State.Valid_block.hash) p in
let p2 = List.map (fun b -> (vblock s b).hash) p2 in
if not (compare_path p p2) then Test.fail "bad path %s -> %s" h1 h2 ;
if not (compare_path p p2) then
Assert.fail_msg "bad path %s -> %s" h1 h2 ;
Lwt.return_unit in
check_path "A2" "A6" ["A3"; "A4"; "A5"; "A6"] >>= fun () ->
check_path "B2" "B6" ["B3"; "B4"; "B5"; "B6"] >>= fun () ->
@ -355,19 +363,18 @@ let test_ancestor s =
State.Block.common_ancestor
s.state (fst @@ block s h1) (fst @@ block s h2) >>= function
| Error _ ->
Test.fail "Cannot compure ancestor for %s %s" h1 h2
Assert.fail_msg "Cannot compure ancestor for %s %s" h1 h2 ;
| Ok a ->
if not (Block_hash.equal a (fst expected)) then
Test.fail "bad ancestor %s %s: found %s, expected %s"
Assert.fail_msg
"bad ancestor %s %s: found %s, expected %s"
h1 h2 (rev_find s a) (rev_find s @@ fst expected) ;
Test.log "Found the expected ancestor %s %s\n" h1 h2 ;
Lwt.return_unit in
let check_valid_ancestor h1 h2 expected =
State.Valid_block.common_ancestor
s.state (vblock s h1) (vblock s h2) >>= fun a ->
if not (Block_hash.equal a.hash expected.State.Valid_block.hash) then
Test.fail "bad ancestor %s %s" h1 h2 ;
Test.log "Found the expected valid ancestor %s %s\n" h1 h2 ;
Assert.fail_msg "bad ancestor %s %s" h1 h2 ;
Lwt.return_unit in
check_ancestor "A6" "B6" (block s "A3") >>= fun () ->
check_ancestor "B6" "A6" (block s "A3") >>= fun () ->
@ -401,30 +408,31 @@ let test_locator s =
State.Block.block_locator
s.state (List.length expected) (fst @@ block s h1) >>= function
| Error _ ->
Test.fail "Cannot compute locator for %s" h1
Assert.fail_msg "Cannot compute locator for %s" h1
| Ok l ->
if List.length l <> List.length expected then
Test.fail "Invalid locator length %s (found: %d, expected: %d)"
Assert.fail_msg
"Invalid locator length %s (found: %d, expected: %d)"
h1 (List.length l) (List.length expected) ;
List.iter2
(fun h h2 ->
if not (Block_hash.equal h (fst @@ block s h2)) then
Test.fail "Invalid locator %s (expectd: %s)" h1 h2)
Assert.fail_msg "Invalid locator %s (expectd: %s)" h1 h2)
l expected;
Lwt.return_unit in
let check_valid_locator h1 expected =
State.Valid_block.block_locator
s.state (List.length expected) (vblock s h1) >>= fun l ->
if List.length l <> List.length expected then
Test.fail "Invalid locator length %s (found: %d, expected: %d)"
Assert.fail_msg
"Invalid locator length %s (found: %d, expected: %d)"
h1 (List.length l) (List.length expected) ;
List.iter2
(fun h h2 ->
if not (Block_hash.equal h (fst @@ block s h2)) then
Test.fail "Invalid locator %s (expectd: %s)" h1 h2)
Assert.fail_msg "Invalid locator %s (expectd: %s)" h1 h2)
l expected ;
Lwt.return_unit in
Printf.eprintf "Checking Block\n%!" ;
check_locator "A8" ["A8";"A7";"A6";"A5";"A4";"A3";"A2";"A1"] >>= fun () ->
check_locator "B8"
["B8";"B7";"B6";"B5";"B4";"B3";"B2";"B1";"A3"] >>= fun () ->
@ -432,7 +440,6 @@ let test_locator s =
["C8";"C7";"C6";"C5";"C4";"C3";"C2";"C1";
"B7";"B6";"B4";"B2";"A3";"A1"] >>= fun () ->
check_locator "C8" ["C8";"C7";"C6";"C5";"C4"] >>= fun () ->
Printf.eprintf "Checking Valid_block\n%!" ;
check_valid_locator "A8"
["A8";"A7";"A6";"A5";"A4";"A3";"A2"] >>= fun () ->
check_valid_locator "B8"
@ -447,13 +454,14 @@ let test_locator s =
let compare s name heads l =
if Block_hash_map.cardinal heads <> List.length l then
Test.fail "unexpected known_heads size (%s: %d %d)"
Assert.fail_msg
"unexpected known_heads size (%s: %d %d)"
name (Block_hash_map.cardinal heads) (List.length l) ;
List.iter
(fun bname ->
let hash = (vblock s bname).hash in
if not (Block_hash_map.mem hash heads) then
Test.fail "missing block in known_heads (%s: %s)" name bname)
Assert.fail_msg "missing block in known_heads (%s: %s)" name bname)
l
let test_known_heads s =
@ -473,15 +481,15 @@ let test_known_heads s =
let test_head s =
State.Net.Blockchain.head s.net >>= fun head ->
if not (Block_hash.equal head.hash genesis_block) then
Test.fail "unexpected head" ;
Assert.fail_msg "unexpected head" ;
State.Net.Blockchain.set_head s.net (vblock s "A6") >>= fun _ ->
State.Net.Blockchain.head s.net >>= fun head ->
if not (Block_hash.equal head.hash (vblock s "A6").hash) then
Test.fail "unexpected head" ;
Assert.fail_msg "unexpected head" ;
save_reload s >>=? fun s ->
State.Net.Blockchain.head s.net >>= fun head ->
if not (Block_hash.equal head.hash (vblock s "A6").hash) then
Test.fail "unexpected head" ;
Assert.fail_msg "unexpected head" ;
return s
@ -495,11 +503,11 @@ let test_mem s =
let test_mem s x =
mem s x >>= function
| true -> Lwt.return_unit
| false -> Test.fail "mem %s" x in
| false -> Assert.fail_msg "mem %s" x in
let test_not_mem s x =
mem s x >>= function
| false -> Lwt.return_unit
| true -> Test.fail "not (mem %s)" x in
| true -> Assert.fail_msg "not (mem %s)" x in
test_not_mem s "A3" >>= fun () ->
test_not_mem s "A6" >>= fun () ->
test_not_mem s "A8" >>= fun () ->
@ -539,7 +547,7 @@ let test_mem s =
save_reload s >>=? fun s ->
State.Net.Blockchain.head s.net >>= fun head ->
if not (Block_hash.equal head.hash (vblock s "B8").hash) then
Test.fail "Invalid head after save/load" ;
Assert.fail_msg "Invalid head after save/load" ;
return s
@ -552,20 +560,20 @@ let test_new s =
State.Valid_block.block_locator s.state 50 (vblock s h) >>= fun loc ->
State.Net.Blockchain.find_new s.net loc (List.length expected) >>= function
| Error _ ->
Test.fail "Failed to compute new blocks %s" h
Assert.fail_msg "Failed to compute new blocks %s" h
| Ok blocks ->
if List.length blocks <> List.length expected then
Test.fail "Invalid locator length %s (found: %d, expected: %d)"
Assert.fail_msg
"Invalid locator length %s (found: %d, expected: %d)"
h (List.length blocks) (List.length expected) ;
List.iter2
(fun h1 h2 ->
if not (Block_hash.equal h1 (vblock s h2).hash) then
Test.fail "Invalid locator %s (expected: %s)" h h2)
Assert.fail_msg "Invalid locator %s (expected: %s)" h h2)
blocks expected ;
Lwt.return_unit
in
test s "A6" [] >>= fun () ->
Printf.eprintf "Set_head A8.\n%!" ;
State.Net.Blockchain.set_head s.net (vblock s "A8") >>= fun _ ->
test s "A6" ["A7";"A8"] >>= fun () ->
test s "A6" ["A7"] >>= fun () ->
@ -579,14 +587,21 @@ let test_new s =
(** State.mempool *)
let compare s name mempool l =
if Operation_hash_set.cardinal mempool <> List.length l then
Test.fail "unexpected mempool size (%s: %d %d)"
name (Operation_hash_set.cardinal mempool) (List.length l) ;
let mempool_sz = Operation_hash_set.cardinal mempool in
let l_sz = List.length l in
if mempool_sz <> l_sz then
Assert.fail
(string_of_int mempool_sz)
(string_of_int l_sz)
"unexpected mempool size (%s)" name ;
List.iter
(fun oname ->
try
let oph = fst @@ operation s oname in
if not (Operation_hash_set.mem oph mempool) then
Test.fail "missing operation in mempool (%s: %s)" name oname)
Assert.fail_msg "missing operation in mempool (%s: %s)" name oname
with Not_found ->
Assert.fail_msg "Read value not found in mempool (%s: %s)" name oname)
l
let test_mempool s =
@ -611,10 +626,10 @@ let test_mempool s =
["PP";
"A4" ; "A5" ; "A6" ; "A7" ; "A8" ;
"B7" ; "B8" ] ;
State.Net.Mempool.remove s.net (fst @@ operation s "PP") >>= fun _changed ->
assert _changed ;
State.Net.Mempool.remove s.net (fst @@ operation s "PP") >>= fun _changed ->
assert (not _changed) ;
State.Net.Mempool.remove s.net (fst @@ operation s "PP") >>= fun rm_status ->
Assert.is_true ~msg:__LOC__ rm_status ;
State.Net.Mempool.remove s.net (fst @@ operation s "PP") >>= fun rm_status ->
Assert.is_false ~msg:__LOC__ rm_status ;
State.Net.Mempool.get s.net >>= fun mempool ->
compare s "B6.remove" mempool
["A4" ; "A5" ; "A6" ; "A7" ; "A8" ;
@ -649,5 +664,5 @@ let tests : (string * (state -> state tzresult Lwt.t)) list = [
"mempool", test_mempool;
]
let res =
let () =
Test.run "state." (List.map (fun (s, f) -> s, wrap_state_init f) tests)

View File

@ -1,5 +1,4 @@
open Utils
open Hash
open Store
@ -109,16 +108,15 @@ let test_block (s: Store.store) =
let check s k d =
get s k >|= fun d' ->
if d' <> Some d then begin
Test.fail
"Error while reading key %S\n%!"
(String.concat Filename.dir_sep k);
Assert.fail_msg
"Error while reading key %S\n%!" (String.concat Filename.dir_sep k) ;
end
let check_none s k =
get s k >|= function
| None -> ()
| Some _ ->
Test.fail
Assert.fail_msg
"Error while reading non-existent key %S\n%!"
(String.concat Filename.dir_sep k)
@ -139,26 +137,27 @@ let test_generic_list (s: Store.store) =
set s ["f";] (MBytes.of_string "Avril") >>= fun () ->
set s ["g"; "h"] (MBytes.of_string "Avril") >>= fun () ->
list s [] >>= fun l ->
assert (l = []);
Assert.equal_persist_list ~msg:__LOC__ [] l ;
list s [[]] >>= fun l ->
assert (l = [["a"];["f"];["g"];["version"]]);
Assert.equal_persist_list
~msg:__LOC__ [["a"];["f"];["g"];["version"]] l ;
list s [["a"]] >>= fun l ->
assert (l = [["a";"b"]; ["a";"c"]; ["a";"d"]]);
Assert.equal_persist_list
~msg:__LOC__ [["a";"b"]; ["a";"c"]; ["a";"d"]] l ;
list s [["f"]] >>= fun l ->
assert (l = []);
Assert.equal_persist_list ~msg:__LOC__ [] l ;
list s [["g"]] >>= fun l ->
assert (l = [["g";"h"]]);
Assert.equal_persist_list ~msg:__LOC__ [["g";"h"]] l ;
list s [["i"]] >>= fun l ->
assert (l = []);
Assert.equal_persist_list ~msg:__LOC__ [] l ;
list s [["a"];["g"]] >>= fun l ->
assert (l = [["a"; "b"]; ["a"; "c"]; ["a"; "d"]; ["g"; "h"]]);
Assert.equal_persist_list ~msg:__LOC__
[["a"; "b"]; ["a"; "c"]; ["a"; "d"]; ["g"; "h"]] l ;
Lwt.return_unit)
(** HashSet *)
let test_hashset (s: Store.store) =
let test name b =
if b then Lwt.return_unit else Test.fail name in
let module BlockSet = Hash_set(Block_hash) in
let module StoreSet =
Persist.MakeBufferedPersistentSet
@ -168,22 +167,25 @@ let test_hashset (s: Store.store) =
let prefix = [ "test_set" ]
let length = path_len
end)(BlockSet) in
let bhset = BlockSet.empty |> BlockSet.add bh1 |> BlockSet.add bh2 in
let open BlockSet in
let eq = BlockSet.equal in
let bhset : BlockSet.t = BlockSet.add bh2 (BlockSet.add bh1 BlockSet.empty) in
Persist.use s.global_store (fun s ->
StoreSet.write s bhset >>= fun s ->
StoreSet.read s >>= fun bhset' ->
test "init" (BlockSet.compare bhset bhset' = 0) >>= fun () ->
let bhset2 = bhset |> BlockSet.add bh3 |> BlockSet.remove bh1 in
Assert.equal_block_map ~msg:__LOC__ ~eq bhset bhset' ;
let bhset2 =
Pervasives.(bhset |> BlockSet.add bh3 |> BlockSet.remove bh1) in
StoreSet.write s bhset2 >>= fun s ->
StoreSet.read s >>= fun bhset2' ->
test "add/del" (BlockSet.compare bhset2 bhset2' = 0) >>= fun () ->
Assert.equal_block_map ~msg:__LOC__ ~eq bhset2 bhset2' ;
StoreSet.fold s BlockSet.empty
(fun bh acc -> Lwt.return (BlockSet.add bh acc)) >>= fun bhset2'' ->
test "fold" (BlockSet.compare bhset2 bhset2'' = 0) >>= fun () ->
Assert.equal_block_map ~msg:__LOC__ ~eq bhset2 bhset2'' ;
set s ["day";"current"] (MBytes.of_string "Mercredi") >>= fun () ->
StoreSet.clear s >>= fun s ->
StoreSet.read s >>= fun empty ->
test "clean" (BlockSet.compare empty BlockSet.empty = 0) >>= fun () ->
Assert.equal_block_map ~msg:__LOC__ ~eq BlockSet.empty empty ;
check s ["day";"current"] (MBytes.of_string "Mercredi") >>= fun () ->
Lwt.return_unit)
@ -191,8 +193,6 @@ let test_hashset (s: Store.store) =
(** HashMap *)
let test_hashmap (s: Store.store) =
let test name b =
if b then Lwt.return_unit else Test.fail name in
let module BlockMap = Hash_map(Block_hash) in
let module StoreMap =
Persist.MakeBufferedPersistentTypedMap
@ -208,17 +208,19 @@ let test_hashmap (s: Store.store) =
Data_encoding.(tup2 int31 (conv int_of_char char_of_int int8))
end)
(BlockMap) in
let eq = BlockMap.equal (=) in
let map =
BlockMap.empty |> BlockMap.add bh1 (1, 'a') |> BlockMap.add bh2 (2, 'b') in
Pervasives.(BlockMap.empty |>
BlockMap.add bh1 (1, 'a') |> BlockMap.add bh2 (2, 'b')) in
Persist.use s.global_store (fun s ->
StoreMap.write s map >>= fun s ->
StoreMap.read s >>= fun map' ->
test "init" (BlockMap.compare Pervasives.compare map map' = 0) >>= fun () ->
let map2 = map |> BlockMap.add bh3 (3, 'c') |> BlockMap.remove bh1 in
Assert.equal_block_map ~msg:__LOC__ ~eq map map' ;
let map2 =
Pervasives.(map |> BlockMap.add bh3 (3, 'c') |> BlockMap.remove bh1) in
StoreMap.write s map2 >>= fun s ->
StoreMap.read s >>= fun map2' ->
test "add/del"
(BlockMap.compare Pervasives.compare map2 map2' = 0) >>= fun () ->
Assert.equal_block_map ~msg:__LOC__ ~eq map2 map2' ;
Lwt.return_unit)
(** *)
@ -233,6 +235,5 @@ let tests : (string * (store -> unit Lwt.t)) list = [
"hashmap", test_hashmap ;
]
let res =
let () =
Test.run "store." (List.map (fun (s, f) -> s, wrap_store_init f) tests)