diff --git a/src/environment/jbuild b/src/environment/jbuild index e16b8cd29..6106ccbb5 100644 --- a/src/environment/jbuild +++ b/src/environment/jbuild @@ -38,7 +38,6 @@ ;; Tezos specifics v1/tezos_data.mli - v1/persist.mli v1/context.mli v1/RPC.mli v1/updater.mli diff --git a/src/environment/v1/context.mli b/src/environment/v1/context.mli index 2a26b2df1..e9281a8dc 100644 --- a/src/environment/v1/context.mli +++ b/src/environment/v1/context.mli @@ -10,7 +10,21 @@ (** View over the context store, restricted to types, access and functional manipulation of an existing context. *) -include Persist.STORE +type t + +(** Keys in (kex x value) database implementations *) +type key = string list + +(** Values in (kex x value) database implementations *) +type value = MBytes.t + +val mem: t -> key -> bool Lwt.t +val dir_mem: t -> key -> bool Lwt.t +val get: t -> key -> value option Lwt.t +val set: t -> key -> value -> t Lwt.t +val del: t -> key -> t Lwt.t +val list: t -> key list -> key list Lwt.t +val remove_rec: t -> key -> t Lwt.t val register_resolver: 'a Base58.encoding -> (t -> string -> 'a list Lwt.t) -> unit diff --git a/src/node/db/context.ml b/src/node/db/context.ml index 58d49cfa0..93b667e01 100644 --- a/src/node/db/context.ml +++ b/src/node/db/context.ml @@ -140,6 +140,9 @@ let undata_key = function | "data" :: key -> key | _ -> assert false +type key = string list +type value = MBytes.t + let mem ctxt key = Lwt_utils.Idle_waiter.task ctxt.index.repack_scheduler @@ fun () -> GitStore.Tree.mem ctxt.tree (data_key key) >>= fun v -> diff --git a/src/node/db/context.mli b/src/node/db/context.mli index 478472dd3..27a7a292c 100644 --- a/src/node/db/context.mli +++ b/src/node/db/context.mli @@ -40,7 +40,16 @@ val commit_test_network_genesis: (** {2 Generic interface} ****************************************************) -include Persist.STORE with type t := context +type key = string list +type value = MBytes.t + +val mem: context -> key -> bool Lwt.t +val dir_mem: context -> key -> bool Lwt.t +val get: context -> key -> value option Lwt.t +val set: context -> key -> value -> t Lwt.t +val del: context -> key -> t Lwt.t +val list: context -> key list -> key list Lwt.t +val remove_rec: context -> key -> t Lwt.t (** {2 Accessing and Updating Versions} **************************************) diff --git a/src/node/db/persist.mli b/src/node/db/persist.mli deleted file mode 100644 index 437746767..000000000 --- a/src/node/db/persist.mli +++ /dev/null @@ -1,212 +0,0 @@ -(**************************************************************************) -(* *) -(* Copyright (c) 2014 - 2017. *) -(* Dynamic Ledger Solutions, Inc. *) -(* *) -(* All rights reserved. No warranty, explicit or implicit, provided. *) -(* *) -(**************************************************************************) - -(** Tezos - Persistent structures on top of {!Context} *) - -(** Keys in (kex x value) database implementations *) -type key = string list - -(** Values in (kex x value) database implementations *) -type value = MBytes.t - -(** Low level view over a (key x value) database implementation. *) -module type STORE = sig - type t - val mem: t -> key -> bool Lwt.t - val dir_mem: t -> key -> bool Lwt.t - val get: t -> key -> value option Lwt.t - val set: t -> key -> value -> t Lwt.t - val del: t -> key -> t Lwt.t - val list: t -> key list -> key list Lwt.t - val remove_rec: t -> key -> t Lwt.t -end - -(** Projection of OCaml keys of some abstract type to concrete storage - keys. For practical reasons, all such keys must fall under a same - {!prefix} and have the same relative {!length}. Functions - {!to_path} and {!of_path} only take the relative part into account - (the prefix is added and removed when needed). *) -module type KEY = sig - type t - val prefix: key - val length: int - val to_path: t -> key - val of_path: key -> t - val compare: t -> t -> int -end - -(** A KEY instance for using raw implementation paths as keys *) -module RawKey : KEY with type t = key - -module type BYTES_STORE = sig - type t - type key - val mem: t -> key -> bool Lwt.t - val get: t -> key -> value option Lwt.t - val set: t -> key -> value -> t Lwt.t - val del: t -> key -> t Lwt.t - val list: t -> key list -> key list Lwt.t - val remove_rec: t -> key -> t Lwt.t -end - -module MakeBytesStore (S : STORE) (K : KEY) : - BYTES_STORE with type t = S.t and type key = K.t - -(** {2 Typed Store Overlays} *************************************************) - -(** Projection of OCaml values of some abstract type to concrete - storage data. *) -module type VALUE = sig - type t - val of_bytes: value -> t option - val to_bytes: t -> value -end - -(** A VALUE instance for using the raw bytes values *) -module RawValue : VALUE with type t = value - -(** Signature of a typed store as returned by {!MakeTypedStore} *) -module type TYPED_STORE = sig - type t - type key - type value - val mem: t -> key -> bool Lwt.t - val get: t -> key -> value option Lwt.t - val set: t -> key -> value -> t Lwt.t - val del: t -> key -> t Lwt.t -end - -(** Gives a typed view of a store (values of a given type stored under - keys of a given type). The view is also restricted to a prefix, - (which can be empty). For all primitives to work as expected, all - keys under this prefix must be homogeneously typed. *) -module MakeTypedStore (S : STORE) (K : KEY) (C : VALUE) : - TYPED_STORE with type t = S.t and type key = K.t and type value = C.t - - -(** {2 Persistent Sets} ******************************************************) - -(** Signature of a set as returned by {!MakePersistentSet} *) -module type PERSISTENT_SET = sig - type t and key - val mem : t -> key -> bool Lwt.t - val set : t -> key -> t Lwt.t - val del : t -> key -> t Lwt.t - val elements : t -> key list Lwt.t - val clear : t -> t Lwt.t - val iter : t -> f:(key -> unit Lwt.t) -> unit Lwt.t - val fold : t -> 'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t -end - -(** Signature of a buffered set as returned by {!MakeBufferedPersistentSet} *) -module type BUFFERED_PERSISTENT_SET = sig - include PERSISTENT_SET - module Set : Set.S with type elt = key - val read : t -> Set.t Lwt.t - val write : t -> Set.t -> t Lwt.t -end - -(** Build a set in the (key x value) storage by encoding elements as - keys and using the association of (any) data to these keys as - membership. For this to work, the prefix passed must be reserved - for the set (every key under it is considered a member). *) -module MakePersistentSet (S : STORE) (K : KEY) - : PERSISTENT_SET with type t := S.t and type key := K.t - -(** Same as {!MakePersistentSet} but also provides a way to use an - OCaml set as an explicitly synchronized in-memory buffer. *) -module MakeBufferedPersistentSet - (S : STORE) (K : KEY) (Set : Set.S with type elt = K.t) - : BUFFERED_PERSISTENT_SET - with type t := S.t - and type key := K.t - and module Set := Set - -(** {2 Persistent Maps} ******************************************************) - -(** Signature of a map as returned by {!MakePersistentMap} *) -module type PERSISTENT_MAP = sig - type t and key and value - val mem : t -> key -> bool Lwt.t - val get : t -> key -> value option Lwt.t - val set : t -> key -> value -> t Lwt.t - val del : t -> key -> t Lwt.t - val bindings : t -> (key * value) list Lwt.t - val clear : t -> t Lwt.t - val iter : t -> f:(key -> value -> unit Lwt.t) -> unit Lwt.t - val fold : t -> 'a -> f:(key -> value -> 'a -> 'a Lwt.t) -> 'a Lwt.t -end - -(** Signature of a buffered map as returned by {!MakeBufferedPersistentMap} *) -module type BUFFERED_PERSISTENT_MAP = sig - include PERSISTENT_MAP - module Map : Map.S with type key = key - val read : t -> value Map.t Lwt.t - val write : t -> value Map.t -> t Lwt.t -end - -(** Build a map in the (key x value) storage. For this to work, the - prefix passed must be reserved for the map (every key under it is - considered the key of a binding). *) -module MakePersistentMap (S : STORE) (K : KEY) (C : VALUE) - : PERSISTENT_MAP - with type t := S.t and type key := K.t and type value := C.t - -(** Same as {!MakePersistentMap} but also provides a way to use an - OCaml map as an explicitly synchronized in-memory buffer. *) -module MakeBufferedPersistentMap - (S : STORE) (K : KEY) (C : VALUE) (Map : Map.S with type key = K.t) - : BUFFERED_PERSISTENT_MAP - with type t := S.t - and type key := K.t - and type value := C.t - and module Map := Map - - -(** {2 Predefined Instances} *************************************************) - -module MakePersistentBytesMap (S : STORE) (K : KEY) - : PERSISTENT_MAP - with type t := S.t and type key := K.t and type value := MBytes.t - -module MakeBufferedPersistentBytesMap - (S : STORE) (K : KEY) (Map : Map.S with type key = K.t) - : BUFFERED_PERSISTENT_MAP - with type t := S.t - and type key := K.t - and type value := MBytes.t - and module Map := Map - -module type TYPED_VALUE_REPR = sig - type value - val encoding: value Data_encoding.t -end - -module MakePersistentTypedMap (S : STORE) (K : KEY) (T : TYPED_VALUE_REPR) - : PERSISTENT_MAP - with type t := S.t and type key := K.t and type value := T.value - -module MakeBufferedPersistentTypedMap - (S : STORE) (K : KEY) (T : TYPED_VALUE_REPR) (Map : Map.S with type key = K.t) - : BUFFERED_PERSISTENT_MAP - with type t := S.t - and type key := K.t - and type value := T.value - and module Map := Map - -module MakeHashResolver - (Store : sig - type t - val dir_mem: t -> string list -> bool Lwt.t - val list: t -> string list list -> string list list Lwt.t - val prefix: string list - end) - (H: HASH) : sig - val resolve : Store.t -> string -> H.t list Lwt.t -end diff --git a/src/node/updater/tezos_protocol_environment.ml b/src/node/updater/tezos_protocol_environment.ml index 333dda09e..79c7cc532 100644 --- a/src/node/updater/tezos_protocol_environment.ml +++ b/src/node/updater/tezos_protocol_environment.ml @@ -254,7 +254,6 @@ module Make(Param : sig val name: string end)() = struct module Ed25519 = Ed25519 module Hash = Hash module Tezos_data = Tezos_data - module Persist = Persist module RPC = RPC module Micheline = Micheline module Fitness = Fitness diff --git a/src/proto/alpha/TEZOS_PROTOCOL b/src/proto/alpha/TEZOS_PROTOCOL index 21c25a9b6..b476a04d4 100644 --- a/src/proto/alpha/TEZOS_PROTOCOL +++ b/src/proto/alpha/TEZOS_PROTOCOL @@ -26,6 +26,7 @@ "Manager_repr", "Block_header_repr", + "Persist", "Storage_sigs", "Storage_functors", "Storage", diff --git a/src/proto/alpha/misc.ml b/src/proto/alpha/misc.ml index 0e4768062..2441400fc 100644 --- a/src/proto/alpha/misc.ml +++ b/src/proto/alpha/misc.ml @@ -64,3 +64,16 @@ let take n l = | [] -> None | x :: xs -> loop (x :: acc) (n-1) xs in loop [] n l + +let remove_prefix ~prefix s = + let x = String.length prefix in + let n = String.length s in + if Compare.Int.(n >= x) && Compare.String.(String.sub s 0 x = prefix) then + Some (String.sub s x (n - x)) + else + None + +let rec remove_elem_from_list nb = function + | [] -> [] + | l when Compare.Int.(nb <= 0) -> l + | _ :: tl -> remove_elem_from_list (nb - 1) tl diff --git a/src/proto/alpha/misc.mli b/src/proto/alpha/misc.mli index 9aa4e83c8..77e76209f 100644 --- a/src/proto/alpha/misc.mli +++ b/src/proto/alpha/misc.mli @@ -20,3 +20,9 @@ val (--->) : Int32.t -> Int32.t -> Int32.t list val pp_print_paragraph : Format.formatter -> string -> unit val take: int -> 'a list -> ('a list * 'a list) option + +(** Some (input with [prefix] removed), if string has [prefix], else [None] **) +val remove_prefix: prefix:string -> string -> string option + +(** [remove nb list] remove the first [nb] elements from the list [list]. *) +val remove_elem_from_list: int -> 'a list -> 'a list diff --git a/src/node/db/persist.ml b/src/proto/alpha/persist.ml similarity index 58% rename from src/node/db/persist.ml rename to src/proto/alpha/persist.ml index 4a4e0768f..ef90b9264 100644 --- a/src/node/db/persist.ml +++ b/src/proto/alpha/persist.ml @@ -9,8 +9,6 @@ (* Tezos - Persistent structures on top of {!Store} or {!Context} *) -open Lwt.Infix - (*-- Signatures --------------------------------------------------------------*) type key = string list @@ -108,7 +106,7 @@ let prefix prf key = let unprefix prf key = let rec eat = function | k :: key, p :: prefix -> - assert (k = p) ; + assert Compare.String.(k = p) ; eat (key, prefix) | key, [] -> key | _ -> assert false in @@ -165,17 +163,17 @@ module MakeTypedStore let set s k v = S.set s k (C.to_bytes v) let del = S.del - let raw_get = S.get - end +module CompareStringList = Compare.List(Compare.String) + module RawKey = struct type t = key let prefix = [] let length = 0 let to_path p = p let of_path p = p - let compare pa pb = Pervasives.compare pa pb + let compare = CompareStringList.compare end module RawValue = struct type t = value @@ -190,7 +188,7 @@ module MakePersistentSet let to_path k = let suffix = K.to_path k in - assert (List.length suffix = K.length) ; + assert Compare.Int.(List.length suffix = K.length) ; prefix K.prefix suffix let of_path p = K.of_path (unprefix K.prefix p) @@ -216,9 +214,9 @@ module MakePersistentSet let fold c x ~f = let rec dig i root acc = - if root = inited_key then + if CompareStringList.(root = inited_key) then Lwt.return acc - else if i <= 0 then + else if Compare.Int.(i <= 0) then f (of_path root) acc else S.list c [root] >>= fun roots -> @@ -259,7 +257,7 @@ module MakePersistentMap let to_path k = let suffix = K.to_path k in - assert (List.length suffix = K.length) ; + assert Compare.Int.(List.length suffix = K.length) ; prefix K.prefix suffix let of_path p = K.of_path (unprefix K.prefix p) @@ -290,9 +288,9 @@ module MakePersistentMap let fold c x ~f = let rec dig i root acc = - if root = inited_key then + if CompareStringList.(root = inited_key) then Lwt.return acc - else if i <= 0 then + else if Compare.Int.(i <= 0) then S.get c root >>= function | None -> Lwt.return acc | Some b -> @@ -327,206 +325,6 @@ module MakeBufferedPersistentMap end -(*-- Imperative overlays ----------------------------------------------------*) - -type 'a shared_ref = - { mutable contents : 'a ; - lock : Lwt_mutex.t } -let share contents = - { contents ; - lock = Lwt_mutex.create () } -let update r f = - Lwt_mutex.with_lock r.lock - (fun () -> f r.contents >>= function - | None -> Lwt.return false - | Some new_contents -> - r.contents <- new_contents ; - Lwt.return true) -let update_with_res r f = - Lwt_mutex.with_lock r.lock - (fun () -> f r.contents >>= function - | (None, x) -> Lwt.return (false, x) - | (Some new_contents, x) -> - r.contents <- new_contents ; - Lwt.return (true, x)) -let use r f = - Lwt_mutex.with_lock r.lock - (fun () -> f r.contents) - -module type IMPERATIVE_PROXY = sig - module Store : TYPED_STORE - - type t - type rdata - type state - val create: state -> Store.t shared_ref -> t - val known: t -> Store.key -> bool Lwt.t - val read: t -> Store.key -> Store.value option Lwt.t - val store: t -> Store.key -> Store.value -> bool Lwt.t - val update: t -> Store.key -> Store.value -> bool Lwt.t - val remove: t -> Store.key -> bool Lwt.t - val prefetch: t -> rdata -> Store.key -> unit - val fetch: t -> rdata -> Store.key -> Store.value Lwt.t - val pending: t -> Store.key -> bool - val shutdown: t -> unit Lwt.t -end - -module type IMPERATIVE_PROXY_SCHEDULER = sig - module Store : TYPED_STORE - type state - type rdata - type data - - val name : string - val init_request : - state -> Store.key -> data Lwt.t - val request : - state -> - get:(rdata -> Store.key -> Store.value Lwt.t) -> - set:(Store.key -> Store.value -> unit Lwt.t) -> - (Store.key * data * rdata) list -> float -end - -module MakeImperativeProxy - (Store : TYPED_STORE) - (Table : Hashtbl.S with type key = Store.key) - (Scheduler : IMPERATIVE_PROXY_SCHEDULER with module Store := Store) - : IMPERATIVE_PROXY with module Store := Store and type state = Scheduler.state and type rdata = Scheduler.rdata = struct - - type rdata = Scheduler.rdata - type data = - { rdata: rdata ; - state: [ `Inited of Scheduler.data | `Initing of Scheduler.data Lwt.t ] ; - wakener: Store.value Lwt.u } - type state = Scheduler.state - - type t = - { tbl : data Table.t ; - store : Store.t shared_ref ; - cancelation: unit -> unit Lwt.t ; - cancel: unit -> unit Lwt.t ; - on_cancel: (unit -> unit Lwt.t) -> unit ; - worker_trigger: unit -> unit; - worker_waiter: unit -> unit Lwt.t ; - worker: unit Lwt.t ; - gstate : state } - - let pending_requests { tbl } = - Table.fold - (fun h data acc -> - match data.state with - | `Initing _ -> acc - | `Inited d -> (h, d, data.rdata) :: acc) - tbl [] - - let pending { tbl } hash = Table.mem tbl hash - - let request { tbl ; worker_trigger ; gstate } rdata hash = - assert (not (Table.mem tbl hash)); - let waiter, wakener = Lwt.wait () in - let data = Scheduler.init_request gstate hash in - match Lwt.state data with - | Lwt.Return data -> - let state = `Inited data in - Table.add tbl hash { rdata ; state ; wakener } ; - worker_trigger () ; - waiter - | _ -> - let state = `Initing data in - Table.add tbl hash { rdata ; state ; wakener } ; - Lwt.async - (fun () -> - data >>= fun data -> - let state = `Inited data in - Table.add tbl hash { rdata ; state ; wakener } ; - worker_trigger () ; - Lwt.return_unit) ; - waiter - - let prefetch ({ store ; tbl } as session) rdata hash = - Lwt.ignore_result - (use store (fun store -> Store.mem store hash) >>= fun exists -> - if not exists && not (Table.mem tbl hash) then - request session rdata hash >>= fun _ -> Lwt.return_unit - else - Lwt.return_unit) - - let known { store } hash = - use store (fun store -> Store.mem store hash) - - let read { store } hash = - use store (fun store -> Store.get store hash) - - let fetch ({ store ; tbl } as session) rdata hash = - try Lwt.waiter_of_wakener (Table.find tbl hash).wakener - with Not_found -> - use store (fun store -> Store.get store hash) >>= function - | Some op -> Lwt.return op - | None -> - try Lwt.waiter_of_wakener (Table.find tbl hash).wakener - with Not_found -> request session rdata hash - - let store { store ; tbl } hash data = - update store (fun store -> - Store.mem store hash >>= fun exists -> - if exists then Lwt.return_none - else ( Store.set store hash data >>= fun store -> - Lwt.return (Some store) ) ) >>= fun changed -> - try - let wakener = (Table.find tbl hash).wakener in - Table.remove tbl hash; - Lwt.wakeup wakener data; - Lwt.return changed - with Not_found -> Lwt.return changed - - let remove { store ; _ } hash = - update store (fun store -> - Store.mem store hash >>= fun exists -> - if not exists then Lwt.return_none - else ( Store.del store hash >>= fun store -> - Lwt.return (Some store) ) ) - - let update { store ; _ } hash data = - update store (fun store -> - Store.mem store hash >>= fun exists -> - if not exists then Lwt.return_none - else ( Store.set store hash data >>= fun store -> - Lwt.return (Some store) ) ) - - let create gstate st = - let tbl = Table.create 50 in - let cancelation, cancel, on_cancel = Lwt_utils.canceler () in - let worker_trigger, worker_waiter = Lwt_utils.trigger () in - let session = - { tbl ; gstate ; store = st ; worker = Lwt.return () ; - cancelation ; cancel ; on_cancel ; - worker_trigger ; worker_waiter } in - let worker = - let rec worker_loop () = - Lwt.pick [(worker_waiter () >|= fun () -> `Process); - (cancelation () >|= fun () -> `Cancel)] >>= function - | `Cancel -> Lwt.return_unit - | `Process -> - begin - match pending_requests session with - | [] -> () - | requests -> - let get = fetch session - and set k v = store session k v >>= fun _ -> Lwt.return_unit in - let timeout = Scheduler.request gstate ~get ~set requests in - if timeout > 0. then - Lwt.ignore_result (Lwt_unix.sleep timeout >|= worker_trigger); - end; - worker_loop () - in - Lwt_utils.worker Scheduler.name ~run:worker_loop ~cancel in - { session with worker } - - let shutdown { cancel ; worker } = - cancel () >>= fun () -> worker - -end - (*-- Predefined Instances ----------------------------------------------------*) module MBytesValue = struct @@ -578,7 +376,7 @@ module MakeHashResolver let plen = List.length Store.prefix let build path = H.of_path_exn @@ - Utils.remove_elem_from_list plen path + Misc.remove_elem_from_list plen path let resolve t p = let rec loop prefix = function | [] -> @@ -590,7 +388,7 @@ module MakeHashResolver | [d] -> Store.list t [prefix] >>= fun prefixes -> Lwt_list.filter_map_p (fun prefix -> - match remove_prefix ~prefix:d (List.hd (List.rev prefix)) with + match Misc.remove_prefix ~prefix:d (List.hd (List.rev prefix)) with | None -> Lwt.return_none | Some _ -> Lwt.return (Some (build prefix)) ) prefixes diff --git a/src/environment/v1/persist.mli b/src/proto/alpha/persist.mli similarity index 100% rename from src/environment/v1/persist.mli rename to src/proto/alpha/persist.mli