From a7364f0ed56e3732d715fbcc59111e6f5ac92c47 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gr=C3=A9goire=20Henry?= Date: Wed, 15 Nov 2017 16:20:08 +0100 Subject: [PATCH] Proto_env: remove `Context.list` This was a reminder of old-time (before irmin-1.0). It is now replaced with: `Context.{fold,keys}`. --- src/environment/v1/context.mli | 10 ++- src/node/db/context.ml | 32 +++++-- src/node/db/context.mli | 10 ++- src/proto/alpha/persist.ml | 124 ++++++++++++++++------------ src/proto/alpha/persist.mli | 18 ++-- src/proto/alpha/storage_functors.ml | 8 +- test/shell/test_context.ml | 33 ++++---- 7 files changed, 150 insertions(+), 85 deletions(-) diff --git a/src/environment/v1/context.mli b/src/environment/v1/context.mli index e9281a8dc..c3918966d 100644 --- a/src/environment/v1/context.mli +++ b/src/environment/v1/context.mli @@ -23,9 +23,17 @@ 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 fold: + t -> key -> init:'a -> + f:([ `Key of key | `Dir of key ] -> 'a -> 'a Lwt.t) -> + 'a Lwt.t + +val keys: t -> key -> key list Lwt.t +val fold_keys: + t -> key -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a 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 93b667e01..ceecbbc75 100644 --- a/src/node/db/context.ml +++ b/src/node/db/context.ml @@ -170,19 +170,35 @@ let raw_del ctxt key = Lwt.return { ctxt with tree } let del t key = raw_del t (data_key key) -let list_one ctxt key = - Lwt_utils.Idle_waiter.task ctxt.index.repack_scheduler @@ fun () -> - GitStore.Tree.list ctxt.tree (data_key key) >>= fun keys -> - Lwt.return (List.map (fun (k,_) -> key @ [k]) keys) - -let list ctxt keys = - Lwt_list.map_p (list_one ctxt) keys >|= List.flatten - let remove_rec ctxt key = Lwt_utils.Idle_waiter.task ctxt.index.repack_scheduler @@ fun () -> GitStore.Tree.remove ctxt.tree (data_key key) >>= fun tree -> Lwt.return { ctxt with tree } +let fold ctxt key ~init ~f = + Lwt_utils.Idle_waiter.task ctxt.index.repack_scheduler @@ fun () -> + GitStore.Tree.list ctxt.tree (data_key key) >>= fun keys -> + Lwt_list.fold_left_s + begin fun acc (name, kind) -> + let key = + match kind with + | `Contents -> `Key (key @ [name]) + | `Node -> `Dir (key @ [name]) in + f key acc + end + init keys + +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)) + (*-- Predefined Fields -------------------------------------------------------*) let get_protocol v = diff --git a/src/node/db/context.mli b/src/node/db/context.mli index 27a7a292c..88acdb18b 100644 --- a/src/node/db/context.mli +++ b/src/node/db/context.mli @@ -48,9 +48,17 @@ 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 +val fold: + context -> key -> init:'a -> + f:([ `Key of key | `Dir of key ] -> 'a -> 'a Lwt.t) -> + 'a Lwt.t + +val keys: context -> key -> key list Lwt.t +val fold_keys: + context -> key -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t + (** {2 Accessing and Updating Versions} **************************************) val exists: index -> commit -> bool Lwt.t diff --git a/src/proto/alpha/persist.ml b/src/proto/alpha/persist.ml index ef90b9264..82ebfe59c 100644 --- a/src/proto/alpha/persist.ml +++ b/src/proto/alpha/persist.ml @@ -21,8 +21,14 @@ module type STORE = sig 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 fold: + t -> key -> init:'a -> + f:([ `Key of key | `Dir of key ] -> 'a -> 'a Lwt.t) -> + 'a Lwt.t + val keys: t -> key -> key list Lwt.t + val fold_keys: + t -> key -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t end module type BYTES_STORE = sig @@ -32,7 +38,6 @@ module type BYTES_STORE = sig 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 @@ -69,7 +74,7 @@ module type PERSISTENT_SET = sig 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 + val fold : t -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t end module type BUFFERED_PERSISTENT_SET = sig @@ -88,7 +93,7 @@ module type PERSISTENT_MAP = sig 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 + val fold : t -> init:'a -> f:(key -> value -> 'a -> 'a Lwt.t) -> 'a Lwt.t end module type BUFFERED_PERSISTENT_MAP = sig @@ -123,7 +128,6 @@ module MakeBytesStore let to_path k = let suffix = K.to_path k in prefix K.prefix suffix - let of_path k = K.of_path (unprefix K.prefix k) let mem s k = S.mem s (to_path k) @@ -137,10 +141,6 @@ module MakeBytesStore let del s k = S.del s (to_path k) - let list s l = - S.list s (List.map to_path l) >>= fun res -> - Lwt.return (List.map of_path res) - let remove_rec s k = S.remove_rec s (to_path k) @@ -212,21 +212,26 @@ module MakePersistentSet let clear c = S.remove_rec c K.prefix - let fold c x ~f = - let rec dig i root acc = - if CompareStringList.(root = inited_key) then - Lwt.return acc - else if Compare.Int.(i <= 0) then - f (of_path root) acc + let fold s ~init ~f = + let rec dig i path acc = + if Compare.Int.(i <= 1) then + S.fold s path ~init:acc ~f:begin fun k acc -> + match k with + | `Dir _ -> Lwt.return acc + | `Key file -> f (of_path file) acc + end else - S.list c [root] >>= fun roots -> - Lwt_list.fold_right_s (dig (i - 1)) roots acc in - S.mem c inited_key >>= function - | true -> dig K.length K.prefix x - | false -> Lwt.return x + S.fold s path ~init:acc ~f:begin fun k acc -> + match k with + | `Dir k -> + dig (i-1) k acc + | `Key _ -> + Lwt.return acc + end in + dig K.length K.prefix init - let iter c ~f = fold c () ~f:(fun x () -> f x) - let elements c = fold c [] ~f:(fun p xs -> Lwt.return (p :: xs)) + let iter c ~f = fold c ~init:() ~f:(fun x () -> f x) + let elements c = fold c ~init:[] ~f:(fun p xs -> Lwt.return (p :: xs)) end @@ -236,7 +241,7 @@ module MakeBufferedPersistentSet include MakePersistentSet(S)(K) let read c = - fold c Set.empty ~f:(fun p set -> Lwt.return (Set.add p set)) + fold c ~init:Set.empty ~f:(fun p set -> Lwt.return (Set.add p set)) let write c set = S.set c inited_key empty >>= fun c -> @@ -286,26 +291,32 @@ module MakePersistentMap let clear c = S.remove_rec c K.prefix - let fold c x ~f = - let rec dig i root acc = - if CompareStringList.(root = inited_key) then - Lwt.return acc - else if Compare.Int.(i <= 0) then - S.get c root >>= function - | None -> Lwt.return acc - | Some b -> - match C.of_bytes b with - | None -> Lwt.return acc - | Some v -> f (of_path root) v acc + let fold s ~init ~f = + let rec dig i path acc = + if Compare.Int.(i <= 1) then + S.fold s path ~init:acc ~f:begin fun k acc -> + match k with + | `Dir _ -> Lwt.return acc + | `Key file -> + S.get s file >>= function + | None -> Lwt.return acc + | Some b -> + match C.of_bytes b with + | None -> + (* Silently ignore unparsable data *) + Lwt.return acc + | Some v -> f (of_path file) v acc + end else - S.list c [root] >>= fun roots -> - Lwt_list.fold_right_s (dig (i - 1)) roots acc in - S.mem c inited_key >>= function - | true -> dig K.length K.prefix x - | false -> Lwt.return x + S.fold s path ~init:acc ~f:begin fun k acc -> + match k with + | `Dir k -> dig (i-1) k acc + | `Key _ -> Lwt.return acc + end in + dig K.length K.prefix init - let iter c ~f = fold c () ~f:(fun k v () -> f k v) - let bindings c = fold c [] ~f:(fun k v acc -> Lwt.return ((k, v) :: acc)) + let iter c ~f = fold c ~init:() ~f:(fun k v () -> f k v) + let bindings c = fold c ~init:[] ~f:(fun k v acc -> Lwt.return ((k, v) :: acc)) end @@ -314,7 +325,7 @@ module MakeBufferedPersistentMap include MakePersistentMap(S)(K)(C) - let read c = fold c Map.empty ~f:(fun k v m -> Lwt.return (Map.add k v m)) + let read c = fold c ~init:Map.empty ~f:(fun k v m -> Lwt.return (Map.add k v m)) let write c m = clear c >>= fun c -> @@ -369,7 +380,10 @@ 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 fold: + t -> key -> init:'a -> + f:([ `Key of key | `Dir of key ] -> 'a -> 'a Lwt.t) -> + 'a Lwt.t val prefix: string list end) (H: HASH) = struct @@ -377,20 +391,28 @@ module MakeHashResolver let build path = H.of_path_exn @@ Misc.remove_elem_from_list plen path + let list t k = + Store.fold t k ~init:[] ~f:(fun k acc -> Lwt.return (k :: acc)) let resolve t p = let rec loop prefix = function | [] -> - Lwt.return [build prefix] + list t prefix >>= fun prefixes -> + Lwt_list.map_p (function + | `Key prefix | `Dir prefix -> loop prefix []) prefixes + >|= List.flatten | "" :: ds -> - Store.list t [prefix] >>= fun prefixes -> - Lwt_list.map_p (fun prefix -> loop prefix ds) prefixes + list t prefix >>= fun prefixes -> + Lwt_list.map_p (function + | `Key prefix | `Dir prefix -> loop prefix ds) prefixes >|= List.flatten | [d] -> - Store.list t [prefix] >>= fun prefixes -> - Lwt_list.filter_map_p (fun prefix -> - match Misc.remove_prefix ~prefix:d (List.hd (List.rev prefix)) with - | None -> Lwt.return_none - | Some _ -> Lwt.return (Some (build prefix)) + list t prefix >>= fun prefixes -> + Lwt_list.filter_map_p (function + | `Dir _ -> Lwt.return_none + | `Key prefix -> + match Misc.remove_prefix ~prefix:d (List.hd (List.rev prefix)) with + | None -> Lwt.return_none + | Some _ -> Lwt.return (Some (build prefix)) ) prefixes | d :: ds -> Store.dir_mem t (prefix @ [d]) >>= function diff --git a/src/proto/alpha/persist.mli b/src/proto/alpha/persist.mli index 5ff893a45..51c238e23 100644 --- a/src/proto/alpha/persist.mli +++ b/src/proto/alpha/persist.mli @@ -23,8 +23,14 @@ module type STORE = sig 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 fold: + t -> key -> init:'a -> + f:([ `Key of key | `Dir of key ] -> 'a -> 'a Lwt.t) -> + 'a Lwt.t + val keys: t -> key -> key list Lwt.t + val fold_keys: + t -> key -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t end (** Projection of OCaml keys of some abstract type to concrete storage @@ -62,7 +68,6 @@ module type BYTES_STORE = sig 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 @@ -100,7 +105,7 @@ module type PERSISTENT_SET = sig 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 + val fold : t -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t end (** Signature of a buffered set as returned by {!MakeBufferedPersistentSet} *) @@ -139,7 +144,7 @@ module type PERSISTENT_MAP = sig 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 + val fold : t -> init:'a -> f:(key -> value -> 'a -> 'a Lwt.t) -> 'a Lwt.t end (** Signature of a buffered map as returned by {!MakeBufferedPersistentMap} *) @@ -202,7 +207,10 @@ module MakeHashResolver (Store : sig type t val dir_mem: t -> key -> bool Lwt.t - val list: t -> key list -> key list Lwt.t + val fold: + t -> key -> init:'a -> + f:([ `Key of key | `Dir of key ] -> 'a -> 'a Lwt.t) -> + 'a Lwt.t val prefix: string list end) (H: Hash.HASH) : sig diff --git a/src/proto/alpha/storage_functors.ml b/src/proto/alpha/storage_functors.ml index 6c515658f..ac6285f6f 100644 --- a/src/proto/alpha/storage_functors.ml +++ b/src/proto/alpha/storage_functors.ml @@ -266,7 +266,7 @@ module Make_data_set_storage (P : Single_data_description) = struct map_s (fun (_, data) -> Lwt.return (unserial data)) elts let fold { context = c } init ~f = - HashTbl.fold c (ok init) + HashTbl.fold c ~init:(ok init) ~f:(fun _ data acc -> match acc with | Error _ -> Lwt.return acc @@ -278,7 +278,7 @@ module Make_data_set_storage (P : Single_data_description) = struct return acc) let clear ({ context = c } as s) = - HashTbl.fold c c ~f:(fun hash _ c -> HashTbl.del c hash) >>= fun c -> + HashTbl.fold c ~init:c ~f:(fun hash _ c -> HashTbl.del c hash) >>= fun c -> return { s with context = c } end @@ -363,8 +363,8 @@ module Raw_make_iterable_data_storage HashTbl.clear c >>= fun c -> Lwt.return { s with context = c } - let fold { context = c } x ~f = HashTbl.fold c x ~f:(fun k v acc -> f k v acc) - let iter { context = c } ~f = HashTbl.fold c () ~f:(fun k v () -> f k v) + let fold { context = c } x ~f = HashTbl.fold c ~init:x ~f:(fun k v acc -> f k v acc) + let iter { context = c } ~f = HashTbl.fold c ~init:() ~f:(fun k v () -> f k v) end diff --git a/test/shell/test_context.ml b/test/shell/test_context.ml index 0331fbe14..ba0d3e576 100644 --- a/test/shell/test_context.ml +++ b/test/shell/test_context.ml @@ -176,7 +176,7 @@ let test_replay { idx ; genesis } = Assert.equal_string_option ~msg:__LOC__ (Some "Juillet") (c juillet) ; Lwt.return () -let test_list { idx ; genesis } = +let test_keys { idx ; genesis } = checkout idx genesis >>= function | None -> Assert.fail_msg "checkout genesis_block" @@ -186,20 +186,23 @@ let test_list { idx ; genesis } = 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 -> - list ctxt [[]] >>= fun l -> - Assert.equal_string_list_list ~msg:__LOC__ [["a"];["f"];["g"]] l ; - list ctxt [["a"]] >>= fun l -> - Assert.equal_string_list_list - ~msg:__LOC__ [["a";"b"]; ["a";"c"]; ["a";"d"]] l ; - list ctxt [["f"]] >>= fun l -> - Assert.equal_string_list_list ~msg:__LOC__ [] l ; - list ctxt [["g"]] >>= fun l -> - Assert.equal_string_list_list ~msg:__LOC__ [["g";"h"]] l ; - list ctxt [["i"]] >>= fun l -> - Assert.equal_string_list_list ~msg:__LOC__ [] l ; - list ctxt [["a"];["g"]] >>= fun l -> + keys ctxt [] >>= fun l -> Assert.equal_string_list_list ~msg:__LOC__ - [["a"; "b"]; ["a"; "c"]; ["a"; "d"]; ["g"; "h"]] l ; + [["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 () @@ -210,7 +213,7 @@ let tests : (string * (t -> unit Lwt.t)) list = [ "continuation", test_continuation ; "fork", test_fork ; "replay", test_replay ; - "list", test_list ; + "keys", test_keys ; ] let () =