From 03d37bfdeba94f673f5e6c6b54b3122cf6a35e7b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=C3=87a=C4=9Fda=C5=9F=20Bozman?= Date: Fri, 30 Sep 2016 11:43:50 +0200 Subject: [PATCH] Update test framework We now use Kaputt for our tests. --- Makefile | 2 +- scripts/install_build_deps.sh | 2 +- src/tezos-deps.opam | 1 + test/.merlin | 3 +- test/Makefile | 27 +++-- test/{ => attic}/test_p2p.ml | 0 test/lib/assert.ml | 75 +++++++++++++ test/lib/assert.mli | 35 ++++++ test/lib/test.ml | 27 +++++ test/lib/test.mli | 1 + test/myocaml-parser | 9 -- test/test.ml | 57 ---------- test/test.mli | 3 - test/test_basic.ml | 54 ++++------ test/test_context.ml | 77 +++++++------- test/test_state.ml | 193 ++++++++++++++++++---------------- test/test_store.ml | 61 +++++------ 17 files changed, 352 insertions(+), 275 deletions(-) rename test/{ => attic}/test_p2p.ml (100%) create mode 100644 test/lib/assert.ml create mode 100644 test/lib/assert.mli create mode 100644 test/lib/test.ml create mode 100644 test/lib/test.mli delete mode 100755 test/myocaml-parser delete mode 100644 test/test.ml delete mode 100644 test/test.mli diff --git a/Makefile b/Makefile index 630033490..8e744c17e 100644 --- a/Makefile +++ b/Makefile @@ -5,7 +5,7 @@ all: clean: ${MAKE} -C src clean -.PHONY:test +.PHONY: test test: ${MAKE} -C test diff --git a/scripts/install_build_deps.sh b/scripts/install_build_deps.sh index b35ad7c42..db0d95dca 100755 --- a/scripts/install_build_deps.sh +++ b/scripts/install_build_deps.sh @@ -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 diff --git a/src/tezos-deps.opam b/src/tezos-deps.opam index b91a76ef4..aa9c8a1a1 100644 --- a/src/tezos-deps.opam +++ b/src/tezos-deps.opam @@ -28,4 +28,5 @@ depends: [ "ocplib-json-typed" "ocplib-resto" {>= "dev"} "sodium" {>= "0.3.0"} + "kaputt" {test} ] diff --git a/test/.merlin b/test/.merlin index eb974a4dc..2c4a878ce 100644 --- a/test/.merlin +++ b/test/.merlin @@ -19,4 +19,5 @@ S ../src/client/embedded B ../src/client/embedded FLG -w -40 PKG lwt -PKG sodium \ No newline at end of file +PKG sodium +PKG kaputt \ No newline at end of file diff --git a/test/Makefile b/test/Makefile index 893f8015a..0f1e02bc8 100644 --- a/test/Makefile +++ b/test/Makefile @@ -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:: diff --git a/test/test_p2p.ml b/test/attic/test_p2p.ml similarity index 100% rename from test/test_p2p.ml rename to test/attic/test_p2p.ml diff --git a/test/lib/assert.ml b/test/lib/assert.ml new file mode 100644 index 000000000..f1576b0e8 --- /dev/null +++ b/test/lib/assert.ml @@ -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" diff --git a/test/lib/assert.mli b/test/lib/assert.mli new file mode 100644 index 000000000..124e35f9d --- /dev/null +++ b/test/lib/assert.mli @@ -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 diff --git a/test/lib/test.ml b/test/lib/test.ml new file mode 100644 index 000000000..416eb1838 --- /dev/null +++ b/test/lib/test.ml @@ -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 diff --git a/test/lib/test.mli b/test/lib/test.mli new file mode 100644 index 000000000..3bbcbc0d4 --- /dev/null +++ b/test/lib/test.mli @@ -0,0 +1 @@ +val run : string -> (string * (string -> unit Lwt.t)) list -> unit diff --git a/test/myocaml-parser b/test/myocaml-parser deleted file mode 100755 index 1fd800768..000000000 --- a/test/myocaml-parser +++ /dev/null @@ -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 diff --git a/test/test.ml b/test/test.ml deleted file mode 100644 index 1aab1716f..000000000 --- a/test/test.ml +++ /dev/null @@ -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 diff --git a/test/test.mli b/test/test.mli deleted file mode 100644 index 2d122e38b..000000000 --- a/test/test.mli +++ /dev/null @@ -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 diff --git a/test/test_basic.ml b/test/test_basic.ml index e024a716c..d7ca51b95 100644 --- a/test/test_basic.ml +++ b/test/test_basic.ml @@ -13,10 +13,8 @@ let should_fail f t = | Error error -> if not (List.exists f error) then failwith "@[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 ; - return () - end + Assert.equal_int64 ~msg:__LOC__ expected balance ; + return () 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 diff --git a/test/test_context.ml b/test/test_context.ml index c177207a9..c6099aa66 100644 --- a/test/test_context.ml +++ b/test/test_context.ml @@ -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) diff --git a/test/test_state.ml b/test/test_state.ml index 791e5ded3..b2af72077 100644 --- a/test/test_state.ml +++ b/test/test_state.ml @@ -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 ] -> - Data_encoding.Binary.of_bytes Data_encoding.int64 fitness - |> Utils.unopt 0L - |> Int64.succ - |> Data_encoding.Binary.to_bytes Data_encoding.int64 + 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 ] @@ -44,8 +44,8 @@ let incr_timestamp timestamp = let operation op = let op : Store.operation = { - shell = { net_id = Net genesis_block } ; - proto = MBytes.of_string op ; + shell = { net_id = Net genesis_block } ; + proto = MBytes.of_string op ; } in Store.Operation.hash op, op, @@ -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 = - Hashtbl.fold (fun k v acc -> (k,v) :: acc) s.block [] - |> List.sort Pervasives.compare + Pervasives.( + Hashtbl.fold (fun k v acc -> (k,v) :: acc) s.block [] + |> List.sort Pervasives.compare) let vblocks s = - Hashtbl.fold (fun k v acc -> (k,v) :: acc) s.vblock [] - |> List.sort Pervasives.compare + Pervasives.( + Hashtbl.fold (fun k v acc -> (k,v) :: acc) s.vblock [] + |> List.sort Pervasives.compare) let operations s = - Hashtbl.fold (fun k v acc -> (k,v) :: acc) s.operation [] - |> List.sort Pervasives.compare + Pervasives.( + Hashtbl.fold (fun k v acc -> (k,v) :: acc) s.operation [] + |> 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" - h1 h2 (rev_find s a) (rev_find s @@ fst expected); - Test.log "Found the expected ancestor %s %s\n" h1 h2 ; + Assert.fail_msg + "bad ancestor %s %s: found %s, expected %s" + h1 h2 (rev_find s a) (rev_find s @@ fst expected) ; 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 + 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 -> - 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) + try + let oph = fst @@ operation s oname in + if not (Operation_hash_set.mem oph mempool) then + 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) diff --git a/test/test_store.ml b/test/test_store.ml index da839c0df..e596a5787 100644 --- a/test/test_store.ml +++ b/test/test_store.ml @@ -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) (** *) @@ -231,8 +233,7 @@ let tests : (string * (store -> unit Lwt.t)) list = [ "generic_list", test_generic_list ; "hashset", test_hashset ; "hashmap", test_hashmap ; - ] +] -let res = +let () = Test.run "store." (List.map (fun (s, f) -> s, wrap_store_init f) tests) -