Update test framework
We now use Kaputt for our tests.
This commit is contained in:
Çağdaş Bozman
Grégoire Henry
parent
d0f78a5662
commit
03d37bfdeb
2
Makefile
2
Makefile
@ -5,7 +5,7 @@ all:
|
||||
clean:
|
||||
${MAKE} -C src clean
|
||||
|
||||
.PHONY:test
|
||||
.PHONY: test
|
||||
test:
|
||||
${MAKE} -C test
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -28,4 +28,5 @@ depends: [
|
||||
"ocplib-json-typed"
|
||||
"ocplib-resto" {>= "dev"}
|
||||
"sodium" {>= "0.3.0"}
|
||||
"kaputt" {test}
|
||||
]
|
||||
|
||||
@ -20,3 +20,4 @@ B ../src/client/embedded
|
||||
FLG -w -40
|
||||
PKG lwt
|
||||
PKG sodium
|
||||
PKG kaputt
|
||||
@ -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
75
test/lib/assert.ml
Normal 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
35
test/lib/assert.mli
Normal 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
27
test/lib/test.ml
Normal 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
1
test/lib/test.mli
Normal file
@ -0,0 +1 @@
|
||||
val run : string -> (string * (string -> unit Lwt.t)) list -> unit
|
||||
@ -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
|
||||
57
test/test.ml
57
test/test.ml
@ -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
|
||||
@ -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
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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"
|
||||
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
|
||||
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)
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user