From a6ab12e701077c8aa26004874c3ea2f9ffd0e349 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gr=C3=A9goire=20Henry?= Date: Mon, 5 Feb 2018 19:37:18 +0100 Subject: [PATCH] Context: add an alternative in-memory only implementation --- src/lib_protocol_environment_client/mem.ml | 12 ++ .../mem_context.ml | 114 ++++++++++++++ .../mem_context.mli | 15 ++ .../test/jbuild | 29 ++++ .../test/test_mem_context.ml | 148 ++++++++++++++++++ .../tezos-protocol-environment-client.opam | 1 + 6 files changed, 319 insertions(+) create mode 100644 src/lib_protocol_environment_client/mem.ml create mode 100644 src/lib_protocol_environment_client/mem_context.ml create mode 100644 src/lib_protocol_environment_client/mem_context.mli create mode 100644 src/lib_protocol_environment_client/test/jbuild create mode 100644 src/lib_protocol_environment_client/test/test_mem_context.ml diff --git a/src/lib_protocol_environment_client/mem.ml b/src/lib_protocol_environment_client/mem.ml new file mode 100644 index 000000000..40ac71387 --- /dev/null +++ b/src/lib_protocol_environment_client/mem.ml @@ -0,0 +1,12 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +module Make(Param : sig val name: string end)() = + Tezos_base.Protocol_environment.MakeV1 + (Param)(Mem_context)(Fake_updater.Make(Mem_context))() diff --git a/src/lib_protocol_environment_client/mem_context.ml b/src/lib_protocol_environment_client/mem_context.ml new file mode 100644 index 000000000..45da9fc54 --- /dev/null +++ b/src/lib_protocol_environment_client/mem_context.ml @@ -0,0 +1,114 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +module StringMap = Map.Make(String) + +type key = string list +type value = MBytes.t + +type t = + | Dir of t StringMap.t + | Key of value + +let empty = Dir StringMap.empty + +let rec raw_get m k = + match k, m with + | [], m -> Some m + | n :: k, Dir m -> begin + try raw_get (StringMap.find n m) k + with Not_found -> None + end + | _ :: _, Key _ -> None + +let rec raw_set m k v = + match k, m, v with + | [], (Key _ as m), Some v -> + if m = v then None else Some v + | [], (Dir _ as m), Some v -> + if m == v then None else Some v + | [], (Key _ | Dir _), None -> Some empty + | n :: k, Dir m, _ -> begin + match raw_set (StringMap.find n m) k v with + | exception Not_found -> begin + match raw_set empty k v with + | None -> None + | Some rm -> + if rm = empty then + Some (Dir (StringMap.remove n m)) + else + Some (Dir (StringMap.add n rm m)) + end + | None -> None + | Some rm -> + if rm = empty then + Some (Dir (StringMap.remove n m)) + else + Some (Dir (StringMap.add n rm m)) + end + | _ :: _, Key _, None -> None + | _ :: _, Key _, Some _ -> + Pervasives.failwith "Mem_context.set" + +let mem m k = + match raw_get m k with + | Some (Key _) -> Lwt.return_true + | Some (Dir _) | None -> Lwt.return_false + +let dir_mem m k = + match raw_get m k with + | Some (Dir _) -> Lwt.return_true + | Some (Key _) | None -> Lwt.return_false + +let get m k = + match raw_get m k with + | Some (Key v) -> Lwt.return_some v + | Some (Dir _) | None -> Lwt.return_none + +let set m k v = + match raw_set m k (Some (Key v)) with + | None -> Lwt.return m + | Some m -> Lwt.return m +let del m k = + (* TODO assert key *) + match raw_set m k None with + | None -> Lwt.return m + | Some m -> Lwt.return m +let remove_rec m k = + match raw_set m k None with + | None -> Lwt.return m + | Some m -> Lwt.return m + +let fold m k ~init ~f = + match raw_get m k with + | None -> Lwt.return init + | Some (Key _) -> Lwt.return init + | Some (Dir m) -> + StringMap.fold + (fun n m acc -> + acc >>= fun acc -> + match m with + | Key _ -> f (`Key (k @ [n])) acc + | Dir _ -> f (`Dir (k @ [n])) acc) + m (Lwt.return init) + +let rec pp ppf m = + match m with + | Key s -> Format.fprintf ppf "%s" (MBytes.to_string s) + | Dir m -> + StringMap.iter + (fun n m -> + match m with + | Key s -> + Format.fprintf ppf "- %s: %s@ " n (MBytes.to_string s) + | Dir m -> + Format.fprintf ppf "- %s:@[@ %a@]@ " n pp (Dir m)) + m + +let dump m = Format.eprintf "@[%a@]" pp m diff --git a/src/lib_protocol_environment_client/mem_context.mli b/src/lib_protocol_environment_client/mem_context.mli new file mode 100644 index 000000000..f06382baa --- /dev/null +++ b/src/lib_protocol_environment_client/mem_context.mli @@ -0,0 +1,15 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +include Protocol_environment.CONTEXT + +val empty : t + +val pp : Format.formatter -> t -> unit +val dump : t -> unit diff --git a/src/lib_protocol_environment_client/test/jbuild b/src/lib_protocol_environment_client/test/jbuild new file mode 100644 index 000000000..32fc67b47 --- /dev/null +++ b/src/lib_protocol_environment_client/test/jbuild @@ -0,0 +1,29 @@ +(jbuild_version 1) + +(executables + ((names (test_mem_context)) + (libraries (tezos-base + tezos-protocol-environment-client + tezos-test-helpers)) + (flags (:standard -w -9-32 + -safe-string + -open Tezos_base__TzPervasives + -open Tezos_test_helpers + -open Tezos_protocol_environment_client)))) + +(alias + ((name buildtest) + (deps (test_mem_context.exe)))) + +(alias + ((name runtest_mem_context) + (action (run ${exe:test_mem_context.exe})))) + +(alias + ((name runtest) + (deps ((alias runtest_mem_context))))) + +(alias + ((name runtest_indent) + (deps ((glob_files *.ml) (glob_files *.mli))) + (action (run bash ${libexec:tezos-stdlib:test-ocp-indent.sh} ${^})))) diff --git a/src/lib_protocol_environment_client/test/test_mem_context.ml b/src/lib_protocol_environment_client/test/test_mem_context.ml new file mode 100644 index 000000000..95295a3ad --- /dev/null +++ b/src/lib_protocol_environment_client/test/test_mem_context.ml @@ -0,0 +1,148 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Mem_context + +(** Context creation *) + +let create_block2 ctxt = + set ctxt ["a"; "b"] (MBytes.of_string "Novembre") >>= fun ctxt -> + set ctxt ["a"; "c"] (MBytes.of_string "Juin") >>= fun ctxt -> + set ctxt ["version";] (MBytes.of_string "0.0") >>= fun ctxt -> + Lwt.return ctxt + +let create_block3a ctxt = + del ctxt ["a"; "b"] >>= fun ctxt -> + set ctxt ["a"; "d"] (MBytes.of_string "Mars") >>= fun ctxt -> + Lwt.return ctxt + +let create_block3b ctxt = + del ctxt ["a"; "c"] >>= fun ctxt -> + set ctxt ["a"; "d"] (MBytes.of_string "Février") >>= fun ctxt -> + Lwt.return ctxt + +type t = { + genesis: Mem_context.t ; + block2: Mem_context.t ; + block3a: Mem_context.t ; + block3b: Mem_context.t ; +} + +let wrap_context_init f _base_dir = + let genesis = Mem_context.empty in + create_block2 genesis >>= fun block2 -> + create_block3a block2 >>= fun block3a -> + create_block3b block2 >>= fun block3b -> + f { genesis; block2 ; block3a; block3b } >>= fun result -> + return result + +(** Simple test *) + +let c = function + | None -> None + | Some s -> Some (MBytes.to_string s) + +let test_simple { block2 = ctxt } = + get ctxt ["version"] >>= fun version -> + Assert.equal_string_option ~msg:__LOC__ (c version) (Some "0.0") ; + get ctxt ["a";"b"] >>= fun novembre -> + Assert.equal_string_option (Some "Novembre") (c novembre) ; + get ctxt ["a";"c"] >>= fun juin -> + Assert.equal_string_option ~msg:__LOC__ (Some "Juin") (c juin) ; + Lwt.return () + +let test_continuation { block3a = ctxt } = + get ctxt ["version"] >>= fun version -> + Assert.equal_string_option ~msg:__LOC__ (Some "0.0") (c version) ; + get ctxt ["a";"b"] >>= fun novembre -> + Assert.is_none ~msg:__LOC__ (c novembre) ; + get ctxt ["a";"c"] >>= fun juin -> + Assert.equal_string_option ~msg:__LOC__ (Some "Juin") (c juin) ; + get ctxt ["a";"d"] >>= fun mars -> + Assert.equal_string_option ~msg:__LOC__ (Some "Mars") (c mars) ; + Lwt.return () + +let test_fork { block3b = ctxt } = + get ctxt ["version"] >>= fun version -> + Assert.equal_string_option ~msg:__LOC__ (Some "0.0") (c version) ; + get ctxt ["a";"b"] >>= fun novembre -> + Assert.equal_string_option ~msg:__LOC__ (Some "Novembre") (c novembre) ; + get ctxt ["a";"c"] >>= fun juin -> + Assert.is_none ~msg:__LOC__ (c juin) ; + get ctxt ["a";"d"] >>= fun mars -> + Assert.equal_string_option ~msg:__LOC__ (Some "Février") (c mars) ; + Lwt.return () + +let test_replay { genesis = ctxt0 } = + set ctxt0 ["version"] (MBytes.of_string "0.0") >>= fun ctxt1 -> + set ctxt1 ["a"; "b"] (MBytes.of_string "Novembre") >>= fun ctxt2 -> + set ctxt2 ["a"; "c"] (MBytes.of_string "Juin") >>= fun ctxt3 -> + set ctxt3 ["a"; "d"] (MBytes.of_string "July") >>= fun ctxt4a -> + 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.equal_string_option ~msg:__LOC__ (Some "Novembre") (c novembre) ; + get ctxt5a ["a";"b"] >>= fun november -> + Assert.equal_string_option ~msg:__LOC__ (Some "November") (c november) ; + get ctxt5a ["a";"d"] >>= fun july -> + Assert.equal_string_option ~msg:__LOC__ (Some "July") (c july) ; + get ctxt4b ["a";"b"] >>= fun novembre -> + Assert.equal_string_option ~msg:__LOC__ (Some "Novembre") (c novembre) ; + get ctxt4b ["a";"d"] >>= fun juillet -> + Assert.equal_string_option ~msg:__LOC__ (Some "Juillet") (c juillet) ; + Lwt.return () + +let fold_keys s k ~init ~f = + let rec loop k acc = + fold s k ~init:acc + ~f:(fun file acc -> + match file with + | `Key k -> f k acc + | `Dir k -> loop k acc) in + loop k init +let keys t = fold_keys t ~init:[] ~f:(fun k acc -> Lwt.return (k :: acc)) + +let test_fold { genesis = ctxt } = + set ctxt ["a"; "b"] (MBytes.of_string "Novembre") >>= fun ctxt -> + set ctxt ["a"; "c"] (MBytes.of_string "Juin") >>= fun ctxt -> + set ctxt ["a"; "d"; "e"] (MBytes.of_string "Septembre") >>= fun ctxt -> + set ctxt ["f";] (MBytes.of_string "Avril") >>= fun ctxt -> + set ctxt ["g"; "h"] (MBytes.of_string "Avril") >>= fun ctxt -> + keys ctxt [] >>= fun l -> + Assert.equal_string_list_list ~msg:__LOC__ + [["a";"b"]; + ["a";"c"]; + ["a";"d";"e"]; + ["f"]; + ["g";"h"]] (List.sort compare l) ; + keys ctxt ["a"] >>= fun l -> + Assert.equal_string_list_list + ~msg:__LOC__ [["a";"b"]; ["a";"c"]; ["a";"d";"e"]] + (List.sort compare l) ; + keys ctxt ["f"] >>= fun l -> + Assert.equal_string_list_list ~msg:__LOC__ [] l ; + keys ctxt ["g"] >>= fun l -> + Assert.equal_string_list_list ~msg:__LOC__ [["g";"h"]] l ; + keys ctxt ["i"] >>= fun l -> + Assert.equal_string_list_list ~msg:__LOC__ [] l ; + Lwt.return () + +(******************************************************************************) + +let tests : (string * (t -> unit Lwt.t)) list = [ + "simple", test_simple ; + "continuation", test_continuation ; + "fork", test_fork ; + "replay", test_replay ; + "fold", test_fold ; +] + +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/src/lib_protocol_environment_client/tezos-protocol-environment-client.opam b/src/lib_protocol_environment_client/tezos-protocol-environment-client.opam index 732317837..e7da705c3 100644 --- a/src/lib_protocol_environment_client/tezos-protocol-environment-client.opam +++ b/src/lib_protocol_environment_client/tezos-protocol-environment-client.opam @@ -12,6 +12,7 @@ depends: [ "tezos-base" "tezos-micheline" "tezos-protocol-environment-sigs" + "tezos-test-helpers" { test } ] build: [ [ "jbuilder" "build" "-p" name "-j" jobs ]