diff --git a/src/lib_protocol_environment/dummy_context.ml b/src/lib_protocol_environment/dummy_context.ml index 1d60057df513df8a2f6e30f1c9e1f1fa375cb219..cf870902eb406448b3fcf53514e0314559c59647 100644 --- a/src/lib_protocol_environment/dummy_context.ml +++ b/src/lib_protocol_environment/dummy_context.ml @@ -48,6 +48,8 @@ module M = struct let set_protocol _ _ = assert false + let get_protocol _ = assert false + let fork_test_chain _ ~protocol:_ ~expiration:_ = assert false end diff --git a/src/lib_protocol_environment/dune b/src/lib_protocol_environment/dune index 16bf863fc021ad3127b036ac05aa7b4dd050d7d1..574cfc6088a9013e8a7bc2e7dfbf2553a8b9b986 100644 --- a/src/lib_protocol_environment/dune +++ b/src/lib_protocol_environment/dune @@ -5,7 +5,8 @@ tezos-sapling tezos-protocol-environment-sigs tezos-protocol-environment-structs - tezos-micheline) + tezos-micheline + tezos-storage.memory) (flags (:standard -open Tezos_base__TzPervasives -open Tezos_micheline)) (wrapped false) diff --git a/src/lib_protocol_environment/environment_context.ml b/src/lib_protocol_environment/environment_context.ml index cb97dc1fce33f806030f7d837dcb7cc1f809a98c..a1d2b9da84318d63d47c8234723b0189c20824dc 100644 --- a/src/lib_protocol_environment/environment_context.ml +++ b/src/lib_protocol_environment/environment_context.ml @@ -51,6 +51,8 @@ module type CONTEXT = sig val set_protocol : t -> Protocol_hash.t -> t Lwt.t + val get_protocol : t -> Protocol_hash.t Lwt.t + val fork_test_chain : t -> protocol:Protocol_hash.t -> expiration:Time.Protocol.t -> t Lwt.t end @@ -99,6 +101,9 @@ module Context = struct Ops.set_protocol ctxt protocol_hash >>= fun ctxt -> Lwt.return (Context {ops; ctxt; kind}) + let get_protocol (Context {ops = (module Ops); ctxt; _}) = + Ops.get_protocol ctxt + let fork_test_chain (Context {ops = (module Ops) as ops; ctxt; kind}) ~protocol ~expiration = Ops.fork_test_chain ctxt ~protocol ~expiration diff --git a/src/lib_protocol_environment/environment_context.mli b/src/lib_protocol_environment/environment_context.mli index 4790388bb19c3e1819bb548514855d3865561ddc..2b0044e2615a9dba74752f2bd8f79f0e698794e3 100644 --- a/src/lib_protocol_environment/environment_context.mli +++ b/src/lib_protocol_environment/environment_context.mli @@ -49,6 +49,8 @@ module type CONTEXT = sig val set_protocol : t -> Protocol_hash.t -> t Lwt.t + val get_protocol : t -> Protocol_hash.t Lwt.t + val fork_test_chain : t -> protocol:Protocol_hash.t -> expiration:Time.Protocol.t -> t Lwt.t end diff --git a/src/lib_protocol_environment/memory_context.ml b/src/lib_protocol_environment/memory_context.ml index 3578be1f69cab3b2f5a5f7b5a4782a98317597f6..b2fc6a4848a079fb3f8414e67c0ae413ecbe5960 100644 --- a/src/lib_protocol_environment/memory_context.ml +++ b/src/lib_protocol_environment/memory_context.ml @@ -24,165 +24,38 @@ (*****************************************************************************) module M = struct - module StringMap = Map.Make (String) - - type key = string list - - type value = Bytes.t - - type t = Dir of t StringMap.t | Key of value - - let pp_key = - Format.( - pp_print_list - ~pp_sep:(fun ppf () -> pp_print_string ppf " / ") - pp_print_string) - - let empty = Dir StringMap.empty - - let rec raw_get m k = - match (k, m) with - | ([], m) -> - Some m - | (n :: k, Dir m) -> ( - match StringMap.find n m with Some res -> raw_get res k | None -> None ) - | (_ :: _, 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, _) -> ( - match raw_set (Option.value ~default:empty (StringMap.find n m)) k v with - | None -> - None - | Some rm when rm = empty -> - Some (Dir (StringMap.remove n m)) - | Some rm -> - Some (Dir (StringMap.add n rm m)) ) - | (_ :: _, Key _, None) -> - None - | (_ :: _, Key _, Some _) -> - Format.kasprintf - Stdlib.failwith - "Mem_context.set: cannot set value below key %a, because there's a \ - Key value here. A value can only be nested below a Dir, not a Key" - pp_key - k - - 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 + include Tezos_storage_memory.Context - let set m k v = - match raw_set m k (Some (Key v)) with - | None -> - Lwt.return m - | Some m -> - Lwt.return m + let set = add + + let get = find + + let dir_mem = mem_tree - let remove_rec m k = - match raw_set m k None with None -> Lwt.return m | Some m -> Lwt.return m + let remove_rec = remove - let copy m ~from ~to_ = - match raw_get m from with + let copy ctxt ~from ~to_ = + find_tree ctxt from + >>= function | None -> Lwt.return_none - | Some v -> ( - match raw_set m to_ (Some v) with - | Some _ as v -> - Lwt.return v - | None -> - Format.kasprintf - Lwt.fail_with - "Mem_context.copy %a %a: The value is already set." - pp_key - from - pp_key - to_ - | exception Failure s -> - Format.kasprintf - Lwt.fail_with - "Mem_context.copy %a %a: Failed with %s" - pp_key - from - pp_key - to_ - s ) + | Some sub_tree -> + add_tree ctxt to_ sub_tree >>= Lwt.return_some type key_or_dir = [`Key of key | `Dir of key] - 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 current_protocol_key = ["protocol"] - - let set_protocol v key = - raw_set v current_protocol_key (Some (Key (Protocol_hash.to_bytes key))) - |> function Some m -> Lwt.return m | None -> assert false + let fold t root ~init ~f = + fold ~depth:(`Eq 1) t root ~init ~f:(fun k t acc -> + let k = root @ k in + match Tree.kind t with + | `Value _ -> + f (`Key k) acc + | `Tree -> + f (`Dir k) acc) - let fork_test_chain c ~protocol:_ ~expiration:_ = Lwt.return c + let set_protocol = add_protocol - let encoding : t Data_encoding.t = - let open Data_encoding in - mu "memory_context" (fun encoding -> - let map_encoding = - conv - (fun map -> List.of_seq (StringMap.to_seq map)) - (fun bindings -> StringMap.of_seq (List.to_seq bindings)) - (list (tup2 string encoding)) - in - union - [ case - ~title:"directory" - (Tag 0) - map_encoding - (function Dir map -> Some map | Key _ -> None) - (fun map -> Dir map); - case - ~title:"value" - (Tag 1) - bytes - (function Key v -> Some v | Dir _ -> None) - (fun v -> Key v) ]) + let fork_test_chain c ~protocol:_ ~expiration:_ = Lwt.return c end open Tezos_protocol_environment diff --git a/src/lib_protocol_environment/proxy_context.ml b/src/lib_protocol_environment/proxy_context.ml index b0cc5f8e0dc0cb16ef01ed7db28db9483a4d24c7..0c9602d47861e236364203b963ce22b530673309 100644 --- a/src/lib_protocol_environment/proxy_context.ml +++ b/src/lib_protocol_environment/proxy_context.ml @@ -23,14 +23,14 @@ (* *) (*****************************************************************************) -module StringMap = TzString.Map +module Local = Tezos_storage_memory.Context module M = struct - type key = string list + type key = Local.key - type value = Bytes.t + type value = Local.value - type tree = Dir of tree StringMap.t | Key of value + type tree = [`Value of bytes | `Tree of tree TzString.Map.t] module type ProxyDelegate = sig val proxy_dir_mem : key -> bool tzresult Lwt.t @@ -42,11 +42,31 @@ module M = struct type proxy_delegate = (module ProxyDelegate) - (* When the option is [None], this instance of [M] should behave - like [Memory_context]. *) - type t = {proxy : proxy_delegate option; tree : tree} + (* When the [proxy] option is [None], this instance of [M] should + behave like [Memory_context]. *) + type t = {proxy : proxy_delegate option; local : Local.tree} - let empty = Dir StringMap.empty + let rec tree_size_aux acc = function + | `Value _ -> + acc + 1 + | `Tree t -> + TzString.Map.fold (fun _ t acc -> tree_size_aux (acc + 1) t) t acc + + let tree_size = tree_size_aux 0 + + let empty = `Tree TzString.Map.empty +end + +module C = struct + type key = M.key + + type value = M.value + + type t = M.t + + (* [root] is the root of the current subtree; [path] is the path + from the underlying local store. *) + type tree = {root : M.t; path : key} (** Generic pretty printing functions *) let pp_key ppf key = @@ -80,210 +100,126 @@ module M = struct ("trace", Error_monad.trace_encoding) end - (* Useful for debugging *) - let rec _pp_tree ppf = function - | Key _b -> - Format.fprintf ppf "key:" - | Dir t -> - StringMap.iter - (fun k t -> Format.fprintf ppf "@[%s: @[%a@]@]" k _pp_tree t) - t - - let rec tree_size = function - | Key _ -> - 1 - | Dir t -> - StringMap.fold (fun _ t' i -> tree_size t' + i) t 0 - - let rec local_get m k = - match (k, m) with - | ([], m) -> - Some m - | (n :: k, Dir m) -> ( - match StringMap.find_opt n m with - | Some res -> - local_get res k - | None -> - None ) - | (_ :: _, Key _) -> - None + type elt = Key of value | Dir of Local.tree - let raw_get m k = - match local_get m.tree k with + let elt t = match Local.Tree.kind t with `Value v -> Key v | `Tree -> Dir t + + let raw_find (t : tree) k = + Local.find_tree t.root.local k + >>= function + | Some x -> + Lwt.return_some x | None -> ( L.(S.emit proxy_context_missing) k >>= fun () -> - match m.proxy with + match t.root.proxy with | None -> Lwt.return_none - | Some proxy -> ( - let (module ProxyDelegation) = proxy in - ProxyDelegation.proxy_get k + | Some (module ProxyDelegation) -> ( + ProxyDelegation.proxy_get (t.path @ k) >>= function | Error err -> L.(S.emit delegation_error ("get", err)) >>= fun () -> Lwt.return_none | Ok x -> - Lwt.return x ) ) - | Some _ as v -> - Lwt.return v - - let rec raw_set m k v = - (* This function returns the update it did. This is used in the - recursive cases to find out what to do. In case no update was - done, this allows to maximise persistence (keeping most part - of the existing structure). - - That is why, in the three base cases (the first three pipes below), - we check whether the value being put equals the value that is there - already (if any). If they are equal, no update needs to be done; - and hence None is returned. - *) - 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, _) -> ( - (* recursive case: inspect recursive modification *) - match - raw_set (Option.value ~default:empty (StringMap.find_opt n m)) k v - with - | None -> - None - | Some rm when rm = empty -> - Some (Dir (StringMap.remove n m)) - | Some rm -> - Some (Dir (StringMap.add n rm m)) ) - | (_ :: _, Key _, None) -> - None - | (_ :: _, Key _, Some _) -> - Stdlib.failwith "Proxy_context.set" - - let raw_set m k v = - let u = raw_set m.tree k v in - match u with None -> None | Some u -> Some {m with tree = u} - - let mem m k = - match local_get m.tree k with - | Some (Key _) -> - Lwt.return_true - | Some (Dir _) -> - Lwt.return_false - | None -> ( - match m.proxy with - | None -> - Lwt.return_false - | Some proxy -> ( - let (module ProxyDelegation) = proxy in - ProxyDelegation.proxy_mem k - >>= function - | Error err -> - L.(S.emit delegation_error ("mem", err)) - >>= fun () -> Lwt.return_false - | Ok x -> - Lwt.return x ) ) + Lwt.return (Option.map Local.Tree.of_raw x) ) ) - let dir_mem m k = - match local_get m.tree k with - | Some (Key _) -> - Lwt.return_false - | Some (Dir _) -> - Lwt.return_true + let raw_mem_aux kind (t : tree) k = + Local.find_tree t.root.local k + >|= Option.map Local.Tree.kind + >>= function + | Some (`Value _) -> + Lwt.return (kind = `Value) + | Some `Tree -> + Lwt.return (kind = `Tree) | None -> ( - match m.proxy with + match t.root.proxy with | None -> Lwt.return_false - | Some proxy -> ( - let (module ProxyDelegation) = proxy in - ProxyDelegation.proxy_dir_mem k + | Some (module ProxyDelegation) -> ( + let mem = + match kind with + | `Value -> + ProxyDelegation.proxy_mem + | `Tree -> + ProxyDelegation.proxy_dir_mem + in + mem (t.path @ k) >>= function | Error err -> - L.(S.emit delegation_error ("dir_mem", err)) + let msg = + match kind with `Value -> "mem" | `Tree -> "dir_mem" + in + L.(S.emit delegation_error (msg, err)) >>= fun () -> Lwt.return_false | Ok x -> Lwt.return x ) ) - let get m k = - raw_get m k - >>= function - | Some (Dir _) | None -> - Lwt.return_none - | Some (Key v) -> - Lwt.return_some v + let raw_mem = raw_mem_aux `Value - let set m k v = - match raw_set m k (Some (Key v)) with - | None -> - Lwt.return m - | Some m -> - Lwt.return m + let raw_mem_tree = raw_mem_aux `Tree + + let root t = {root = t; path = []} + + let mem t k = raw_mem (root t) k + + let mem_tree t k = raw_mem_tree (root t) k + + let find t k = + raw_find (root t) k + >|= Option.map elt + >|= function Some (Key v) -> Some v | _ -> None + + let find_tree t k = raw_find (root t) k + + let add_tree (t : t) k v = + Local.add_tree t.local k v + >|= fun local -> if t.local == local then t else {t with local} - let remove_rec m k = - match raw_set m k None with None -> Lwt.return m | Some m -> Lwt.return m + let add (t : t) k v = + Local.add t.local k v + >|= fun local -> if t.local == local then t else {t with local} - let copy m ~from ~to_ = - raw_get m from + let remove (t : t) k = + Local.remove t.local k + >|= fun local -> if t.local == local then t else {t with local} + + let set = add + + let get = find + + let dir_mem = mem_tree + + let remove_rec = remove + + let copy ctxt ~from ~to_ = + find_tree ctxt from >>= function | None -> Lwt.return_none - | Some v -> ( - let pp_path = - Format.( - pp_print_list - ~pp_sep:(fun ppf () -> pp_print_string ppf " / ") - pp_print_string) - in - match raw_set m to_ (Some v) with - | Some _ as v -> - Lwt.return v - | None -> - Format.kasprintf - Lwt.fail_with - "Proxy_context.copy %a %a: The value is already set." - pp_path - from - pp_path - to_ - | exception Failure s -> - Format.kasprintf - Lwt.fail_with - "Proxy_context.copy %a %a: Failed with %s" - pp_path - from - pp_path - to_ - s ) + | Some sub_tree -> + add_tree ctxt to_ sub_tree >>= Lwt.return_some type key_or_dir = [`Key of key | `Dir of key] - let fold m k ~init ~f = - raw_get m k + let fold ctxt root ~init ~f = + find_tree ctxt root >>= function | 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 current_protocol_key = ["protocol"] - - let set_protocol v key = - raw_set v current_protocol_key (Some (Key (Protocol_hash.to_bytes key))) - |> function Some m -> Lwt.return m | None -> assert false + | Some t -> + Local.Tree.fold ~depth:(`Eq 1) t [] ~init ~f:(fun k t acc -> + let k = root @ k in + match Local.Tree.kind t with + | `Value _ -> + f (`Key k) acc + | `Tree -> + f (`Dir k) acc) + + let set_protocol (t : t) p = + Local.add_protocol t.local p >|= fun local -> {t with local} + + let get_protocol (t : t) = Local.get_protocol t.local let fork_test_chain c ~protocol:_ ~expiration:_ = Lwt.return c end @@ -292,17 +228,17 @@ open Tezos_protocol_environment type _ Context.kind += Proxy : M.t Context.kind -let ops = (module M : CONTEXT with type t = 'ctxt) +let ops = (module C : CONTEXT with type t = 'ctxt) let empty proxy = - let ctxt = M.{proxy; tree = empty} in + let ctxt = M.{proxy; local = Local.empty} in Context.Context {ops; ctxt; kind = Proxy} let set_delegate : M.proxy_delegate -> Context.t -> Context.t = - fun proxy (Context.Context {ops; ctxt; kind} : Context.t) -> - match kind with + fun proxy (Context.Context t) -> + match t.kind with | Proxy -> - let ctxt' = {ctxt with proxy = Some proxy} in - Context.Context {ops; ctxt = ctxt'; kind = Proxy} + let ctxt = {t.ctxt with proxy = Some proxy} in + Context.Context {t with ctxt} | _ -> assert false diff --git a/src/lib_protocol_environment/proxy_context.mli b/src/lib_protocol_environment/proxy_context.mli index 49d27ae57eb389c4a9b9311e97462216fb892c24..332e130092d8a73427cf51e2fb6ccc019b332eb5 100644 --- a/src/lib_protocol_environment/proxy_context.mli +++ b/src/lib_protocol_environment/proxy_context.mli @@ -42,7 +42,7 @@ module M : sig type value = Bytes.t (* as in environment_context.mli *) - type tree = Dir of tree TzString.Map.t | Key of value + type tree = [`Value of bytes | `Tree of tree TzString.Map.t] module type ProxyDelegate = sig (** Whether [mem] would return Some Dir _ *) diff --git a/src/lib_protocol_environment/tezos-protocol-environment.opam b/src/lib_protocol_environment/tezos-protocol-environment.opam index 2ad3417c5d3b97fa0939acef36e43f23d78769e8..6fc03caf8fb237e6655fe46d31b1e31b91659a18 100644 --- a/src/lib_protocol_environment/tezos-protocol-environment.opam +++ b/src/lib_protocol_environment/tezos-protocol-environment.opam @@ -10,6 +10,7 @@ depends: [ "dune" { >= "2.0" } "tezos-sapling" "tezos-base" + "tezos-storage" "tezos-protocol-environment-sigs" "tezos-protocol-environment-structs" "alcotest-lwt" { with-test & >= "1.1.0" } diff --git a/src/lib_proxy/proxy_getter.ml b/src/lib_proxy/proxy_getter.ml index 073f52478b7454d8f301da3ef4fa34eab99add83..52a1d69d76b056888360ed7105ba655b733fc73b 100644 --- a/src/lib_proxy/proxy_getter.ml +++ b/src/lib_proxy/proxy_getter.ml @@ -66,7 +66,7 @@ let rec raw_context_to_tree Proxy_context.M.tree option = match raw with | Key (bytes : Bytes.t) -> - Some (Proxy_context.M.Key bytes) + Some (`Value bytes) | Cut -> None | Dir pairs -> @@ -79,7 +79,7 @@ let rec raw_context_to_tree TzString.Map.add string u string_map in let dir = List.fold_left f TzString.Map.empty pairs in - if TzString.Map.is_empty dir then None else Some (Dir dir) + if TzString.Map.is_empty dir then None else Some (`Tree dir) type proxy_getter_input = { rpc_context : RPC_context.simple; @@ -119,13 +119,13 @@ module Tree = struct match (k, m) with | ([], m) -> Some m - | (n :: k, Proxy_context.M.Dir m) -> ( + | (n :: k, `Tree m) -> ( match StringMap.find_opt n m with | Some res -> raw_get res k | None -> None ) - | (_ :: _, Proxy_context.M.Key _) -> + | (_ :: _, `Value _) -> None let rec comb (k : StringMap.key list) (v : Proxy_context.M.tree) : @@ -134,7 +134,7 @@ module Tree = struct | [] -> v | k_hd :: k_tail -> - Proxy_context.M.Dir (StringMap.singleton k_hd (comb k_tail v)) + `Tree (StringMap.singleton k_hd (comb k_tail v)) let rec set_leaf (m : Proxy_context.M.tree) (k : StringMap.key list) (v : Proxy_context.M.tree) = @@ -143,9 +143,9 @@ module Tree = struct v | k_hd :: k_tail -> ( match m with - | Key _ -> + | `Value _ -> assert false - | Dir map -> + | `Tree map -> let k_m = match StringMap.find_opt k_hd map with | None -> @@ -153,7 +153,7 @@ module Tree = struct | Some k_hd_tree -> set_leaf k_hd_tree k_tail v in - Proxy_context.M.Dir (StringMap.add k_hd k_m map) ) + `Tree (StringMap.add k_hd k_m map) ) end module type REQUESTS_TREE = sig @@ -297,9 +297,9 @@ module Make (X : PROTO_RPC) : M = struct match tree_opt with | None -> return_false - | Some (Proxy_context.M.Key _) -> + | Some (`Value _) -> return_false - | Some (Proxy_context.M.Dir _) -> + | Some (`Tree _) -> return_true let proxy_mem pgi key = @@ -308,8 +308,8 @@ module Make (X : PROTO_RPC) : M = struct match tree_opt with | None -> return_false - | Some (Proxy_context.M.Key _) -> + | Some (`Value _) -> return_true - | Some (Proxy_context.M.Dir _) -> + | Some (`Tree _) -> return_false end diff --git a/src/lib_proxy/proxy_getter.mli b/src/lib_proxy/proxy_getter.mli index 3be3f4ea769670f8b89a7589684c7fbe6dc0a72e..06f1c091e43b1608ce682dcd3464e942ad86ed36 100644 --- a/src/lib_proxy/proxy_getter.mli +++ b/src/lib_proxy/proxy_getter.mli @@ -50,7 +50,7 @@ module type REQUESTS_TREE = sig If proxy_getter receives a request for A-D, there's no point doing a request, even if it's not there; because as A has been requested already; if A-D was available, it would be there already. - + This is a crucial optimisation that reduces the number of .../raw/bytes RPC requests by 90% when executing baking_rights&?all=true locally, after the chain starts having more than a few cycles. diff --git a/src/lib_proxy/test/test_proxy.ml b/src/lib_proxy/test/test_proxy.ml index 308633ba46a37ac52f0a3498802d54ae59790ba5..a3da6350ec3f759e9f338ed72d7543442cc56079 100644 --- a/src/lib_proxy/test/test_proxy.ml +++ b/src/lib_proxy/test/test_proxy.ml @@ -35,10 +35,11 @@ module StringMap = TzString.Map -let rec nb_nodes = - let open Proxy_context.M in - function - | Key _ -> 1 | Dir dir -> StringMap.fold (fun _ v i -> i + nb_nodes v) dir 1 +let rec nb_nodes = function + | `Value _ -> + 1 + | `Tree dir -> + StringMap.fold (fun _ v i -> i + nb_nodes v) dir 1 let nb_nodes = function None -> 0 | Some t -> nb_nodes t @@ -73,10 +74,9 @@ let mock_proto_rpc () = in let rec mock_tree = function | [] -> - Proxy_context.M.Key Bytes.empty + `Value Bytes.empty | hd :: tail -> - Proxy_context.M.Dir - (StringMap.add hd (mock_tree tail) StringMap.empty) + `Tree (StringMap.add hd (mock_tree tail) StringMap.empty) in if please_error k then return_none else ( diff --git a/src/lib_storage/context.ml b/src/lib_storage/context.ml index d5f5c3a8c5931d71b91c15d5979c972f12926892..6d1fd6ec1d8260a8ce1de481c9ddda772e35c95b 100644 --- a/src/lib_storage/context.ml +++ b/src/lib_storage/context.ml @@ -28,8 +28,7 @@ (** Tezos - Versioned (key x value) store (over Irmin) *) -module Path = Irmin.Path.String_list -module Metadata = Irmin.Metadata.None +open Tezos_storage_encoding.Context let reporter () = let report src level ~over k msgf = @@ -75,160 +74,6 @@ let () = () )) args -module Hash : sig - include Irmin.Hash.S - - val to_context_hash : t -> Context_hash.t - - val of_context_hash : Context_hash.t -> t -end = struct - module H = Digestif.Make_BLAKE2B (struct - let digest_size = 32 - end) - - type t = H.t - - let of_context_hash s = H.of_raw_string (Context_hash.to_string s) - - let to_context_hash h = Context_hash.of_string_exn (H.to_raw_string h) - - let pp ppf t = Context_hash.pp ppf (to_context_hash t) - - let of_string x = - match Context_hash.of_b58check x with - | Ok x -> - Ok (of_context_hash x) - | Error err -> - Error - (`Msg - (Format.asprintf - "Failed to read b58check_encoding data: %a" - Error_monad.pp_print_error - err)) - - let short_hash_string = Irmin.Type.(unstage (short_hash string)) - - let short_hash_staged = - Irmin.Type.stage - @@ fun ?seed t -> short_hash_string ?seed (H.to_raw_string t) - - let t : t Irmin.Type.t = - Irmin.Type.map - ~pp - ~of_string - Irmin.Type.(string_of (`Fixed H.digest_size)) - ~short_hash:short_hash_staged - H.of_raw_string - H.to_raw_string - - let short_hash = - let f = short_hash_string ?seed:None in - fun t -> f (H.to_raw_string t) - - let hash_size = H.digest_size - - let hash = H.digesti_string -end - -module Node = struct - module M = Irmin.Private.Node.Make (Hash) (Path) (Metadata) - - module V1 = struct - module Hash = Irmin.Hash.V1 (Hash) - - type kind = [`Node | `Contents of Metadata.t] - - type entry = {kind : kind; name : M.step; node : Hash.t} - - (* Irmin 1.4 uses int8 to store filename lengths. - - Irmin 2 use a variable-size encoding for strings; this is using int8 - for strings of size stricly less than 128 (e.g. 2^7) which happen to - be the case for all filenames ever produced by Irmin 1.4. *) - let step_t = Irmin.Type.string - - let metadata_t = - let some = "\255\000\000\000\000\000\000\000" in - let none = "\000\000\000\000\000\000\000\000" in - Irmin.Type.(map (string_of (`Fixed 8))) - (fun s -> - match s.[0] with - | '\255' -> - None - | '\000' -> - Some () - | _ -> - assert false) - (function Some _ -> some | None -> none) - - (* Irmin 1.4 uses int64 to store list lengths *) - let entry_t : entry Irmin.Type.t = - let open Irmin.Type in - record "Tree.entry" (fun kind name node -> - let kind = match kind with None -> `Node | Some m -> `Contents m in - {kind; name; node}) - |+ field "kind" metadata_t (function - | {kind = `Node; _} -> - None - | {kind = `Contents m; _} -> - Some m) - |+ field "name" step_t (fun {name; _} -> name) - |+ field "node" Hash.t (fun {node; _} -> node) - |> sealr - - let entries_t : entry list Irmin.Type.t = - Irmin.Type.(list ~len:`Int64 entry_t) - - let import_entry (s, v) = - match v with - | `Node h -> - {name = s; kind = `Node; node = h} - | `Contents (h, m) -> - {name = s; kind = `Contents m; node = h} - - let import t = List.map import_entry (M.list t) - - let pre_hash_entries = Irmin.Type.(unstage (pre_hash entries_t)) - - let compare_entry x y = String.compare x.name y.name - - let pre_hash entries = - pre_hash_entries (List.fast_sort compare_entry entries) - end - - include M - - let pre_hash_v1 x = V1.pre_hash (V1.import x) - - let t = Irmin.Type.(like t ~pre_hash:(stage @@ fun x -> pre_hash_v1 x)) -end - -module Commit = struct - module M = Irmin.Private.Commit.Make (Hash) - module V1 = Irmin.Private.Commit.V1 (M) - include M - - let pre_hash_v1_t = Irmin.Type.(unstage (pre_hash V1.t)) - - let pre_hash_v1 t = pre_hash_v1_t (V1.import t) - - let t = Irmin.Type.(like t ~pre_hash:(stage @@ fun x -> pre_hash_v1 x)) -end - -module Contents = struct - type t = bytes - - let ty = Irmin.Type.(pair (bytes_of `Int64) unit) - - let pre_hash_ty = Irmin.Type.(unstage (pre_hash ty)) - - let pre_hash_v1 x = pre_hash_ty (x, ()) - - let t = Irmin.Type.(like bytes ~pre_hash:(stage @@ fun x -> pre_hash_v1 x)) - - let merge = Irmin.Merge.(idempotent (Irmin.Type.option t)) -end - module Conf = struct let entries = 32 @@ -241,10 +86,10 @@ module Store = let io_version = `V1 end) (Conf) - (Irmin.Metadata.None) + (Metadata) (Contents) - (Irmin.Path.String_list) - (Irmin.Branch.String) + (Path) + (Branch) (Hash) (Node) (Commit) @@ -262,7 +107,7 @@ and context = {index : index; parents : Store.Commit.t list; tree : Store.tree} type t = context -module type S = Context_intf.S +module type S = Tezos_storage_sigs.Context.S (*-- Version Access and Update -----------------------------------------------*) @@ -373,110 +218,7 @@ type value = bytes type tree = Store.tree -module Tree = struct - include Store.Tree - - let empty _ = Store.Tree.empty - - let equal = Irmin.Type.(unstage (equal Store.tree_t)) - - let is_empty t = equal Store.Tree.empty t - - let hash t = Hash.to_context_hash (Store.Tree.hash t) - - let add t k v = Store.Tree.add t k v - - let kind t = - match Store.Tree.destruct t with - | `Contents (c, _) -> - `Value c - | `Node _ -> - `Tree - - let fold ?depth t k ~init ~f = - find_tree t k - >>= function - | None -> - Lwt.return init - | Some t -> - Store.Tree.fold - ?depth - ~force:`And_clear - ~uniq:`False - ~node:(fun k v acc -> f k (Store.Tree.of_node v) acc) - ~contents:(fun k v acc -> - if k = [] then Lwt.return acc - else f k (Store.Tree.of_contents v) acc) - t - init - - type raw = [`Value of bytes | `Tree of raw TzString.Map.t] - - type concrete = Store.Tree.concrete - - let rec raw_of_concrete : type a. (raw -> a) -> concrete -> a = - fun k -> function - | `Tree l -> - raw_of_node (fun l -> k (`Tree (TzString.Map.of_seq l))) l - | `Contents (v, _) -> - k (`Value v) - - and raw_of_node : - type a. ((string * raw) Seq.t -> a) -> (string * concrete) list -> a = - fun k -> function - | [] -> - k Seq.empty - | (n, v) :: t -> - raw_of_concrete - (fun v -> - raw_of_node (fun t -> k (fun () -> Seq.Cons ((n, v), t))) t) - v - - let to_raw t = Store.Tree.to_concrete t >|= raw_of_concrete (fun t -> t) - - let rec concrete_of_raw : type a. (concrete -> a) -> raw -> a = - fun k -> function - | `Tree l -> - concrete_of_node (fun l -> k (`Tree l)) (TzString.Map.to_seq l) - | `Value v -> - k (`Contents (v, ())) - - and concrete_of_node : - type a. ((string * concrete) list -> a) -> (string * raw) Seq.t -> a = - fun k seq -> - match seq () with - | Nil -> - k [] - | Cons ((n, v), t) -> - concrete_of_raw - (fun v -> concrete_of_node (fun t -> k ((n, v) :: t)) t) - v - - let of_raw = concrete_of_raw Store.Tree.of_concrete - - let raw_encoding : raw Data_encoding.t = - let open Data_encoding in - mu "Tree.raw" (fun encoding -> - let map_encoding = - conv - TzString.Map.bindings - (fun bindings -> TzString.Map.of_seq (List.to_seq bindings)) - (list (tup2 string encoding)) - in - union - [ case - ~title:"tree" - (Tag 0) - map_encoding - (function `Tree t -> Some t | `Value _ -> None) - (fun t -> `Tree t); - case - ~title:"value" - (Tag 1) - bytes - (function `Value v -> Some v | `Tree _ -> None) - (fun v -> `Value v) ]) -end +module Tree = Tezos_storage_helpers.Context.Make_tree (Store) let mem ctxt key = Tree.mem ctxt.tree (data_key key) @@ -951,7 +693,9 @@ module Dumpable_context = struct Store.Tree.kind value [] >|= function | None -> - assert false (* The value must exist in the tree *) + (* The value must exist in the tree, because we're + iterating over existing keys *) + assert false | Some value_kind -> let value_hash = tree_hash value in {key; value; value_kind; value_hash}) diff --git a/src/lib_storage/context.mli b/src/lib_storage/context.mli index 6cbb95084a5e625e278d44e0c7319df9b7b4bc6d..6faed0cdb9a1d1f7e8dfa4fd33f3de0041d43f03 100644 --- a/src/lib_storage/context.mli +++ b/src/lib_storage/context.mli @@ -32,7 +32,7 @@ module type S = sig (** @inline *) - include Context_intf.S + include Tezos_storage_sigs.Context.S end include S diff --git a/src/lib_storage/dune b/src/lib_storage/dune index 44dc3dbafa462bfe76a301d8a0aa3319610717a6..fe4bbee2f8bcceb622c8162407ae57ab198749d4 100644 --- a/src/lib_storage/dune +++ b/src/lib_storage/dune @@ -8,7 +8,10 @@ digestif.c irmin irmin-pack - tezos-stdlib-unix) + tezos-stdlib-unix + tezos-storage.sigs + tezos-storage.helpers + tezos-storage.encoding) (flags (:standard -open Tezos_shell_services -open Tezos_base__TzPervasives -open Tezos_stdlib_unix diff --git a/src/lib_storage/encoding/.ocamlformat b/src/lib_storage/encoding/.ocamlformat new file mode 100644 index 0000000000000000000000000000000000000000..8278a132e3d6f6c868be4c6e0a012089319d0bbc --- /dev/null +++ b/src/lib_storage/encoding/.ocamlformat @@ -0,0 +1,12 @@ +version=0.10 +wrap-fun-args=false +let-binding-spacing=compact +field-space=loose +break-separators=after-and-docked +sequence-style=separator +doc-comments=before +margin=80 +module-item-spacing=sparse +parens-tuple=always +parens-tuple-patterns=always +break-string-literals=newlines-and-wrap diff --git a/src/lib_storage/encoding/context.ml b/src/lib_storage/encoding/context.ml new file mode 100644 index 0000000000000000000000000000000000000000..48cb996501d9e29c025b67c14235e6d0110390b0 --- /dev/null +++ b/src/lib_storage/encoding/context.ml @@ -0,0 +1,166 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018-2021 Tarides *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +module Path = Irmin.Path.String_list +module Metadata = Irmin.Metadata.None +module Branch = Irmin.Branch.String + +module Hash : sig + include Irmin.Hash.S + + val to_context_hash : t -> Context_hash.t + + val of_context_hash : Context_hash.t -> t +end = struct + module H = Digestif.Make_BLAKE2B (struct + let digest_size = 32 + end) + + type t = H.t + + let of_context_hash s = H.of_raw_string (Context_hash.to_string s) + + let to_context_hash h = Context_hash.of_string_exn (H.to_raw_string h) + + let pp ppf t = Context_hash.pp ppf (to_context_hash t) + + let of_string x = + match Context_hash.of_b58check x with + | Ok x -> + Ok (of_context_hash x) + | Error err -> + Error + (`Msg + (Format.asprintf + "Failed to read b58check_encoding data: %a" + Error_monad.pp_print_error + err)) + + let short_hash_string = Irmin.Type.(unstage (short_hash string)) + + let short_hash_staged = + Irmin.Type.stage + @@ fun ?seed t -> short_hash_string ?seed (H.to_raw_string t) + + let t : t Irmin.Type.t = + Irmin.Type.map + ~pp + ~of_string + Irmin.Type.(string_of (`Fixed H.digest_size)) + ~short_hash:short_hash_staged + H.of_raw_string + H.to_raw_string + + let short_hash = + let f = short_hash_string ?seed:None in + fun t -> f (H.to_raw_string t) + + let hash_size = H.digest_size + + let hash = H.digesti_string +end + +module Node = struct + module M = Irmin.Private.Node.Make (Hash) (Path) (Metadata) + + (* [V1] is only used to compute preimage hashes. [assert false] + statements should be unreachable.*) + module V1 : sig + val pre_hash : M.t -> (string -> unit) -> unit + end = struct + module Hash = Irmin.Hash.V1 (Hash) + + type entry = string * M.value + + (* Irmin 1.4 uses int8 to store filename lengths. + + Irmin 2 use a variable-size encoding for strings; this is using int8 + for strings of size stricly less than 128 (e.g. 2^7) which happen to + be the case for all filenames ever produced by Irmin 1.4. *) + let step_t = Irmin.Type.string + + let metadata_t = + let some = "\255\000\000\000\000\000\000\000" in + let none = "\000\000\000\000\000\000\000\000" in + Irmin.Type.(map (string_of (`Fixed 8))) + (fun _ -> assert false) + (function Some _ -> some | None -> none) + + let metadata_of_entry (_, t) = + match t with `Node _ -> None | `Contents (_, m) -> Some m + + let hash_of_entry (_, t) = + match t with `Node h -> h | `Contents (h, _) -> h + + (* Irmin 1.4 uses int64 to store list lengths *) + let entry_t : entry Irmin.Type.t = + let open Irmin.Type in + record "Tree.entry" (fun _ _ _ -> assert false) + |+ field "kind" metadata_t metadata_of_entry + |+ field "name" step_t fst + |+ field "hash" Hash.t hash_of_entry + |> sealr + + let entries_t : entry list Irmin.Type.t = + Irmin.Type.(list ~len:`Int64 entry_t) + + let pre_hash_entries = Irmin.Type.(unstage (pre_hash entries_t)) + + let compare_entry (x, _) (y, _) = String.compare x y + + let pre_hash t = + M.list t |> List.fast_sort compare_entry |> pre_hash_entries + end + + include M + + let t = Irmin.Type.(like t ~pre_hash:(stage @@ fun x -> V1.pre_hash x)) +end + +module Commit = struct + module M = Irmin.Private.Commit.Make (Hash) + module V1 = Irmin.Private.Commit.V1 (M) + include M + + let pre_hash_v1_t = Irmin.Type.(unstage (pre_hash V1.t)) + + let pre_hash_v1 t = pre_hash_v1_t (V1.import t) + + let t = Irmin.Type.(like t ~pre_hash:(stage @@ fun x -> pre_hash_v1 x)) +end + +module Contents = struct + type t = bytes + + let ty = Irmin.Type.(pair (bytes_of `Int64) unit) + + let pre_hash_ty = Irmin.Type.(unstage (pre_hash ty)) + + let pre_hash_v1 x = pre_hash_ty (x, ()) + + let t = Irmin.Type.(like bytes ~pre_hash:(stage @@ fun x -> pre_hash_v1 x)) + + let merge = Irmin.Merge.(idempotent (Irmin.Type.option t)) +end diff --git a/src/lib_storage/encoding/context.mli b/src/lib_storage/encoding/context.mli new file mode 100644 index 0000000000000000000000000000000000000000..f4d642474501275b370837cd0f03389e010f6f89 --- /dev/null +++ b/src/lib_storage/encoding/context.mli @@ -0,0 +1,50 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018-2021 Tarides *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Context serialization format. *) + +module Hash : sig + include Irmin.Hash.S + + val to_context_hash : t -> Context_hash.t + + val of_context_hash : Context_hash.t -> t +end + +module Contents : Irmin.Contents.S with type t = bytes + +module Metadata : Irmin.Metadata.S with type t = unit + +module Path : Irmin.Path.S with type step = string and type t = string list + +module Branch : Irmin.Branch.S with type t = string + +module Node : + Irmin.Private.Node.S + with type hash = Hash.t + and type step = string + and type metadata = unit + +module Commit : Irmin.Private.Commit.S with type hash = Hash.t diff --git a/src/lib_storage/encoding/dune b/src/lib_storage/encoding/dune new file mode 100644 index 0000000000000000000000000000000000000000..bddbf8cf2f726ad112cde3ef76c8179fb814f61e --- /dev/null +++ b/src/lib_storage/encoding/dune @@ -0,0 +1,12 @@ +(library + (name tezos_storage_encoding) + (public_name tezos-storage.encoding) + (libraries tezos-base + irmin) + (flags (:standard -open Tezos_base__TzPervasives + -open Tezos_stdlib))) + +(rule + (alias runtest_lint) + (deps (glob_files *.ml{,i})) + (action (run %{lib:tezos-tooling:lint.sh} %{deps}))) diff --git a/src/lib_storage/helpers/.ocamlformat b/src/lib_storage/helpers/.ocamlformat new file mode 100644 index 0000000000000000000000000000000000000000..8278a132e3d6f6c868be4c6e0a012089319d0bbc --- /dev/null +++ b/src/lib_storage/helpers/.ocamlformat @@ -0,0 +1,12 @@ +version=0.10 +wrap-fun-args=false +let-binding-spacing=compact +field-space=loose +break-separators=after-and-docked +sequence-style=separator +doc-comments=before +margin=80 +module-item-spacing=sparse +parens-tuple=always +parens-tuple-patterns=always +break-string-literals=newlines-and-wrap diff --git a/src/lib_storage/helpers/context.ml b/src/lib_storage/helpers/context.ml new file mode 100644 index 0000000000000000000000000000000000000000..c0fea728b768354ed41143f3326f9db0b312c530 --- /dev/null +++ b/src/lib_storage/helpers/context.ml @@ -0,0 +1,141 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018-2021 Tarides *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Tezos_storage_encoding.Context + +module type DB = + Irmin.S + with type key = Path.t + and type contents = Contents.t + and type branch = Branch.t + and type hash = Hash.t + and type step = Path.step + and type metadata = Metadata.t + and type Key.step = Path.step + +module Make_tree (Store : DB) = struct + include Store.Tree + + let empty _ = Store.Tree.empty + + let equal = Irmin.Type.(unstage (equal Store.tree_t)) + + let is_empty t = equal Store.Tree.empty t + + let hash t = Hash.to_context_hash (Store.Tree.hash t) + + let add t k v = Store.Tree.add t k v + + let kind t = + match Store.Tree.destruct t with + | `Contents (c, _) -> + `Value c + | `Node _ -> + `Tree + + let fold ?depth t k ~init ~f = + find_tree t k + >>= function + | None -> + Lwt.return init + | Some t -> + Store.Tree.fold + ?depth + ~force:`And_clear + ~uniq:`False + ~node:(fun k v acc -> f k (Store.Tree.of_node v) acc) + ~contents:(fun k v acc -> + if k = [] then Lwt.return acc + else f k (Store.Tree.of_contents v) acc) + t + init + + type raw = [`Value of bytes | `Tree of raw TzString.Map.t] + + type concrete = Store.Tree.concrete + + let rec raw_of_concrete : type a. (raw -> a) -> concrete -> a = + fun k -> function + | `Tree l -> + raw_of_node (fun l -> k (`Tree (TzString.Map.of_seq l))) l + | `Contents (v, _) -> + k (`Value v) + + and raw_of_node : + type a. ((string * raw) Seq.t -> a) -> (string * concrete) list -> a = + fun k -> function + | [] -> + k Seq.empty + | (n, v) :: t -> + raw_of_concrete + (fun v -> + raw_of_node (fun t -> k (fun () -> Seq.Cons ((n, v), t))) t) + v + + let to_raw t = Store.Tree.to_concrete t >|= raw_of_concrete (fun t -> t) + + let rec concrete_of_raw : type a. (concrete -> a) -> raw -> a = + fun k -> function + | `Tree l -> + concrete_of_node (fun l -> k (`Tree l)) (TzString.Map.to_seq l) + | `Value v -> + k (`Contents (v, ())) + + and concrete_of_node : + type a. ((string * concrete) list -> a) -> (string * raw) Seq.t -> a = + fun k seq -> + match seq () with + | Nil -> + k [] + | Cons ((n, v), t) -> + concrete_of_raw + (fun v -> concrete_of_node (fun t -> k ((n, v) :: t)) t) + v + + let of_raw = concrete_of_raw Store.Tree.of_concrete + + let raw_encoding : raw Data_encoding.t = + let open Data_encoding in + mu "Tree.raw" (fun encoding -> + let map_encoding = + conv + TzString.Map.bindings + (fun bindings -> TzString.Map.of_seq (List.to_seq bindings)) + (list (tup2 string encoding)) + in + union + [ case + ~title:"tree" + (Tag 0) + map_encoding + (function `Tree t -> Some t | `Value _ -> None) + (fun t -> `Tree t); + case + ~title:"value" + (Tag 1) + bytes + (function `Value v -> Some v | `Tree _ -> None) + (fun v -> `Value v) ]) +end diff --git a/src/lib_storage/helpers/context.mli b/src/lib_storage/helpers/context.mli new file mode 100644 index 0000000000000000000000000000000000000000..1d22311d88a2b0deb2ee1b87af0c8072e980c507 --- /dev/null +++ b/src/lib_storage/helpers/context.mli @@ -0,0 +1,47 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018-2021 Tarides *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Tezos_storage_encoding.Context + +module type DB = + Irmin.S + with type key = Path.t + and type contents = Contents.t + and type branch = Branch.t + and type hash = Hash.t + and type step = Path.step + and type metadata = Metadata.t + and type Key.step = Path.step + +module Make_tree (DB : DB) : sig + include + Tezos_storage_sigs.Context.TREE + with type t := DB.t + and type key := string list + and type value := bytes + and type tree := DB.tree + + val empty : _ -> DB.tree +end diff --git a/src/lib_storage/helpers/dune b/src/lib_storage/helpers/dune new file mode 100644 index 0000000000000000000000000000000000000000..131def2aa7642175204936efff72afe327858208 --- /dev/null +++ b/src/lib_storage/helpers/dune @@ -0,0 +1,14 @@ +(library + (name tezos_storage_helpers) + (public_name tezos-storage.helpers) + (libraries tezos-base + tezos-storage.encoding + tezos-storage.sigs + irmin) + (flags (:standard -open Tezos_base__TzPervasives + -open Tezos_stdlib))) + +(rule + (alias runtest_lint) + (deps (glob_files *.ml{,i})) + (action (run %{lib:tezos-tooling:lint.sh} %{deps}))) diff --git a/src/lib_storage/memory/.ocamlformat b/src/lib_storage/memory/.ocamlformat new file mode 100644 index 0000000000000000000000000000000000000000..8278a132e3d6f6c868be4c6e0a012089319d0bbc --- /dev/null +++ b/src/lib_storage/memory/.ocamlformat @@ -0,0 +1,12 @@ +version=0.10 +wrap-fun-args=false +let-binding-spacing=compact +field-space=loose +break-separators=after-and-docked +sequence-style=separator +doc-comments=before +margin=80 +module-item-spacing=sparse +parens-tuple=always +parens-tuple-patterns=always +break-string-literals=newlines-and-wrap diff --git a/src/lib_storage/memory/context.ml b/src/lib_storage/memory/context.ml new file mode 100644 index 0000000000000000000000000000000000000000..00442991dcf4a9255102531d8e1cd558e6e47d32 --- /dev/null +++ b/src/lib_storage/memory/context.ml @@ -0,0 +1,109 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018-2021 Tarides *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Tezos_storage_encoding.Context +module AO = Irmin.Content_addressable (Irmin_mem.Append_only) +module RW = Irmin_mem.Atomic_write +module Store = + Irmin.Make_ext (AO) (RW) (Metadata) (Contents) (Path) (Branch) (Hash) (Node) + (Commit) + +type t = Store.tree + +type tree = t + +type key = string list + +type value = bytes + +module Tree = Tezos_storage_helpers.Context.Make_tree (Store) +include Tree + +let data_key key = "data" :: key + +let mem t key = Tree.mem t (data_key key) + +let mem_tree t key = Tree.mem_tree t (data_key key) + +let list t ?offset ?length key = Tree.list t ?offset ?length (data_key key) + +let find t key = Tree.find t (data_key key) + +let add t key data = Tree.add t (data_key key) data + +let remove t key = Tree.remove t (data_key key) + +let find_tree t key = Tree.find_tree t (data_key key) + +let add_tree t key tree = Tree.add_tree t (data_key key) tree + +let fold ?depth t key ~init ~f = Tree.fold ?depth t (data_key key) ~init ~f + +let current_protocol_key = ["protocol"] + +let get_protocol t = + Tree.find t current_protocol_key + >>= function + | None -> + assert false + | Some data -> + Lwt.return (Protocol_hash.of_bytes_exn data) + +let add_protocol t key = + let key = Protocol_hash.to_bytes key in + Tree.add t current_protocol_key key + +let empty = Store.Tree.empty + +let concrete_encoding : Store.Tree.concrete Data_encoding.t = + let open Data_encoding in + mu "memory_context" (fun encoding -> + let map_encoding = list (tup2 string encoding) in + union + [ case + ~title:"tree" + (Tag 0) + map_encoding + (function `Tree map -> Some map | `Contents _ -> None) + (fun map -> `Tree map); + case + ~title:"value" + (Tag 1) + bytes + (function `Contents (v, _) -> Some v | `Tree _ -> None) + (fun v -> `Contents (v, ())) ]) + +let encoding : t Data_encoding.t = + Data_encoding.conv + (fun t -> + let tree = Store.Tree.to_concrete t in + let tree = + (* This is safe as store.Tree will never call any blocking + functions. *) + match Lwt.state tree with Return t -> t | _ -> assert false + in + tree) + Store.Tree.of_concrete + concrete_encoding diff --git a/src/lib_storage/memory/context.mli b/src/lib_storage/memory/context.mli new file mode 100644 index 0000000000000000000000000000000000000000..591779c977368d9a7a8f04bf7f6a03c094f4d268 --- /dev/null +++ b/src/lib_storage/memory/context.mli @@ -0,0 +1,39 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018-2021 Tarides *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Implementation of Tezos context fully in memory. *) + +(** The type for in-memory contexts. *) +type t + +include Tezos_storage_sigs.Context.S with type t := t and type tree = t + +val empty : t + +val encoding : t Data_encoding.t + +val get_protocol : t -> Protocol_hash.t Lwt.t + +val add_protocol : t -> Protocol_hash.t -> t Lwt.t diff --git a/src/lib_storage/memory/dune b/src/lib_storage/memory/dune new file mode 100644 index 0000000000000000000000000000000000000000..a4a7fd0b95346764b83794ff952b56ca85049cbf --- /dev/null +++ b/src/lib_storage/memory/dune @@ -0,0 +1,15 @@ +(library + (name tezos_storage_memory) + (public_name tezos-storage.memory) + (libraries tezos-base + irmin-mem + tezos-storage.sigs + tezos-storage.encoding + tezos-storage.helpers) + (flags (:standard -open Tezos_base__TzPervasives + -open Tezos_stdlib))) + +(rule + (alias runtest_lint) + (deps (glob_files *.ml{,i})) + (action (run %{lib:tezos-tooling:lint.sh} %{deps}))) diff --git a/src/lib_storage/sigs/.ocamlformat b/src/lib_storage/sigs/.ocamlformat new file mode 100644 index 0000000000000000000000000000000000000000..8278a132e3d6f6c868be4c6e0a012089319d0bbc --- /dev/null +++ b/src/lib_storage/sigs/.ocamlformat @@ -0,0 +1,12 @@ +version=0.10 +wrap-fun-args=false +let-binding-spacing=compact +field-space=loose +break-separators=after-and-docked +sequence-style=separator +doc-comments=before +margin=80 +module-item-spacing=sparse +parens-tuple=always +parens-tuple-patterns=always +break-string-literals=newlines-and-wrap diff --git a/src/lib_storage/context_intf.ml b/src/lib_storage/sigs/context.ml similarity index 100% rename from src/lib_storage/context_intf.ml rename to src/lib_storage/sigs/context.ml diff --git a/src/lib_storage/sigs/dune b/src/lib_storage/sigs/dune new file mode 100644 index 0000000000000000000000000000000000000000..0f6bda6c18f6f4d9bc03eac3bd81800416743482 --- /dev/null +++ b/src/lib_storage/sigs/dune @@ -0,0 +1,11 @@ +(library + (name tezos_storage_sigs) + (public_name tezos-storage.sigs) + (libraries tezos-base) + (flags (:standard -open Tezos_base__TzPervasives + -open Tezos_stdlib))) + +(rule + (alias runtest_lint) + (deps (glob_files *.ml{,i})) + (action (run %{lib:tezos-tooling:lint.sh} %{deps}))) diff --git a/src/lib_version/dune b/src/lib_version/dune index 7992f72b069acc8cbd5a99941b05b83daf4dafbc..c61819b2fa4bb799f5e6301a311094fdceda6654 100644 --- a/src/lib_version/dune +++ b/src/lib_version/dune @@ -7,5 +7,5 @@ (rule (targets generated_git_info.ml) ; Ensures the hash update whenever a source file is modified ; - (deps (source_tree %{workspace_root}) (:script get-git-info.mlt)) + (deps (universe) (:script get-git-info.mlt)) (action (with-stdout-to %{targets} (run %{ocaml} unix.cma %{script})))) diff --git a/src/proto_007_PsDELPH1/lib_protocol/test/helpers/context.ml b/src/proto_007_PsDELPH1/lib_protocol/test/helpers/context.ml index 353bc9afee8277f9c1b803b55e078126c125e3ff..5e7b6d566cee6813c0950de7f9d6c755a43c6335 100644 --- a/src/proto_007_PsDELPH1/lib_protocol/test/helpers/context.ml +++ b/src/proto_007_PsDELPH1/lib_protocol/test/helpers/context.ml @@ -197,9 +197,7 @@ module Vote = struct Alpha_services.Voting.current_proposal rpc_ctxt ctxt let get_protocol (b : Block.t) = - Tezos_protocol_environment.Context.get b.context ["protocol"] - >|= function - | None -> assert false | Some p -> Protocol_hash.of_bytes_exn p + Tezos_protocol_environment.Context.get_protocol b.context let get_participation_ema (b : Block.t) = Environment.Context.get b.context ["votes"; "participation_ema"] diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/helpers/context.ml b/src/proto_008_PtEdoTez/lib_protocol/test/helpers/context.ml index 2123d81ffc1defe373b25d464bfe0372c6fdb289..53a3ce0e5fc9dc1fb5a7a58d89f953a5bb674581 100644 --- a/src/proto_008_PtEdoTez/lib_protocol/test/helpers/context.ml +++ b/src/proto_008_PtEdoTez/lib_protocol/test/helpers/context.ml @@ -193,9 +193,7 @@ module Vote = struct Alpha_services.Voting.current_proposal rpc_ctxt ctxt let get_protocol (b : Block.t) = - Tezos_protocol_environment.Context.get b.context ["protocol"] - >|= function - | None -> assert false | Some p -> Protocol_hash.of_bytes_exn p + Tezos_protocol_environment.Context.get_protocol b.context let get_participation_ema (b : Block.t) = Environment.Context.get b.context ["votes"; "participation_ema"] diff --git a/src/proto_alpha/lib_protocol/test/helpers/context.ml b/src/proto_alpha/lib_protocol/test/helpers/context.ml index c25b12862c0a1a6a9fc70ec7dcf1b3f3c58d231d..40aee5d875eedae3d669dcff94a7e47d539ae9e9 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/context.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/context.ml @@ -193,9 +193,7 @@ module Vote = struct Alpha_services.Voting.current_proposal rpc_ctxt ctxt let get_protocol (b : Block.t) = - Tezos_protocol_environment.Context.get b.context ["protocol"] - >|= function - | None -> assert false | Some p -> Protocol_hash.of_bytes_exn p + Tezos_protocol_environment.Context.get_protocol b.context let get_participation_ema (b : Block.t) = Environment.Context.get b.context ["votes"; "participation_ema"]