diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index edceeaa83..1248e311a 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -227,146 +227,151 @@ opam:07:tezos-crypto: variables: package: tezos-crypto -opam:08:tezos-base: - <<: *opam_definition - variables: - package: tezos-base - -opam:09:tezos-protocol-environment-sigs: - <<: *opam_definition - variables: - package: tezos-protocol-environment-sigs - -opam:10:irmin-leveldb: - <<: *opam_definition - variables: - package: irmin-leveldb - -opam:11:tezos-micheline: +opam:08:tezos-micheline: <<: *opam_definition variables: package: tezos-micheline -opam:12:tezos-protocol-compiler: - <<: *opam_definition - variables: - package: tezos-protocol-compiler - -opam:13:tezos-storage: - <<: *opam_definition - variables: - package: tezos-storage - -opam:14:ocplib-resto-cohttp: +opam:09:ocplib-resto-cohttp: <<: *opam_definition variables: package: ocplib-resto-cohttp -opam:15:tezos-p2p: +opam:10:tezos-base: <<: *opam_definition variables: - package: tezos-p2p + package: tezos-base -opam:16:tezos-protocol-updater: +opam:11:irmin-leveldb: <<: *opam_definition variables: - package: tezos-protocol-updater + package: irmin-leveldb -opam:17:tezos-rpc-http: +opam:12:tezos-protocol-environment-sigs: + <<: *opam_definition + variables: + package: tezos-protocol-environment-sigs + +opam:13:tezos-rpc-http: <<: *opam_definition variables: package: tezos-rpc-http -opam:18:tezos-shell-services: +opam:14:tezos-shell-services: <<: *opam_definition variables: package: tezos-shell-services -opam:19:tezos-shell: +opam:15:tezos-storage: <<: *opam_definition variables: - package: tezos-shell + package: tezos-storage -opam:20:tezos-embedded-protocol-alpha: +opam:16:tezos-protocol-compiler: <<: *opam_definition variables: - package: tezos-embedded-protocol-alpha + package: tezos-protocol-compiler -opam:21:tezos-embedded-protocol-demo: - <<: *opam_definition - variables: - package: tezos-embedded-protocol-demo - -opam:22:tezos-embedded-protocol-genesis: - <<: *opam_definition - variables: - package: tezos-embedded-protocol-genesis - -opam:23:tezos-client-base: +opam:17:tezos-client-base: <<: *opam_definition variables: package: tezos-client-base -opam:24:tezos-client-alpha: +opam:18:tezos-protocol-alpha: <<: *opam_definition variables: - package: tezos-client-alpha + package: tezos-protocol-alpha -opam:25:tezos-protocol-environment-client: +opam:19:tezos-protocol-environment-client: <<: *opam_definition variables: package: tezos-protocol-environment-client -opam:26:tezos-protocol-genesis: +opam:20:tezos-p2p: + <<: *opam_definition + variables: + package: tezos-p2p + +opam:21:tezos-protocol-updater: + <<: *opam_definition + variables: + package: tezos-protocol-updater + +opam:22:tezos-client-alpha: + <<: *opam_definition + variables: + package: tezos-client-alpha + +opam:23:tezos-protocol-genesis: <<: *opam_definition variables: package: tezos-protocol-genesis -opam:27:ocplib-resto-json: +opam:24:tezos-shell: + <<: *opam_definition + variables: + package: tezos-shell + +opam:25:ocplib-resto-json: <<: *opam_definition variables: package: ocplib-resto-json -opam:28:tezos-client-genesis: +opam:26:tezos-client-genesis: <<: *opam_definition variables: package: tezos-client-genesis -opam:29:ocplib-ezresto: +opam:27:tezos-embedded-protocol-alpha: + <<: *opam_definition + variables: + package: tezos-embedded-protocol-alpha + +opam:28:tezos-embedded-protocol-demo: + <<: *opam_definition + variables: + package: tezos-embedded-protocol-demo + +opam:29:tezos-embedded-protocol-genesis: + <<: *opam_definition + variables: + package: tezos-embedded-protocol-genesis + +opam:30:ocplib-ezresto: <<: *opam_definition variables: package: ocplib-ezresto -opam:30:tezos-client: +opam:31:tezos-client: <<: *opam_definition variables: package: tezos-client -opam:31:tezos-node: +opam:32:tezos-node: <<: *opam_definition variables: package: tezos-node -opam:32:ocplib-ezresto-directory: +opam:33:tezos-test-helpers: + <<: *opam_definition + variables: + package: tezos-test-helpers + +opam:34:ocplib-ezresto-directory: <<: *opam_definition variables: package: ocplib-ezresto-directory -opam:33:tezos-test: +opam:35:tezos-test: <<: *opam_definition variables: package: tezos-test -opam:34:tezos-protocol-demo: +opam:36:tezos-protocol-demo: <<: *opam_definition variables: package: tezos-protocol-demo -opam:35:tezos-protocol-alpha: - <<: *opam_definition - variables: - package: tezos-protocol-alpha - ##END_OPAM## diff --git a/test/utils/bench_data_encoding.ml b/src/lib_data_encoding/test/bench_data_encoding.ml similarity index 100% rename from test/utils/bench_data_encoding.ml rename to src/lib_data_encoding/test/bench_data_encoding.ml diff --git a/src/lib_data_encoding/test/jbuild b/src/lib_data_encoding/test/jbuild new file mode 100644 index 000000000..058ecd08f --- /dev/null +++ b/src/lib_data_encoding/test/jbuild @@ -0,0 +1,39 @@ +(jbuild_version 1) + +(executables + ((names (test_data_encoding + test_stream_data_encoding + ;; bench_data_encoding + )) + (libraries (tezos-stdlib + tezos_data_encoding + tezos-test-helpers)) + (flags (:standard -w -9-32 -safe-string + -open Tezos_stdlib + -open Tezos_data_encoding + -open Tezos_test_helpers)))) + +(alias + ((name buildtest) + (deps (test_data_encoding.exe + test_stream_data_encoding.exe + ;; bench_data_encoding.exe + )))) + +(alias + ((name runtest_stream_data_encoding) + (action (run ${exe:test_stream_data_encoding.exe})))) + +(alias + ((name runtest_data_encoding) + (action (run ${exe:test_data_encoding.exe})))) + +(alias + ((name runtest) + (deps ((alias runtest_data_encoding) + (alias runtest_stream_data_encoding))))) + +(alias + ((name runtest_indent) + (deps ((glob_files *.ml) (glob_files *.mli))) + (action (run bash ${libexec:tezos-stdlib:test-ocp-indent.sh} ${^})))) diff --git a/test/utils/test_data_encoding.ml b/src/lib_data_encoding/test/test_data_encoding.ml similarity index 94% rename from test/utils/test_data_encoding.ml rename to src/lib_data_encoding/test/test_data_encoding.ml index 0289633c5..e6a13cea5 100644 --- a/test/utils/test_data_encoding.ml +++ b/src/lib_data_encoding/test/test_data_encoding.ml @@ -1,7 +1,22 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Utils.Infix +open Lwt.Infix open Data_encoding -let (>>=) = Lwt.bind -let (>|=) = Lwt.(>|=) +module Error = struct + type error = .. + let pp_print_error _ _ = () +end +module Test = Test.Make(Error) + let (//) = Filename.concat let write_file dir ~name content = @@ -117,6 +132,7 @@ let test_simple_values _ = Lwt.return_unit +(* let test_json testdir = let open Data_encoding_ezjsonm in let file = testdir // "testing_data_encoding.tezos" in @@ -130,7 +146,7 @@ let test_json testdir = read_file file >>= fun opt -> Assert.is_ok ~msg:__LOC__ opt ; Lwt.return () - +*) type t = A of int | B of string | C of int | D of string | E let prn_t = function @@ -256,6 +272,7 @@ let test_splitted _ = Assert.equal ~msg:__LOC__ "44" (get_result ~msg:__LOC__ binB); Lwt.return_unit +(* let test_json_input testdir = let enc = obj1 @@ -318,10 +335,11 @@ let test_json_input testdir = | _ -> false) ; Lwt.return_unit end +*) let wrap_test f base_dir = f base_dir >>= fun result -> - return result + Lwt.return_ok result let test_wrapped_binary _ = let open Data_encoding in @@ -413,10 +431,10 @@ let test_randomized_variant_list _ = let tests = [ "simple", test_simple_values ; - "json", test_json ; + (* "json", test_json ; *) "union", test_union ; "splitted", test_splitted ; - "json.input", test_json_input ; + (* "json.input", test_json_input ; *) "tags", test_tag_errors ; "wrapped_binary", test_wrapped_binary ; "out_of_range", test_out_of_range ; diff --git a/test/utils/test_stream_data_encoding.ml b/src/lib_data_encoding/test/test_stream_data_encoding.ml similarity index 95% rename from test/utils/test_stream_data_encoding.ml rename to src/lib_data_encoding/test/test_stream_data_encoding.ml index 0efdabb57..38eea2baa 100644 --- a/test/utils/test_stream_data_encoding.ml +++ b/src/lib_data_encoding/test/test_stream_data_encoding.ml @@ -1,14 +1,27 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Lwt.Infix open Data_encoding -let (>>=) = Lwt.bind -let (>|=) = Lwt.(>|=) +module Error = struct + type error = .. + let pp_print_error _ _ = () +end +module Test = Test.Make(Error) + let (//) = Filename.concat let is_invalid_arg = function | Invalid_argument _ -> true | _ -> false - let is_await = function Binary.Await _ -> true | _ -> false let is_success = function Binary.Success _ -> true | _ -> false let is_error = function Binary.Error -> true | _ -> false @@ -435,7 +448,7 @@ let test_splitted _ = let wrap_test f base_dir = f base_dir >>= fun result -> - return result + Lwt.return_ok result let tests = [ "simple", test_simple_values ; diff --git a/test/lib/assert.ml b/src/lib_test_helpers/assert.ml similarity index 68% rename from test/lib/assert.ml rename to src/lib_test_helpers/assert.ml index 696bbe80e..2d1da5905 100644 --- a/test/lib/assert.ml +++ b/src/lib_test_helpers/assert.ml @@ -17,13 +17,6 @@ let is_error ?(msg="") = function | Error _ -> () | Ok _ -> fail "Error _" "Ok _" msg -let contain_error ?(msg="") ~f = function - | Ok _ -> fail "Error _" "Ok _" msg - | Error error when not (List.exists f error) -> - let error_str = Format.asprintf "%a" pp_print_error error in - fail "" error_str msg - | _ -> () - let is_ok ?(msg="") = function | Ok _ -> () | Error _ -> fail "Ok _" "Error _" msg @@ -36,11 +29,6 @@ let equal_string_list_list ?msg l1 l2 = Printf.sprintf "[%s]" res in Assert.make_equal_list ?msg (=) pr_persist l1 l2 -let equal_block_hash_list ?msg l1 l2 = - let msg = format_msg msg in - let pr_block_hash = Block_hash.to_short_b58check in - Assert.make_equal_list ?msg Block_hash.equal pr_block_hash l1 l2 - let equal_string_list ?msg l1 l2 = let msg = format_msg msg in Assert.make_equal_list ?msg (=) (fun x -> x) l1 l2 @@ -52,29 +40,6 @@ let equal_string_option ?msg o1 o2 = | 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 err = Format.asprintf "%a" Error_monad.pp_print_error [err] in - Assert.equal ?msg ~prn exn1 exn2 - -let equal_block_set ?msg set1 set2 = - let msg = format_msg msg in - let b1 = Block_hash.Set.elements set1 - and b2 = Block_hash.Set.elements set2 in - Assert.make_equal_list ?msg - (fun h1 h2 -> Block_hash.equal h1 h2) - Block_hash.to_string - b1 b2 - -let equal_block_map ?msg ~eq map1 map2 = - let msg = format_msg msg in - let b1 = Block_hash.Map.bindings map1 - and b2 = Block_hash.Map.bindings map2 in - Assert.make_equal_list ?msg - (fun (h1, b1) (h2, b2) -> Block_hash.equal h1 h2 && eq b1 b2) - (fun (h1, _) -> Block_hash.to_string h1) - b1 b2 - let equal_result ?msg r1 r2 ~equal_ok ~equal_err = let msg = format_msg msg in match r1, r2 with diff --git a/test/lib/assert.mli b/src/lib_test_helpers/assert.mli similarity index 73% rename from test/lib/assert.mli rename to src/lib_test_helpers/assert.mli index a39b70278..a8c06b32c 100644 --- a/test/lib/assert.mli +++ b/src/lib_test_helpers/assert.mli @@ -11,17 +11,10 @@ include module type of Kaputt.Assertion val format_msg : string option -> string option -val is_ok : ?msg:string -> 'a tzresult -> unit -val is_error : ?msg:string -> 'a tzresult -> unit -val contain_error : ?msg:string -> f:(error -> bool) -> 'a tzresult -> unit - val fail_msg : ('a, Format.formatter, unit, 'b) format4 -> 'a val fail : string -> string -> ('a, Format.formatter, unit, 'b) format4 -> 'a -val equal_block_hash_list : - ?msg:string -> Block_hash.t list -> Block_hash.t list -> unit - val equal_string_list : ?msg:string -> string list -> string list -> unit @@ -30,16 +23,6 @@ val equal_string_list_list : 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_set : - ?msg:string -> Block_hash.Set.t -> Block_hash.Set.t -> unit - -val equal_block_map : - ?msg:string -> eq:('a -> 'a -> bool) -> - 'a Block_hash.Map.t -> 'a Block_hash.Map.t -> unit - val equal_result : ?msg:string -> ('a, 'b) result -> diff --git a/test/lib/jbuild b/src/lib_test_helpers/jbuild similarity index 52% rename from test/lib/jbuild rename to src/lib_test_helpers/jbuild index b8f38ab51..26db4c8a2 100644 --- a/test/lib/jbuild +++ b/src/lib_test_helpers/jbuild @@ -1,11 +1,11 @@ (jbuild_version 1) (library - ((name test_lib) - (libraries (kaputt tezos-base)) - (wrapped false) - (flags (:standard -w -9-32 -safe-string - -open Tezos_base__TzPervasives)))) + ((name tezos_test_helpers) + (public_name tezos-test-helpers) + (libraries (lwt.unix kaputt)) + (modules (:standard)) + (flags (:standard -w -9-32 -safe-string)))) (alias ((name runtest_indent) diff --git a/test/lib/node_helpers.ml b/src/lib_test_helpers/node_helpers.ml similarity index 100% rename from test/lib/node_helpers.ml rename to src/lib_test_helpers/node_helpers.ml diff --git a/test/lib/node_helpers.mli b/src/lib_test_helpers/node_helpers.mli similarity index 100% rename from test/lib/node_helpers.mli rename to src/lib_test_helpers/node_helpers.mli diff --git a/src/lib_test_helpers/process.ml b/src/lib_test_helpers/process.ml new file mode 100644 index 000000000..96acaabe6 --- /dev/null +++ b/src/lib_test_helpers/process.ml @@ -0,0 +1,186 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Lwt.Infix + +let () = Lwt_unix.set_default_async_method Async_none + +module Make(Error : sig + type error + type error += Exn of exn + type 'a tzresult = ('a, error list) result + val pp_print_error: Format.formatter -> error list -> unit + val error_exn: exn -> ('a, error list) result + val join: unit tzresult Lwt.t list -> unit tzresult Lwt.t + val failwith: + ('a, Format.formatter, unit, 'b tzresult Lwt.t) format4 -> + 'a + end) = struct + + open Error + + let section = Lwt_log.Section.make "process" + let log_f ~level format = + if level < Lwt_log.Section.level section then + Format.ikfprintf (fun _ -> Lwt.return_unit) Format.std_formatter format + else + Format.kasprintf (fun msg -> Lwt_log.log ~section ~level msg) format + let lwt_debug fmt = log_f ~level:Lwt_log.Debug fmt + let lwt_log_notice fmt = log_f ~level:Lwt_log.Notice fmt + let lwt_log_info fmt = log_f ~level:Lwt_log.Info fmt + let lwt_log_error fmt = log_f ~level:Lwt_log.Error fmt + + exception Exited of int + exception Signaled of int + exception Stopped of int + + let handle_error f = + Lwt.catch + f + (fun exn -> Lwt.return_error [Exn exn]) >>= function + | Ok () -> Lwt.return_unit + | Error err -> + lwt_debug "%a" pp_print_error err >>= fun () -> + exit 1 + + module Channel = struct + type ('a, 'b) t = (Lwt_io.input_channel * Lwt_io.output_channel) + let push (_, outch) v = + Lwt.catch + (fun () -> Lwt_io.write_value outch v >>= Lwt.return_ok) + (fun exn -> Lwt.return_error [Exn exn]) + let pop (inch, _) = + Lwt.catch + (fun () -> Lwt_io.read_value inch >>= Lwt.return_ok) + (fun exn -> Lwt.return_error [Exn exn]) + end + + let wait pid = + Lwt.catch + (fun () -> + Lwt_unix.waitpid [] pid >>= function + | (_,Lwt_unix.WEXITED 0) -> + Lwt.return_ok () + | (_,Lwt_unix.WEXITED n) -> + Lwt.return_error [Exn (Exited n)] + | (_,Lwt_unix.WSIGNALED n) -> + Lwt.return_error [Exn (Signaled n)] + | (_,Lwt_unix.WSTOPPED n) -> + Lwt.return_error [Exn (Stopped n)]) + (function + | Lwt.Canceled -> + Unix.kill pid Sys.sigkill ; + Lwt.return_ok () + | exn -> + Lwt.return_error [Exn exn]) + + type ('a, 'b) t = { + termination: unit tzresult Lwt.t ; + channel: ('b, 'a) Channel.t ; + } + + let template = "$(date) - $(section): $(message)" + + let detach ?(prefix = "") f = + Lwt_io.flush_all () >>= fun () -> + let main_in, child_out = Lwt_io.pipe () in + let child_in, main_out = Lwt_io.pipe () in + match Lwt_unix.fork () with + | 0 -> + Lwt_log.default := + Lwt_log.channel ~template ~close_mode:`Keep ~channel:Lwt_io.stderr () ; + Random.self_init () ; + let template = Format.asprintf "%s$(message)" prefix in + Lwt_main.run begin + Lwt_io.close main_in >>= fun () -> + Lwt_io.close main_out >>= fun () -> + Lwt_log.default := + Lwt_log.channel ~template ~close_mode:`Keep ~channel:Lwt_io.stderr () ; + lwt_log_notice "PID: %d" (Unix.getpid ()) >>= fun () -> + handle_error (fun () -> f (child_in, child_out)) + end ; + exit 0 + | pid -> + let termination = wait pid in + Lwt_io.close child_in >>= fun () -> + Lwt_io.close child_out >>= fun () -> + Lwt.return ({ termination ; channel = (main_in, main_out) }) + + let signal_name = + let names = + [ Sys.sigabrt, "ABRT" ; + Sys.sigalrm, "ALRM" ; + Sys.sigfpe, "FPE" ; + Sys.sighup, "HUP" ; + Sys.sigill, "ILL" ; + Sys.sigint, "INT" ; + Sys.sigkill, "KILL" ; + Sys.sigpipe, "PIPE" ; + Sys.sigquit, "QUIT" ; + Sys.sigsegv, "SEGV" ; + Sys.sigterm, "TERM" ; + Sys.sigusr1, "USR1" ; + Sys.sigusr2, "USR2" ; + Sys.sigchld, "CHLD" ; + Sys.sigcont, "CONT" ; + Sys.sigstop, "STOP" ; + Sys.sigtstp, "TSTP" ; + Sys.sigttin, "TTIN" ; + Sys.sigttou, "TTOU" ; + Sys.sigvtalrm, "VTALRM" ; + Sys.sigprof, "PROF" ; + Sys.sigbus, "BUS" ; + Sys.sigpoll, "POLL" ; + Sys.sigsys, "SYS" ; + Sys.sigtrap, "TRAP" ; + Sys.sigurg, "URG" ; + Sys.sigxcpu, "XCPU" ; + Sys.sigxfsz, "XFSZ" ] in + fun n -> List.assoc n names + + let wait_all processes = + let rec loop processes = + match processes with + | [] -> Lwt.return_none + | processes -> + Lwt.nchoose_split processes >>= function + | (finished, remaining) -> + let rec handle = function + | [] -> loop remaining + | Ok () :: finished -> handle finished + | Error err :: _ -> + Lwt.return (Some (err, remaining)) in + handle finished in + loop (List.map (fun p -> p.termination) processes) >>= function + | None -> + lwt_log_info "All done!" >>= fun () -> + Lwt.return_ok () + | Some ([Exn (Exited n)], remaining) -> + lwt_log_error "Early error!" >>= fun () -> + List.iter Lwt.cancel remaining ; + join remaining >>= fun _ -> + failwith "A process finished with error %d !" n + | Some ([Exn (Signaled n)], remaining) -> + lwt_log_error "Early error!" >>= fun () -> + List.iter Lwt.cancel remaining ; + join remaining >>= fun _ -> + failwith "A process was killed by a SIG%s !" (signal_name n) + | Some ([Exn (Stopped n)], remaining) -> + lwt_log_error "Early error!" >>= fun () -> + List.iter Lwt.cancel remaining ; + join remaining >>= fun _ -> + failwith "A process was stopped by a SIG%s !" (signal_name n) + | Some (err, remaining) -> + lwt_log_error "@[Unexpected error!@,%a@]" + pp_print_error err >>= fun () -> + List.iter Lwt.cancel remaining ; + join remaining >>= fun _ -> + failwith "A process finished with an unexpected error !" + +end diff --git a/src/lib_test_helpers/process.mli b/src/lib_test_helpers/process.mli new file mode 100644 index 000000000..1612110dd --- /dev/null +++ b/src/lib_test_helpers/process.mli @@ -0,0 +1,44 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +module Make(Error : sig + type error + type error += Exn of exn + type 'a tzresult = ('a, error list) result + val pp_print_error: Format.formatter -> error list -> unit + val error_exn: exn -> ('a, error list) result + val join: unit tzresult Lwt.t list -> unit tzresult Lwt.t + val failwith: + ('a, Format.formatter, unit, 'b tzresult Lwt.t) format4 -> + 'a + end) : sig + + open Error + + exception Exited of int + + module Channel : sig + type ('a, 'b) t + val push: ('a, 'b) t -> 'a -> unit tzresult Lwt.t + val pop: ('a, 'b) t -> 'b tzresult Lwt.t + end + + type ('a, 'b) t = { + termination: unit tzresult Lwt.t ; + channel: ('b, 'a) Channel.t ; + } + + val detach: + ?prefix:string -> + (('a, 'b) Channel.t -> unit tzresult Lwt.t) -> + ('a, 'b) t Lwt.t + + val wait_all: ('a, 'b) t list -> unit tzresult Lwt.t + +end diff --git a/src/lib_test_helpers/test.ml b/src/lib_test_helpers/test.ml new file mode 100644 index 000000000..c51b3df69 --- /dev/null +++ b/src/lib_test_helpers/test.ml @@ -0,0 +1,170 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +module Make(Error : sig + type error + val pp_print_error: Format.formatter -> error list -> unit + end) = struct + + module Test = Kaputt.Abbreviations.Test + + let keep_dir = try ignore (Sys.getenv "KEEPDIR") ; true with _ -> false + + let rec remove_dir dir = + if Sys.file_exists dir then begin + 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 + end + + let output name res = + let open Kaputt in + let open Test in + let out = stderr in + match res with + | Passed -> + Printf.fprintf out "Test '%s' ... passed\n" name + | Failed { Assertion.expected_value = "" ; actual_value = "" ; message } -> + Printf.fprintf out "Test '%s' ... failed\n %s \n" name message + | Failed { Assertion.expected_value ; actual_value ; message = "" } -> + if expected_value <> actual_value then + Printf.fprintf out + "Test '%s' ... failed\n expected `%s` but received `%s`\n" + name + expected_value + actual_value + else + Printf.fprintf out + "Test '%s' ... failed\n expected anything excluding `%s` \ + but received `%s`\n" + name + expected_value + actual_value + | Failed { Assertion.expected_value ; actual_value ; message } -> + if expected_value <> actual_value then + Printf.fprintf out + "Test '%s' ... failed\n %s (expected `%s` but received `%s`)\n" + name + message + expected_value + actual_value + else + Printf.fprintf out + "Test '%s' ... failed\n %s (expected anything excluding `%s` \ + but received `%s`)\n" + name + message + expected_value + actual_value + | Uncaught (e, bt) -> + Printf.fprintf out + "Test '%s' ... raised an exception\n %s\n%s\n" + name (Printexc.to_string e) bt + | Report (valid, total, uncaught, counterexamples, categories) -> + Printf.fprintf out + "Test '%s' ... %d/%d case%s passed%s\n" + name + valid + total + (if valid > 1 then "s" else "") + (match uncaught with + | 0 -> "" + | 1 -> " (1 uncaught exception)" + | n -> " (" ^ (string_of_int n) ^ " uncaught exceptions)"); + if counterexamples <> [] then + Printf.fprintf out " counterexample%s: %s\n" + (if (List.length counterexamples) > 1 then "s" else "") + (String.concat ", " counterexamples); + if (List.length categories) > 1 then begin + Printf.fprintf out " categories:\n"; + List.iter + (fun (c, n) -> + Printf.fprintf out + " %s -> %d occurrence%s\n" + c n (if n > 1 then "s" else "")) + categories + end + | Exit_code c -> + Printf.fprintf out "Test '%s' ... returned code %d\n" name c + + let run prefix tests = + let tests = + List.map + (fun (title, f) -> + let base_dir = Filename.temp_file "tezos_test_" "" in + Unix.unlink base_dir ; + Unix.mkdir base_dir 0o777 ; + let title = prefix ^ title in + title, + Test.make_simple_test + ~title + (fun () -> + let finalise () = + if keep_dir then + Format.eprintf "Kept data dir %s@." base_dir + else + remove_dir base_dir + in + try + match Lwt_main.run (f base_dir) with + | Ok () -> finalise () + | Error err -> + finalise () ; + Format.kasprintf + (fun message -> + raise @@ + Kaputt.Assertion.Failed + { expected_value = "" ; + actual_value = "" ; + message }) + "%a" Error.pp_print_error err + with exn -> + finalise () ; + raise exn)) + tests in + let passed = ref 0 in + let failed = ref 0 in + let uncaught = ref 0 in + let total = ref 0 in + List.iter + (fun (title, test) -> + let res = Test.exec_test test in + begin + match res with + | Passed -> + incr passed; + incr total + | Failed _ -> + incr failed; + incr total + | Uncaught _ -> + incr uncaught; + incr total + | Report (pass, tot, unc, _, _) -> + passed := !passed + pass; + failed := !failed + (tot - pass -unc); + uncaught := !uncaught + unc; + total := !total + tot + | Exit_code c -> + incr (if c = 0 then passed else failed); + incr total + end ; + output title res ; + flush stderr) + tests ; + Format.eprintf "SUMMARY: %d/%d passed (%.2f%%) -- %d failed, \ + %d uncaught exceptions.@." + !passed !total (float_of_int !passed *. 100. /. float_of_int !total) + !failed !uncaught ; + if !total <> !passed then exit 1 + +end diff --git a/test/lib/test.mli b/src/lib_test_helpers/test.mli similarity index 74% rename from test/lib/test.mli rename to src/lib_test_helpers/test.mli index fa4729138..dab17eccb 100644 --- a/test/lib/test.mli +++ b/src/lib_test_helpers/test.mli @@ -7,6 +7,11 @@ (* *) (**************************************************************************) -open Error_monad +module Make(Error : sig + type error + val pp_print_error: Format.formatter -> error list -> unit + end) : sig -val run : string -> (string * (string -> unit tzresult Lwt.t)) list -> unit + val run : string -> (string * (string -> (unit, Error.error list) result Lwt.t)) list -> unit + +end diff --git a/src/lib_test_helpers/tezos-test-helpers.opam b/src/lib_test_helpers/tezos-test-helpers.opam new file mode 100644 index 000000000..516d1a141 --- /dev/null +++ b/src/lib_test_helpers/tezos-test-helpers.opam @@ -0,0 +1,20 @@ +opam-version: "1.2" +version: "dev" +maintainer: "contact@tezos.com" +authors: [ "Tezos devteam" ] +homepage: "https://www.tezos.com/" +bug-reports: "https://gitlab.com/tezos/tezos/issues" +dev-repo: "https://gitlab.com/tezos/tezos.git" +license: "unreleased" +depends: [ + "ocamlfind" { build } + "jbuilder" { build & >= "1.0+beta15" } + "lwt" + "kaputt" +] +build: [ + [ "jbuilder" "build" "-p" name "-j" jobs ] +] +build-test: [ + [ "jbuilder" "runtest" "-p" name "-j" jobs ] +] diff --git a/test/jbuild b/test/jbuild index 098dde4ea..e0b4e144e 100644 --- a/test/jbuild +++ b/test/jbuild @@ -3,7 +3,7 @@ (alias ((name runtest_basic.sh) (deps (sandbox.json - lib/test_lib.inc.sh + test_lib.inc.sh (glob_files contracts/*) )) (locks (/tcp-port/18731 @@ -18,7 +18,7 @@ (alias ((name runtest_contracts.sh) (deps (sandbox.json - lib/test_lib.inc.sh + test_lib.inc.sh (glob_files contracts/*) )) (locks (/tcp-port/18731 @@ -33,7 +33,7 @@ (alias ((name runtest_multinode.sh) (deps (sandbox.json - lib/test_lib.inc.sh + test_lib.inc.sh (glob_files contracts/*) )) (locks (/tcp-port/18731 /tcp-port/18732 /tcp-port/18733 /tcp-port/18734 diff --git a/test/lib/process.ml b/test/lib/process.ml deleted file mode 100644 index 00662525e..000000000 --- a/test/lib/process.ml +++ /dev/null @@ -1,156 +0,0 @@ -(**************************************************************************) -(* *) -(* Copyright (c) 2014 - 2017. *) -(* Dynamic Ledger Solutions, Inc. *) -(* *) -(* All rights reserved. No warranty, explicit or implicit, provided. *) -(* *) -(**************************************************************************) - -let () = Lwt_unix.set_default_async_method Async_none - -include Logging.Make (struct let name = "process" end) - -exception Exited of int -exception Signaled of int -exception Stopped of int - -let handle_error f = - Lwt.catch - f - (fun exn -> Lwt.return (error_exn exn)) >>= function - | Ok () -> Lwt.return_unit - | Error err -> - lwt_log_error "%a" Error_monad.pp_print_error err >>= fun () -> - exit 1 - -module Channel = struct - type ('a, 'b) t = (Lwt_io.input_channel * Lwt_io.output_channel) - let push (_, outch) v = - Lwt.catch - (fun () -> Lwt_io.write_value outch v >>= return) - (fun exn -> fail (Exn exn)) - let pop (inch, _) = - Lwt.catch - (fun () -> Lwt_io.read_value inch >>= return) - (fun exn -> fail (Exn exn)) -end - -let wait pid = - Lwt.catch - (fun () -> - Lwt_unix.waitpid [] pid >>= function - | (_,Lwt_unix.WEXITED 0) -> - return () - | (_,Lwt_unix.WEXITED n) -> - fail (Exn (Exited n)) - | (_,Lwt_unix.WSIGNALED n) -> - fail (Exn (Signaled n)) - | (_,Lwt_unix.WSTOPPED n) -> - fail (Exn (Stopped n))) - (function - | Lwt.Canceled -> - Unix.kill pid Sys.sigkill ; - return () - | exn -> - fail (Exn exn)) - -type ('a, 'b) t = { - termination: unit tzresult Lwt.t ; - channel: ('b, 'a) Channel.t ; -} - -let detach ?(prefix = "") f = - Lwt_io.flush_all () >>= fun () -> - let main_in, child_out = Lwt_io.pipe () in - let child_in, main_out = Lwt_io.pipe () in - match Lwt_unix.fork () with - | 0 -> - Logging.init Stderr >>= fun () -> - Random.self_init () ; - let template = Format.asprintf "%s$(message)" prefix in - Lwt_main.run begin - Lwt_io.close main_in >>= fun () -> - Lwt_io.close main_out >>= fun () -> - Logging.init ~template Stderr >>= fun () -> - lwt_log_notice "PID: %d" (Unix.getpid ()) >>= fun () -> - handle_error (fun () -> f (child_in, child_out)) - end ; - exit 0 - | pid -> - let termination = wait pid in - Lwt_io.close child_in >>= fun () -> - Lwt_io.close child_out >>= fun () -> - Lwt.return ({ termination ; channel = (main_in, main_out) }) - -let signal_name = - let names = - [ Sys.sigabrt, "ABRT" ; - Sys.sigalrm, "ALRM" ; - Sys.sigfpe, "FPE" ; - Sys.sighup, "HUP" ; - Sys.sigill, "ILL" ; - Sys.sigint, "INT" ; - Sys.sigkill, "KILL" ; - Sys.sigpipe, "PIPE" ; - Sys.sigquit, "QUIT" ; - Sys.sigsegv, "SEGV" ; - Sys.sigterm, "TERM" ; - Sys.sigusr1, "USR1" ; - Sys.sigusr2, "USR2" ; - Sys.sigchld, "CHLD" ; - Sys.sigcont, "CONT" ; - Sys.sigstop, "STOP" ; - Sys.sigtstp, "TSTP" ; - Sys.sigttin, "TTIN" ; - Sys.sigttou, "TTOU" ; - Sys.sigvtalrm, "VTALRM" ; - Sys.sigprof, "PROF" ; - Sys.sigbus, "BUS" ; - Sys.sigpoll, "POLL" ; - Sys.sigsys, "SYS" ; - Sys.sigtrap, "TRAP" ; - Sys.sigurg, "URG" ; - Sys.sigxcpu, "XCPU" ; - Sys.sigxfsz, "XFSZ" ] in - fun n -> List.assoc n names - -let wait_all processes = - let rec loop processes = - match processes with - | [] -> Lwt.return_none - | processes -> - Lwt.nchoose_split processes >>= function - | (finished, remaining) -> - let rec handle = function - | [] -> loop remaining - | Ok () :: finished -> handle finished - | Error err :: _ -> - Lwt.return (Some (err, remaining)) in - handle finished in - loop (List.map (fun p -> p.termination) processes) >>= function - | None -> - lwt_log_info "All done!" >>= fun () -> - return () - | Some ([Exn (Exited n)], remaining) -> - lwt_log_error "Early error!" >>= fun () -> - List.iter Lwt.cancel remaining ; - join remaining >>= fun _ -> - failwith "A process finished with error %d !" n - | Some ([Exn (Signaled n)], remaining) -> - lwt_log_error "Early error!" >>= fun () -> - List.iter Lwt.cancel remaining ; - join remaining >>= fun _ -> - failwith "A process was killed by a SIG%s !" (signal_name n) - | Some ([Exn (Stopped n)], remaining) -> - lwt_log_error "Early error!" >>= fun () -> - List.iter Lwt.cancel remaining ; - join remaining >>= fun _ -> - failwith "A process was stopped by a SIG%s !" (signal_name n) - | Some (err, remaining) -> - lwt_log_error "@[Unexpected error!@,%a@]" - pp_print_error err >>= fun () -> - List.iter Lwt.cancel remaining ; - join remaining >>= fun _ -> - failwith "A process finished with an unexpected error !" - diff --git a/test/lib/process.mli b/test/lib/process.mli deleted file mode 100644 index 67dff1453..000000000 --- a/test/lib/process.mli +++ /dev/null @@ -1,29 +0,0 @@ -(**************************************************************************) -(* *) -(* Copyright (c) 2014 - 2017. *) -(* Dynamic Ledger Solutions, Inc. *) -(* *) -(* All rights reserved. No warranty, explicit or implicit, provided. *) -(* *) -(**************************************************************************) - -open Error_monad -exception Exited of int - -module Channel : sig - type ('a, 'b) t - val push: ('a, 'b) t -> 'a -> unit tzresult Lwt.t - val pop: ('a, 'b) t -> 'b tzresult Lwt.t -end - -type ('a, 'b) t = { - termination: unit tzresult Lwt.t ; - channel: ('b, 'a) Channel.t ; -} - -val detach: - ?prefix:string -> - (('a, 'b) Channel.t -> unit tzresult Lwt.t) -> - ('a, 'b) t Lwt.t - -val wait_all: ('a, 'b) t list -> unit tzresult Lwt.t diff --git a/test/lib/test.ml b/test/lib/test.ml deleted file mode 100644 index e9498833c..000000000 --- a/test/lib/test.ml +++ /dev/null @@ -1,163 +0,0 @@ -(**************************************************************************) -(* *) -(* Copyright (c) 2014 - 2017. *) -(* Dynamic Ledger Solutions, Inc. *) -(* *) -(* All rights reserved. No warranty, explicit or implicit, provided. *) -(* *) -(**************************************************************************) - -module Test = Kaputt.Abbreviations.Test - -let keep_dir = try ignore (Sys.getenv "KEEPDIR") ; true with _ -> false - -let rec remove_dir dir = - if Sys.file_exists dir then begin - 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 - end - -let output name res = - let open Kaputt in - let open Test in - let out = stderr in - match res with - | Passed -> - Printf.fprintf out "Test '%s' ... passed\n" name - | Failed { Assertion.expected_value = "" ; actual_value = "" ; message } -> - Printf.fprintf out "Test '%s' ... failed\n %s \n" name message - | Failed { Assertion.expected_value ; actual_value ; message = "" } -> - if expected_value <> actual_value then - Printf.fprintf out - "Test '%s' ... failed\n expected `%s` but received `%s`\n" - name - expected_value - actual_value - else - Printf.fprintf out - "Test '%s' ... failed\n expected anything excluding `%s` \ - but received `%s`\n" - name - expected_value - actual_value - | Failed { Assertion.expected_value ; actual_value ; message } -> - if expected_value <> actual_value then - Printf.fprintf out - "Test '%s' ... failed\n %s (expected `%s` but received `%s`)\n" - name - message - expected_value - actual_value - else - Printf.fprintf out - "Test '%s' ... failed\n %s (expected anything excluding `%s` \ - but received `%s`)\n" - name - message - expected_value - actual_value - | Uncaught (e, bt) -> - Printf.fprintf out - "Test '%s' ... raised an exception\n %s\n%s\n" - name (Printexc.to_string e) bt - | Report (valid, total, uncaught, counterexamples, categories) -> - Printf.fprintf out - "Test '%s' ... %d/%d case%s passed%s\n" - name - valid - total - (if valid > 1 then "s" else "") - (match uncaught with - | 0 -> "" - | 1 -> " (1 uncaught exception)" - | n -> " (" ^ (string_of_int n) ^ " uncaught exceptions)"); - if counterexamples <> [] then - Printf.fprintf out " counterexample%s: %s\n" - (if (List.length counterexamples) > 1 then "s" else "") - (String.concat ", " counterexamples); - if (List.length categories) > 1 then begin - Printf.fprintf out " categories:\n"; - List.iter - (fun (c, n) -> - Printf.fprintf out - " %s -> %d occurrence%s\n" - c n (if n > 1 then "s" else "")) - categories - end - | Exit_code c -> - Printf.fprintf out "Test '%s' ... returned code %d\n" name c - -let run prefix tests = - let tests = - List.map - (fun (title, f) -> - let base_dir = Filename.temp_file "tezos_test_" "" in - Unix.unlink base_dir ; - Unix.mkdir base_dir 0o777 ; - let title = prefix ^ title in - title, - Test.make_simple_test - ~title - (fun () -> - let finalise () = - if keep_dir then - Format.eprintf "Kept data dir %s@." base_dir - else - remove_dir base_dir - in - try - match Lwt_main.run (f base_dir) with - | Ok () -> finalise () - | Error err -> - finalise () ; - Format.kasprintf - (fun message -> - raise @@ - Kaputt.Assertion.Failed - { expected_value = "" ; - actual_value = "" ; - message }) - "%a" Error_monad.pp_print_error err - with exn -> - finalise () ; - raise exn)) - tests in - let passed = ref 0 in - let failed = ref 0 in - let uncaught = ref 0 in - let total = ref 0 in - List.iter - (fun (title, test) -> - let res = Test.exec_test test in - begin - match res with - | Passed -> - incr passed; - incr total - | Failed _ -> - incr failed; - incr total - | Uncaught _ -> - incr uncaught; - incr total - | Report (pass, tot, unc, _, _) -> - passed := !passed + pass; - failed := !failed + (tot - pass -unc); - uncaught := !uncaught + unc; - total := !total + tot - | Exit_code c -> - incr (if c = 0 then passed else failed); - incr total - end ; - output title res ; - flush stderr) - tests ; - Format.eprintf "SUMMARY: %d/%d passed (%.2f%%) -- %d failed, \ - %d uncaught exceptions.@." - !passed !total (float_of_int !passed *. 100. /. float_of_int !total) - !failed !uncaught ; - if !total <> !passed then exit 1 diff --git a/test/p2p/jbuild b/test/p2p/jbuild index 25b8bf1f7..76bd1fcea 100644 --- a/test/p2p/jbuild +++ b/test/p2p/jbuild @@ -6,12 +6,12 @@ test_p2p_io_scheduler)) (libraries (tezos-base tezos-p2p - lwt.unix - test_lib)) + tezos-test-helpers)) (flags (:standard -w -9-32 -linkall -safe-string -open Tezos_base__TzPervasives + -open Tezos_test_helpers -open Tezos_p2p)))) (alias diff --git a/test/p2p/test_p2p_io_scheduler.ml b/test/p2p/test_p2p_io_scheduler.ml index 7c8a8928f..c8d6c8a92 100644 --- a/test/p2p/test_p2p_io_scheduler.ml +++ b/test/p2p/test_p2p_io_scheduler.ml @@ -7,6 +7,8 @@ (* *) (**************************************************************************) +module Process = Tezos_test_helpers.Process.Make(Error_monad) + include Logging.Make (struct let name = "test-p2p-io-scheduler" end) exception Error of error list @@ -215,6 +217,7 @@ let () = let () = Sys.catch_break true ; + let module Test = Tezos_test_helpers.Test.Make(Error_monad) in Test.run "p2p.io-scheduler." [ "trivial-quota", (fun _dir -> run diff --git a/test/p2p/test_p2p_pool.ml b/test/p2p/test_p2p_pool.ml index d078c8309..c24f88d33 100644 --- a/test/p2p/test_p2p_pool.ml +++ b/test/p2p/test_p2p_pool.ml @@ -7,12 +7,13 @@ (* *) (**************************************************************************) +module Process = Tezos_test_helpers.Process.Make(Error_monad) + include Logging.Make (struct let name = "test.p2p.connection-pool" end) type message = | Ping - let msg_config : message P2p_pool.message_config = { encoding = [ P2p_pool.Encoding { @@ -279,6 +280,7 @@ let spec = Arg.[ ] let main () = + let module Test = Tezos_test_helpers.Test.Make(Error_monad) in let anon_fun _num_peers = raise (Arg.Bad "No anonymous argument.") in let usage_msg = "Usage: %s .\nArguments are:" in Arg.parse spec anon_fun usage_msg ; diff --git a/test/p2p/test_p2p_socket.ml b/test/p2p/test_p2p_socket.ml index d7323d805..923ad2d72 100644 --- a/test/p2p/test_p2p_socket.ml +++ b/test/p2p/test_p2p_socket.ml @@ -10,6 +10,8 @@ (* TODO Use Kaputt on the client side and remove `assert` from the server. *) +module Process = Tezos_test_helpers.Process.Make(Error_monad) + include Logging.Make (struct let name = "test.p2p.connection" end) let default_addr = Ipaddr.V6.localhost @@ -409,9 +411,11 @@ let spec = Arg.[ ] let main () = + let module Test = Tezos_test_helpers.Process.Make(Error_monad) in let anon_fun _num_peers = raise (Arg.Bad "No anonymous argument.") in let usage_msg = "Usage: %s.\nArguments are:" in Arg.parse spec anon_fun usage_msg ; + let module Test = Tezos_test_helpers.Test.Make(Error_monad) in Test.run "p2p-connection." [ "low-level", Low_level.run ; "kick", Kick.run ; diff --git a/test/proto_alpha/jbuild b/test/proto_alpha/jbuild index fa21894e4..a6de8ba0f 100644 --- a/test/proto_alpha/jbuild +++ b/test/proto_alpha/jbuild @@ -12,9 +12,10 @@ tezos-client-genesis tezos-client-alpha tezos-shell - test_lib)) + tezos-test-helpers)) (flags (:standard -w -9-32 -safe-string -open Tezos_base__TzPervasives + -open Tezos_test_helpers -open Tezos_rpc_http -open Tezos_client_base -open Tezos_client_genesis diff --git a/test/proto_alpha/proto_alpha_helpers.ml b/test/proto_alpha/proto_alpha_helpers.ml index 59f91d351..2a625c1b0 100644 --- a/test/proto_alpha/proto_alpha_helpers.ml +++ b/test/proto_alpha/proto_alpha_helpers.ml @@ -310,8 +310,15 @@ module Assert = struct let hash op = Tezos_base.Operation.hash op + let contain_error ?(msg="") ~f = function + | Ok _ -> Kaputt.Abbreviations.Assert.fail "Error _" "Ok _" msg + | Error error when not (List.exists f error) -> + let error_str = Format.asprintf "%a" Error_monad.pp_print_error error in + Kaputt.Abbreviations.Assert.fail "" error_str msg + | _ -> () + let failed_to_preapply ~msg ?op f = - Assert.contain_error ~msg ~f:begin function + contain_error ~msg ~f:begin function | Client_baking_forge.Failed_to_preapply (op', err) -> begin match op with @@ -324,64 +331,64 @@ module Assert = struct end let generic_economic_error ~msg = - Assert.contain_error ~msg ~f:(ecoproto_error (fun _ -> true)) + contain_error ~msg ~f:(ecoproto_error (fun _ -> true)) let unknown_contract ~msg = - Assert.contain_error ~msg ~f:begin ecoproto_error (function + contain_error ~msg ~f:begin ecoproto_error (function | Raw_context.Storage_error _ -> true | _ -> false) end let non_existing_contract ~msg = - Assert.contain_error ~msg ~f:begin ecoproto_error (function + contain_error ~msg ~f:begin ecoproto_error (function | Contract_storage.Non_existing_contract _ -> true | _ -> false) end let balance_too_low ~msg = - Assert.contain_error ~msg ~f:begin ecoproto_error (function + contain_error ~msg ~f:begin ecoproto_error (function | Contract.Balance_too_low _ -> true | _ -> false) end let non_spendable ~msg = - Assert.contain_error ~msg ~f:begin ecoproto_error (function + contain_error ~msg ~f:begin ecoproto_error (function | Contract_storage.Unspendable_contract _ -> true | _ -> false) end let inconsistent_pkh ~msg = - Assert.contain_error ~msg ~f:begin ecoproto_error (function + contain_error ~msg ~f:begin ecoproto_error (function | Contract_storage.Inconsistent_hash _ -> true | _ -> false) end let inconsistent_public_key ~msg = - Assert.contain_error ~msg ~f:begin ecoproto_error (function + contain_error ~msg ~f:begin ecoproto_error (function | Contract_storage.Inconsistent_public_key _ -> true | _ -> false) end let missing_public_key ~msg = - Assert.contain_error ~msg ~f:begin ecoproto_error (function + contain_error ~msg ~f:begin ecoproto_error (function | Contract_storage.Missing_public_key _ -> true | _ -> false) end let initial_amount_too_low ~msg = - Assert.contain_error ~msg ~f:begin ecoproto_error (function + contain_error ~msg ~f:begin ecoproto_error (function | Contract.Initial_amount_too_low _ -> true | _ -> false) end let non_delegatable ~msg = - Assert.contain_error ~msg ~f:begin ecoproto_error (function + contain_error ~msg ~f:begin ecoproto_error (function | Contract_storage.Non_delegatable_contract _ -> true | _ -> false) end let wrong_delegate ~msg = - Assert.contain_error ~msg ~f:begin ecoproto_error (function + contain_error ~msg ~f:begin ecoproto_error (function | Baking.Wrong_delegate _ -> true | _ -> false) end diff --git a/test/proto_alpha/test_endorsement.ml b/test/proto_alpha/test_endorsement.ml index 23e09936d..f2409d6fb 100644 --- a/test/proto_alpha/test_endorsement.ml +++ b/test/proto_alpha/test_endorsement.ml @@ -250,4 +250,5 @@ let tests = [ ] let () = + let module Test = Tezos_test_helpers.Test.Make(Error_monad) in Test.run "endorsement." tests diff --git a/test/proto_alpha/test_michelson_parser.ml b/test/proto_alpha/test_michelson_parser.ml index 1401a7eff..7fed2d8d4 100644 --- a/test/proto_alpha/test_michelson_parser.ml +++ b/test/proto_alpha/test_michelson_parser.ml @@ -430,4 +430,5 @@ let tests = [ ] let () = + let module Test = Tezos_test_helpers.Test.Make(Error_monad) in Test.run "michelson." tests diff --git a/test/proto_alpha/test_origination.ml b/test/proto_alpha/test_origination.ml index 0fe1bf9cc..d6438e626 100644 --- a/test/proto_alpha/test_origination.ml +++ b/test/proto_alpha/test_origination.ml @@ -96,4 +96,5 @@ let tests = [ ] let () = + let module Test = Tezos_test_helpers.Test.Make(Error_monad) in Test.run "origination." tests diff --git a/test/proto_alpha/test_transaction.ml b/test/proto_alpha/test_transaction.ml index a541b0c86..cee3a5b77 100644 --- a/test/proto_alpha/test_transaction.ml +++ b/test/proto_alpha/test_transaction.ml @@ -107,4 +107,5 @@ let tests = [ ] let () = + let module Test = Tezos_test_helpers.Test.Make(Error_monad) in Test.run "transactions." tests diff --git a/test/proto_alpha/test_vote.ml b/test/proto_alpha/test_vote.ml index d68ffa5d6..dab8a79f5 100644 --- a/test/proto_alpha/test_vote.ml +++ b/test/proto_alpha/test_vote.ml @@ -95,4 +95,5 @@ let tests = [ ] let () = + let module Test = Tezos_test_helpers.Test.Make(Error_monad) in Test.run "amendment." tests diff --git a/test/proto_alpha_isolate/jbuild b/test/proto_alpha_isolate/jbuild index 82d949fb2..c21348010 100644 --- a/test/proto_alpha_isolate/jbuild +++ b/test/proto_alpha_isolate/jbuild @@ -13,10 +13,11 @@ (libraries (tezos-base tezos-rpc-http tezos-shell - test_lib + tezos-test-helpers tezos_proto_alpha_isolate_helpers)) (flags (:standard -w -9-32 -safe-string -open Tezos_base__TzPervasives + -open Tezos_test_helpers -open Tezos_rpc_http)))) (alias diff --git a/test/proto_alpha_isolate/test_isolate_dsl.ml b/test/proto_alpha_isolate/test_isolate_dsl.ml index c35e59c87..b45c03522 100644 --- a/test/proto_alpha_isolate/test_isolate_dsl.ml +++ b/test/proto_alpha_isolate/test_isolate_dsl.ml @@ -160,4 +160,5 @@ let tests = [ ] let main () = + let module Test = Tezos_test_helpers.Test.Make(Error_monad) in Test.run "dsl." tests diff --git a/test/proto_alpha_isolate/test_isolate_endorsement.ml b/test/proto_alpha_isolate/test_isolate_endorsement.ml index e820f457b..827aa7788 100644 --- a/test/proto_alpha_isolate/test_isolate_endorsement.ml +++ b/test/proto_alpha_isolate/test_isolate_endorsement.ml @@ -150,4 +150,5 @@ let tests = [ ] let main () = + let module Test = Tezos_test_helpers.Test.Make(Error_monad) in Test.run "endorsement." tests diff --git a/test/proto_alpha_isolate/test_isolate_michelson.ml b/test/proto_alpha_isolate/test_isolate_michelson.ml index 5366831cd..f685464ec 100644 --- a/test/proto_alpha_isolate/test_isolate_michelson.ml +++ b/test/proto_alpha_isolate/test_isolate_michelson.ml @@ -498,4 +498,5 @@ let tests = [ ] let main () = + let module Test = Tezos_test_helpers.Test.Make(Error_monad) in Test.run "michelson." tests diff --git a/test/proto_alpha_isolate/test_isolate_origination.ml b/test/proto_alpha_isolate/test_isolate_origination.ml index db47a018d..b265a14fd 100644 --- a/test/proto_alpha_isolate/test_isolate_origination.ml +++ b/test/proto_alpha_isolate/test_isolate_origination.ml @@ -103,4 +103,5 @@ let tests = [ ] let main () = + let module Test = Tezos_test_helpers.Test.Make(Error_monad) in Test.run "origination." tests diff --git a/test/proto_alpha_isolate/test_isolate_transaction.ml b/test/proto_alpha_isolate/test_isolate_transaction.ml index 3a2fdb524..d0e64823a 100644 --- a/test/proto_alpha_isolate/test_isolate_transaction.ml +++ b/test/proto_alpha_isolate/test_isolate_transaction.ml @@ -161,4 +161,5 @@ let tests = [ ] let main () = + let module Test = Tezos_test_helpers.Test.Make(Error_monad) in Test.run "transactions." tests diff --git a/test/proto_alpha_isolate_helpers/helpers_assert.ml b/test/proto_alpha_isolate_helpers/helpers_assert.ml index d5ab21f6a..8f320776b 100644 --- a/test/proto_alpha_isolate_helpers/helpers_assert.ml +++ b/test/proto_alpha_isolate_helpers/helpers_assert.ml @@ -106,18 +106,23 @@ let equal_cents_balance ~tc ?msg (contract, cents_balance) = ~msg: (Option.unopt ~default:"equal_cents_balance" msg) (contract, Helpers_cast.cents_of_int cents_balance) - let ecoproto_error f = function | Proto_alpha.Environment.Ecoproto_error errors -> List.exists f errors | _ -> false +let contain_error ?(msg="") ~f = function + | Ok _ -> Kaputt.Abbreviations.Assert.fail "Error _" "Ok _" msg + | Error error when not (List.exists f error) -> + let error_str = Format.asprintf "%a" Error_monad.pp_print_error error in + Kaputt.Abbreviations.Assert.fail "" error_str msg + | _ -> () let generic_economic_error ~msg = - Assert.contain_error ~msg ~f: (ecoproto_error (fun _ -> true)) + contain_error ~msg ~f: (ecoproto_error (fun _ -> true)) let economic_error ~msg f = - Assert.contain_error ~msg ~f: (ecoproto_error f) + contain_error ~msg ~f: (ecoproto_error f) let ill_typed_data_error ~msg = let aux = function @@ -167,7 +172,7 @@ let balance_too_low ~msg = let non_spendable ~msg = - Assert.contain_error ~msg ~f: begin ecoproto_error (function + contain_error ~msg ~f: begin ecoproto_error (function | Proto_alpha.Contract_storage.Unspendable_contract _ -> true | error -> Helpers_logger.debug "Actual error: %a" pp error ; @@ -175,25 +180,25 @@ let non_spendable ~msg = end let inconsistent_pkh ~msg = - Assert.contain_error ~msg ~f: begin ecoproto_error (function + contain_error ~msg ~f: begin ecoproto_error (function | Proto_alpha.Contract_storage.Inconsistent_hash _ -> true | _ -> false) end let initial_amount_too_low ~msg = - Assert.contain_error ~msg ~f: begin ecoproto_error (function + contain_error ~msg ~f: begin ecoproto_error (function | Contract.Initial_amount_too_low _ -> true | _ -> false) end let non_delegatable ~msg = - Assert.contain_error ~msg ~f: begin ecoproto_error (function + contain_error ~msg ~f: begin ecoproto_error (function | Proto_alpha.Contract_storage.Non_delegatable_contract _ -> true | _ -> false) end let wrong_delegate ~msg = - Assert.contain_error ~msg ~f: begin ecoproto_error (function + contain_error ~msg ~f: begin ecoproto_error (function | Proto_alpha.Baking.Wrong_delegate _ -> true | _ -> false) end diff --git a/test/proto_alpha_isolate_helpers/jbuild b/test/proto_alpha_isolate_helpers/jbuild index fd952ef58..46c8217a1 100644 --- a/test/proto_alpha_isolate_helpers/jbuild +++ b/test/proto_alpha_isolate_helpers/jbuild @@ -2,8 +2,7 @@ (library ((name tezos_proto_alpha_isolate_helpers) - (libraries (kaputt - test_lib + (libraries (tezos-test-helpers tezos-base tezos-shell tezos-embedded-protocol-genesis @@ -11,6 +10,7 @@ (wrapped false) (flags (:standard -w -9-32 -safe-string -open Tezos_base__TzPervasives + -open Tezos_test_helpers -open Tezos_embedded_raw_protocol_alpha)))) (alias diff --git a/test/shell/jbuild b/test/shell/jbuild index 24a772f4e..937ad6db6 100644 --- a/test/shell/jbuild +++ b/test/shell/jbuild @@ -10,10 +10,11 @@ tezos-embedded-protocol-demo tezos-embedded-protocol-alpha tezos-embedded-protocol-genesis - test_lib)) + tezos-test-helpers)) (flags (:standard -w -9-32 -safe-string -open Tezos_base__TzPervasives + -open Tezos_test_helpers -open Tezos_storage -open Tezos_shell)))) diff --git a/test/shell/test_context.ml b/test/shell/test_context.ml index 2cd08de5e..c9a54760a 100644 --- a/test/shell/test_context.ml +++ b/test/shell/test_context.ml @@ -216,4 +216,5 @@ let tests : (string * (t -> unit Lwt.t)) list = [ ] let () = + let module Test = Tezos_test_helpers.Test.Make(Error_monad) in Test.run "context." (List.map (fun (s, f) -> s, wrap_context_init f) tests) diff --git a/test/shell/test_state.ml b/test/shell/test_state.ml index 19df00bfb..db6a8236f 100644 --- a/test/shell/test_state.ml +++ b/test/shell/test_state.ml @@ -446,4 +446,5 @@ let tests : (string * (state -> unit tzresult Lwt.t)) list = [ ] let () = + let module Test = Tezos_test_helpers.Test.Make(Error_monad) in Test.run "state." (List.map (fun (s, f) -> s, wrap_state_init f) tests) diff --git a/test/shell/test_store.ml b/test/shell/test_store.ml index cbd07a97a..66c36fc65 100644 --- a/test/shell/test_store.ml +++ b/test/shell/test_store.ml @@ -208,6 +208,15 @@ let test_generic_list (type t) open Store_helpers +let equal_block_set ?msg set1 set2 = + let msg = Assert.format_msg msg in + let b1 = Block_hash.Set.elements set1 + and b2 = Block_hash.Set.elements set2 in + Assert.make_equal_list ?msg + (fun h1 h2 -> Block_hash.equal h1 h2) + Block_hash.to_string + b1 b2 + let test_hashset (type t) (module Store: Store_sigs.STORE with type t = t) (s: Store.t) = let module BlockSet = Block_hash.Set in @@ -219,25 +228,34 @@ let test_hashset (type t) let bhset : BlockSet.t = BlockSet.add bh2 (BlockSet.add bh1 BlockSet.empty) in StoreSet.store_all s bhset >>= fun () -> StoreSet.read_all s >>= fun bhset' -> - Assert.equal_block_set ~msg:__LOC__ bhset bhset' ; + equal_block_set ~msg:__LOC__ bhset bhset' ; let bhset2 = Pervasives.(bhset |> BlockSet.add bh3 |> BlockSet.remove bh1) in StoreSet.store_all s bhset2 >>= fun () -> StoreSet.read_all s >>= fun bhset2' -> - Assert.equal_block_set ~msg:__LOC__ bhset2 bhset2' ; + equal_block_set ~msg:__LOC__ bhset2 bhset2' ; StoreSet.fold s ~init:BlockSet.empty ~f:(fun bh acc -> Lwt.return (BlockSet.add bh acc)) >>= fun bhset2'' -> - Assert.equal_block_set ~msg:__LOC__ bhset2 bhset2'' ; + equal_block_set ~msg:__LOC__ bhset2 bhset2'' ; Store.store s ["day";"current"] (MBytes.of_string "Mercredi") >>= fun () -> StoreSet.remove_all s >>= fun () -> StoreSet.read_all s >>= fun empty -> - Assert.equal_block_set ~msg:__LOC__ BlockSet.empty empty ; + equal_block_set ~msg:__LOC__ BlockSet.empty empty ; check (module Store) s ["day";"current"] (MBytes.of_string "Mercredi") >>= fun () -> Lwt.return_unit (** HashMap *) +let equal_block_map ?msg ~eq map1 map2 = + let msg = Assert.format_msg msg in + let b1 = Block_hash.Map.bindings map1 + and b2 = Block_hash.Map.bindings map2 in + Assert.make_equal_list ?msg + (fun (h1, b1) (h2, b2) -> Block_hash.equal h1 h2 && eq b1 b2) + (fun (h1, _) -> Block_hash.to_string h1) + b1 b2 + let test_hashmap (type t) (module Store: Store_sigs.STORE with type t = t) (s: Store.t) = let module BlockMap = Block_hash.Map in @@ -257,12 +275,12 @@ let test_hashmap (type t) BlockMap.add bh1 (1, 'a') |> BlockMap.add bh2 (2, 'b')) in StoreMap.store_all s map >>= fun () -> StoreMap.read_all s >>= fun map' -> - Assert.equal_block_map ~msg:__LOC__ ~eq map map' ; + equal_block_map ~msg:__LOC__ ~eq map map' ; let map2 = Pervasives.(map |> BlockMap.add bh3 (3, 'c') |> BlockMap.remove bh1) in StoreMap.store_all s map2 >>= fun () -> StoreMap.read_all s >>= fun map2' -> - Assert.equal_block_map ~msg:__LOC__ ~eq map2 map2' ; + equal_block_map ~msg:__LOC__ ~eq map2 map2' ; Lwt.return_unit (** Functors *) @@ -316,6 +334,11 @@ module SubBlocksMap = end)) (Block_hash.Map) +let equal_block_hash_list ?msg l1 l2 = + let msg = Assert.format_msg msg in + let pr_block_hash = Block_hash.to_short_b58check in + Assert.make_equal_list ?msg Block_hash.equal pr_block_hash l1 l2 + let test_subblock s = SubBlocksSet.known s bh1 >>= fun known -> Assert.is_false ~msg:__LOC__ known ; @@ -328,7 +351,7 @@ let test_subblock s = Block_hash.Set.empty |> Block_hash.Set.add bh1 |> Block_hash.Set.add bh2 in - Assert.equal_block_set ~msg:__LOC__ set set' ; + equal_block_set ~msg:__LOC__ set set' ; SubBlocksSet.remove s bh2 >>= fun () -> let set = Block_hash.Set.empty @@ -336,13 +359,13 @@ let test_subblock s = |> Block_hash.Set.add bh3 in SubBlocksSet.store_all s set >>= fun () -> SubBlocksSet.elements s >>= fun elts -> - Assert.equal_block_hash_list ~msg:__LOC__ + equal_block_hash_list ~msg:__LOC__ (List.sort Block_hash.compare elts) (List.sort Block_hash.compare [bh3 ; bh3']) ; SubBlocksSet.store s bh2 >>= fun () -> SubBlocksSet.remove s bh3 >>= fun () -> SubBlocksSet.elements s >>= fun elts -> - Assert.equal_block_hash_list ~msg:__LOC__ + equal_block_hash_list ~msg:__LOC__ (List.sort Block_hash.compare elts) (List.sort Block_hash.compare [bh2 ; bh3']) ; SubBlocksMap.known s bh1 >>= fun known -> @@ -360,19 +383,19 @@ let test_subblock s = |> Block_hash.Map.add bh1 v1 |> Block_hash.Map.add bh2 v2 in SubBlocksMap.read_all s >>= fun map' -> - Assert.equal_block_map ~eq:(=) ~msg:__LOC__ map map' ; + equal_block_map ~eq:(=) ~msg:__LOC__ map map' ; SubBlocksSet.remove_all s >>= fun () -> SubBlocksSet.elements s >>= fun elts -> - Assert.equal_block_hash_list ~msg:__LOC__ elts [] ; + equal_block_hash_list ~msg:__LOC__ elts [] ; SubBlocksMap.read_all s >>= fun map' -> - Assert.equal_block_map ~eq:(=) ~msg:__LOC__ map map' ; + equal_block_map ~eq:(=) ~msg:__LOC__ map map' ; SubBlocksSet.store s bh3 >>= fun () -> SubBlocks.indexes s >>= fun keys -> - Assert.equal_block_hash_list ~msg:__LOC__ + equal_block_hash_list ~msg:__LOC__ (List.sort Block_hash.compare keys) (List.sort Block_hash.compare [bh1;bh2;bh3]) ; @@ -434,6 +457,7 @@ let tests : (string * (Store.t -> unit Lwt.t)) list = [ ] let () = + let module Test = Tezos_test_helpers.Test.Make(Error_monad) in Test.run "store." (List.map (fun (s, f) -> s, wrap_raw_store_init f) tests_raw @ List.map (fun (s, f) -> s, wrap_store_init f) tests) diff --git a/test/test_basic.sh b/test/test_basic.sh index 224f6d96f..756483b87 100755 --- a/test/test_basic.sh +++ b/test/test_basic.sh @@ -3,7 +3,7 @@ set -e test_dir="$(cd "$(dirname "$0")" && echo "$(pwd -P)")" -source $test_dir/lib/test_lib.inc.sh "$@" +source $test_dir/test_lib.inc.sh "$@" start_node 1 activate_alpha diff --git a/test/test_contracts.sh b/test/test_contracts.sh index bb5f7c089..5cae653ac 100755 --- a/test/test_contracts.sh +++ b/test/test_contracts.sh @@ -4,7 +4,7 @@ set -e set -o pipefail test_dir="$(cd "$(dirname "$0")" && echo "$(pwd -P)")" -source $test_dir/lib/test_lib.inc.sh "$@" +source $test_dir/test_lib.inc.sh "$@" start_node 1 activate_alpha diff --git a/test/lib/test_lib.inc.sh b/test/test_lib.inc.sh similarity index 100% rename from test/lib/test_lib.inc.sh rename to test/test_lib.inc.sh diff --git a/test/test_multinode.sh b/test/test_multinode.sh index 0091c739c..c03875437 100755 --- a/test/test_multinode.sh +++ b/test/test_multinode.sh @@ -3,7 +3,7 @@ set -e test_dir="$(cd "$(dirname "$0")" && echo "$(pwd -P)")" -source $test_dir/lib/test_lib.inc.sh "$@" +source $test_dir/test_lib.inc.sh "$@" expected_connections=4 max_peer_id=8 diff --git a/test/utils/jbuild b/test/utils/jbuild index 4c062baea..16d6dce9e 100644 --- a/test/utils/jbuild +++ b/test/utils/jbuild @@ -1,31 +1,23 @@ (jbuild_version 1) (executables - ((names (test_data_encoding - test_lwt_pipe + ((names (test_lwt_pipe test_merkle - test_stream_data_encoding test_utils - bench_data_encoding test_mbytes_buffer)) - (libraries (tezos-base test_lib)) + (libraries (tezos-base tezos-test-helpers)) (flags (:standard -w -9-32 -safe-string - -open Tezos_base__TzPervasives)))) + -open Tezos_base__TzPervasives + -open Tezos_test_helpers)))) (alias ((name buildtest) - (deps (test_data_encoding.exe - test_lwt_pipe.exe + (deps (test_lwt_pipe.exe test_merkle.exe - test_stream_data_encoding.exe test_utils.exe test_mbytes_buffer.exe)))) -(alias - ((name runtest_data_encoding) - (action (run ${exe:test_data_encoding.exe})))) - (alias ((name runtest_lwt_pipe) (action (run ${exe:test_lwt_pipe.exe})))) @@ -34,10 +26,6 @@ ((name runtest_merkle) (action (run ${exe:test_merkle.exe})))) -(alias - ((name runtest_stream_data_encoding) - (action (run ${exe:test_stream_data_encoding.exe})))) - (alias ((name runtest_utils) (action (run ${exe:test_utils.exe})))) @@ -48,10 +36,8 @@ (alias ((name runtest) - (deps ((alias runtest_data_encoding) - (alias runtest_lwt_pipe) + (deps ((alias runtest_lwt_pipe) (alias runtest_merkle) - (alias runtest_stream_data_encoding) (alias runtest_utils) (alias runtest_mbytes_buffer))))) diff --git a/test/utils/test_merkle.ml b/test/utils/test_merkle.ml index 18b3cbe1c..d027dec25 100644 --- a/test/utils/test_merkle.ml +++ b/test/utils/test_merkle.ml @@ -80,4 +80,5 @@ let tests : (string * (string -> unit tzresult Lwt.t)) list = [ ] let () = + let module Test = Tezos_test_helpers.Test.Make(Error_monad) in Test.run "merkel." tests diff --git a/test/utils/test_utils.ml b/test/utils/test_utils.ml index e3122f8ca..83b0b637b 100644 --- a/test/utils/test_utils.ml +++ b/test/utils/test_utils.ml @@ -50,4 +50,5 @@ let tests : (string * (string -> unit tzresult Lwt.t)) list = [ ] let () = + let module Test = Tezos_test_helpers.Test.Make(Error_monad) in Test.run "utils." tests