From 2498da28152ce6fb062fe0332502611a13c41395 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gr=C3=83=C2=A9goire=20Henry?= Date: Mon, 5 Feb 2018 11:32:12 +0100 Subject: [PATCH] Protocol_environment: more sharing between node and client --- src/lib_base/protocol_environment.ml | 127 +++++++++++++- src/lib_base/tzPervasives.ml | 2 + src/lib_base/tzPervasives.mli | 2 + .../jbuild_embedded_protocol_template | 3 +- src/lib_protocol_environment_client/fake.ml | 27 +-- .../fake_context.ml | 2 - .../fake_context.mli | 10 ++ .../fake_updater.ml | 2 +- .../fake_updater.mli | 11 ++ .../tezos_protocol_environment.ml | 33 ---- src/lib_protocol_updater/updater.ml | 164 +++++++++--------- src/lib_protocol_updater/updater.mli | 93 +++++----- src/lib_shell/state.ml | 2 +- src/lib_storage/context.ml | 11 -- src/lib_storage/context.mli | 4 - src/lib_storage/test/test_context.ml | 15 +- 16 files changed, 301 insertions(+), 207 deletions(-) create mode 100644 src/lib_protocol_environment_client/fake_context.mli create mode 100644 src/lib_protocol_environment_client/fake_updater.mli delete mode 100644 src/lib_protocol_updater/tezos_protocol_environment.ml diff --git a/src/lib_base/protocol_environment.ml b/src/lib_base/protocol_environment.ml index dd5789507..63332cf90 100644 --- a/src/lib_base/protocol_environment.ml +++ b/src/lib_base/protocol_environment.ml @@ -9,7 +9,59 @@ open Error_monad -module Make(Param : sig val name: string end)() = struct +module type CONTEXT = sig + type t + type key = string list + 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 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 +end + +module type UPDATER = sig + + module Context : CONTEXT + + type validation_result = { + context: Context.t ; + fitness: Fitness.t ; + message: string option ; + max_operation_data_length: int ; + max_operations_ttl: int ; + } + + type quota = { + max_size: int ; + max_op: int option ; + } + + type rpc_context = { + block_hash: Block_hash.t ; + block_header: Block_header.t ; + operation_hashes: unit -> Operation_hash.t list list Lwt.t ; + operations: unit -> Operation.t list list Lwt.t ; + context: Context.t ; + } + + val compile: Protocol_hash.t -> Protocol.t -> bool Lwt.t + val activate: Context.t -> Protocol_hash.t -> Context.t Lwt.t + val fork_test_network: + Context.t -> protocol:Protocol_hash.t -> expiration:Time.t -> Context.t Lwt.t + +end + +module MakeV1 + (Param : sig val name: string end) + (Context : CONTEXT) + (Updater : UPDATER with module Context := Context) + () = struct include Pervasives module Pervasives = Pervasives @@ -33,6 +85,7 @@ module Make(Param : sig val name: string end)() = struct module Nativeint = Nativeint module Buffer = Buffer module Format = Format + module Option = Option module Z = Z module Lwt_sequence = Lwt_sequence module Lwt = Lwt @@ -92,6 +145,76 @@ module Make(Param : sig val name: string end)() = struct | Ok _ as ok -> ok | Error errors -> Error [Ecoproto_error errors] - module Option = Option + module Updater = struct + + include Updater + + module type PROTOCOL = sig + open Error_monad + val max_block_length: int + val validation_passes: quota list + type operation + val parse_operation: + Operation_hash.t -> Operation.t -> operation tzresult + val acceptable_passes: operation -> int list + val compare_operations: operation -> operation -> int + type validation_state + val current_context: validation_state -> Context.t tzresult Lwt.t + val precheck_block: + ancestor_context: Context.t -> + ancestor_timestamp: Time.t -> + Block_header.t -> + unit tzresult Lwt.t + val begin_application: + predecessor_context: Context.t -> + predecessor_timestamp: Time.t -> + predecessor_fitness: Fitness.t -> + Block_header.t -> + validation_state tzresult Lwt.t + val begin_construction: + predecessor_context: Context.t -> + predecessor_timestamp: Time.t -> + predecessor_level: Int32.t -> + predecessor_fitness: Fitness.t -> + predecessor: Block_hash.t -> + timestamp: Time.t -> + ?proto_header: MBytes.t -> + unit -> validation_state tzresult Lwt.t + val apply_operation: + validation_state -> operation -> validation_state tzresult Lwt.t + val finalize_block: + validation_state -> validation_result tzresult Lwt.t + val rpc_services: rpc_context RPC_directory.t + val configure_sandbox: + Context.t -> Data_encoding.json option -> Context.t tzresult Lwt.t + end + + end + module Base58 = struct + include Base58 + let simple_encode enc s = simple_encode enc s + let simple_decode enc s = simple_decode enc s + include Make(struct type context = Context.t end) + let decode s = decode s + end + module Context = struct + include Context + + let fold_keys s k ~init ~f = + let rec loop k acc = + fold s k ~init:acc + ~f:(fun file acc -> + match file with + | `Key k -> f k acc + | `Dir k -> loop k acc) in + loop k init + + let keys t = fold_keys t ~init:[] ~f:(fun k acc -> Lwt.return (k :: acc)) + + let register_resolver = Base58.register_resolver + let complete ctxt s = Base58.complete ctxt s + end end + + diff --git a/src/lib_base/tzPervasives.ml b/src/lib_base/tzPervasives.ml index a5ca5655f..698287f6a 100644 --- a/src/lib_base/tzPervasives.ml +++ b/src/lib_base/tzPervasives.ml @@ -53,5 +53,7 @@ module P2p_connection = P2p_connection module P2p_stat = P2p_stat module P2p_version = P2p_version +module Protocol_environment = Protocol_environment + include Utils.Infix include Error_monad diff --git a/src/lib_base/tzPervasives.mli b/src/lib_base/tzPervasives.mli index 60ea6f4dc..671f23840 100644 --- a/src/lib_base/tzPervasives.mli +++ b/src/lib_base/tzPervasives.mli @@ -50,5 +50,7 @@ module P2p_connection = P2p_connection module P2p_stat = P2p_stat module P2p_version = P2p_version +module Protocol_environment = Protocol_environment + include (module type of (struct include Utils.Infix end)) include (module type of (struct include Error_monad end)) diff --git a/src/lib_protocol_compiler/jbuild_embedded_protocol_template b/src/lib_protocol_compiler/jbuild_embedded_protocol_template index 07e90de31..ee5808168 100644 --- a/src/lib_protocol_compiler/jbuild_embedded_protocol_template +++ b/src/lib_protocol_compiler/jbuild_embedded_protocol_template @@ -22,7 +22,7 @@ let () = Format.kasprintf Jbuild_plugin.V1.send {| ((targets (environment.ml)) (action (write-file ${@@} - "include Tezos_protocol_updater.Tezos_protocol_environment.Make(struct let name = \"%s\" end)()")))) + "include Tezos_protocol_updater.Updater.MakeV1(struct let name = \"%s\" end)()")))) (rule ((targets (registerer.ml)) @@ -47,6 +47,7 @@ let () = Format.kasprintf Jbuild_plugin.V1.send {| -w +a-4-6-7-9-29-32-40..42-44-45-48 -warn-error -a+8 -open Tezos_embedded_protocol_environment_%s__Environment + -open Pervasives -open Error_monad)) (modules (:standard \ Environment Registerer)))) diff --git a/src/lib_protocol_environment_client/fake.ml b/src/lib_protocol_environment_client/fake.ml index 2c49555f7..0ab956081 100644 --- a/src/lib_protocol_environment_client/fake.ml +++ b/src/lib_protocol_environment_client/fake.ml @@ -7,27 +7,6 @@ (* *) (**************************************************************************) -module Make(Param : sig val name: string end)() = struct - - include Tezos_base.Protocol_environment.Make(Param)() - - module Updater = struct - include Fake_updater.Make(Fake_context) - module type PROTOCOL = - RAW_PROTOCOL with type error := Error_monad.error - and type 'a tzresult := 'a Error_monad.tzresult - end - module Base58 = struct - include Base58 - let simple_encode enc s = simple_encode enc s - let simple_decode enc s = simple_decode enc s - include Make(struct type context = Fake_context.t end) - let decode s = decode s - end - module Context = struct - include Fake_context - let register_resolver = Base58.register_resolver - let complete ctxt s = Base58.complete ctxt s - end - -end +module Make(Param : sig val name: string end)() = + Tezos_base.Protocol_environment.MakeV1 + (Param)(Fake_context)(Fake_updater.Make(Fake_context))() diff --git a/src/lib_protocol_environment_client/fake_context.ml b/src/lib_protocol_environment_client/fake_context.ml index 88f5a6a8c..81f63d494 100644 --- a/src/lib_protocol_environment_client/fake_context.ml +++ b/src/lib_protocol_environment_client/fake_context.ml @@ -20,5 +20,3 @@ let remove_rec _ _ = assert false let fold _ _ ~init:_ ~f:_ = assert false let keys _ _ = assert false let fold_keys _ _ ~init:_ ~f:_ = assert false -let register_resolver _ _ = () -let complete _ _ = assert false diff --git a/src/lib_protocol_environment_client/fake_context.mli b/src/lib_protocol_environment_client/fake_context.mli new file mode 100644 index 000000000..d348f6806 --- /dev/null +++ b/src/lib_protocol_environment_client/fake_context.mli @@ -0,0 +1,10 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +include Protocol_environment.CONTEXT diff --git a/src/lib_protocol_environment_client/fake_updater.ml b/src/lib_protocol_environment_client/fake_updater.ml index ae66f594a..aac54d18d 100644 --- a/src/lib_protocol_environment_client/fake_updater.ml +++ b/src/lib_protocol_environment_client/fake_updater.ml @@ -7,7 +7,7 @@ (* *) (**************************************************************************) -module Make(Context : sig type t end) = struct +module Make(Context : Protocol_environment.CONTEXT) = struct type validation_result = { context: Context.t ; diff --git a/src/lib_protocol_environment_client/fake_updater.mli b/src/lib_protocol_environment_client/fake_updater.mli new file mode 100644 index 000000000..cc59f0267 --- /dev/null +++ b/src/lib_protocol_environment_client/fake_updater.mli @@ -0,0 +1,11 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +module Make(Context : Protocol_environment.CONTEXT) : + Protocol_environment.UPDATER with module Context := Context diff --git a/src/lib_protocol_updater/tezos_protocol_environment.ml b/src/lib_protocol_updater/tezos_protocol_environment.ml deleted file mode 100644 index 58de9b40f..000000000 --- a/src/lib_protocol_updater/tezos_protocol_environment.ml +++ /dev/null @@ -1,33 +0,0 @@ -(**************************************************************************) -(* *) -(* Copyright (c) 2014 - 2017. *) -(* Dynamic Ledger Solutions, Inc. *) -(* *) -(* All rights reserved. No warranty, explicit or implicit, provided. *) -(* *) -(**************************************************************************) - -module Make(Param : sig val name: string end)() = struct - - include Tezos_base.Protocol_environment.Make(Param)() - - module Updater = struct - include Updater - module type PROTOCOL = - RAW_PROTOCOL with type error := Error_monad.error - and type 'a tzresult := 'a Error_monad.tzresult - end - module Base58 = struct - include Base58 - let simple_encode enc s = simple_encode enc s - let simple_decode enc s = simple_decode enc s - include Make(struct type context = Context.t end) - let decode s = decode s - end - module Context = struct - include Context - let register_resolver = Base58.register_resolver - let complete ctxt s = Base58.complete ctxt s - end - -end diff --git a/src/lib_protocol_updater/updater.ml b/src/lib_protocol_updater/updater.ml index 87493361d..7fbf762cd 100644 --- a/src/lib_protocol_updater/updater.ml +++ b/src/lib_protocol_updater/updater.ml @@ -11,86 +11,92 @@ open Logging.Updater let (//) = Filename.concat -type validation_result = { - context: Context.t ; - fitness: Fitness.t ; - message: string option ; - max_operation_data_length: int ; - max_operations_ttl: int ; -} +module Raw = struct -type quota = { - max_size: int ; - max_op: int option ; -} + type validation_result = { + context: Context.t ; + fitness: Fitness.t ; + message: string option ; + max_operation_data_length: int ; + max_operations_ttl: int ; + } -type rpc_context = { - block_hash: Block_hash.t ; - block_header: Block_header.t ; - operation_hashes: unit -> Operation_hash.t list list Lwt.t ; - operations: unit -> Operation.t list list Lwt.t ; - context: Context.t ; -} + type quota = { + max_size: int ; + max_op: int option ; + } -let activate = Context.set_protocol -let fork_test_network = Context.fork_test_network + type rpc_context = { + block_hash: Block_hash.t ; + block_header: Block_header.t ; + operation_hashes: unit -> Operation_hash.t list list Lwt.t ; + operations: unit -> Operation.t list list Lwt.t ; + context: Context.t ; + } -(** Compiler *) + let activate = Context.set_protocol + let fork_test_network = Context.fork_test_network -let datadir = ref None -let get_datadir () = - match !datadir with - | None -> - fatal_error "Node not initialized" ; - Lwt_exit.exit 1 - | Some m -> m + (** Compiler *) -let init dir = - datadir := Some dir + let datadir = ref None + let get_datadir () = + match !datadir with + | None -> + fatal_error "Node not initialized" ; + Lwt_exit.exit 1 + | Some m -> m -let compiler_name = "tezos-protocol-compiler" + let init dir = + datadir := Some dir -let do_compile hash p = - assert (p.Protocol.expected_env = V1) ; - let datadir = get_datadir () in - let source_dir = datadir // Protocol_hash.to_short_b58check hash // "src" in - let log_file = datadir // Protocol_hash.to_short_b58check hash // "LOG" in - let plugin_file = datadir // Protocol_hash.to_short_b58check hash // - Format.asprintf "protocol_%a.cmxs" Protocol_hash.pp hash - in - Protocol.write_dir source_dir ~hash p >>= fun () -> - let compiler_command = - (Sys.executable_name, - Array.of_list [compiler_name; "-register"; plugin_file; source_dir]) in - let fd = Unix.(openfile log_file [O_WRONLY; O_CREAT; O_TRUNC] 0o644) in - let pi = - Lwt_process.exec - ~stdin:`Close ~stdout:(`FD_copy fd) ~stderr:(`FD_move fd) - compiler_command in - pi >>= function - | Unix.WSIGNALED _ | Unix.WSTOPPED _ -> - log_error "INTERRUPTED COMPILATION (%s)" log_file; - Lwt.return false - | Unix.WEXITED x when x <> 0 -> - log_error "COMPILATION ERROR (%s)" log_file; - Lwt.return false - | Unix.WEXITED _ -> - try Dynlink.loadfile_private plugin_file; Lwt.return true - with Dynlink.Error err -> - log_error "Can't load plugin: %s (%s)" - (Dynlink.error_message err) plugin_file; + let compiler_name = "tezos-protocol-compiler" + + let do_compile hash p = + assert (p.Protocol.expected_env = V1) ; + let datadir = get_datadir () in + let source_dir = datadir // Protocol_hash.to_short_b58check hash // "src" in + let log_file = datadir // Protocol_hash.to_short_b58check hash // "LOG" in + let plugin_file = datadir // Protocol_hash.to_short_b58check hash // + Format.asprintf "protocol_%a.cmxs" Protocol_hash.pp hash + in + Protocol.write_dir source_dir ~hash p >>= fun () -> + let compiler_command = + (Sys.executable_name, + Array.of_list [compiler_name; "-register"; plugin_file; source_dir]) in + let fd = Unix.(openfile log_file [O_WRONLY; O_CREAT; O_TRUNC] 0o644) in + let pi = + Lwt_process.exec + ~stdin:`Close ~stdout:(`FD_copy fd) ~stderr:(`FD_move fd) + compiler_command in + pi >>= function + | Unix.WSIGNALED _ | Unix.WSTOPPED _ -> + log_error "INTERRUPTED COMPILATION (%s)" log_file; Lwt.return false + | Unix.WEXITED x when x <> 0 -> + log_error "COMPILATION ERROR (%s)" log_file; + Lwt.return false + | Unix.WEXITED _ -> + try Dynlink.loadfile_private plugin_file; Lwt.return true + with Dynlink.Error err -> + log_error "Can't load plugin: %s (%s)" + (Dynlink.error_message err) plugin_file; + Lwt.return false -let compile hash p = - if Tezos_protocol_registerer.Registerer.mem hash then - Lwt.return true - else begin - do_compile hash p >>= fun success -> - let loaded = Tezos_protocol_registerer.Registerer.mem hash in - if success && not loaded then - log_error "Internal error while compiling %a" Protocol_hash.pp hash; - Lwt.return loaded - end + let compile hash p = + if Tezos_protocol_registerer.Registerer.mem hash then + Lwt.return true + else begin + do_compile hash p >>= fun success -> + let loaded = Tezos_protocol_registerer.Registerer.mem hash in + if success && not loaded then + log_error "Internal error while compiling %a" Protocol_hash.pp hash; + Lwt.return loaded + end + +end + +include Raw module Node_protocol_environment_sigs = struct @@ -118,6 +124,10 @@ module Node_protocol_environment_sigs = struct and type Updater.validation_result = validation_result and type Updater.quota = quota and type Updater.rpc_context = rpc_context + and type Ed25519.Public_key_hash.t = Ed25519.Public_key_hash.t + and type Ed25519.Public_key.t = Ed25519.Public_key.t + and type Ed25519.Signature.t = Ed25519.Signature.t + and type 'a Micheline.canonical = 'a Micheline.canonical type error += Ecoproto_error of Error_monad.error list val wrap_error : 'a Error_monad.tzresult -> 'a tzresult @@ -126,9 +136,12 @@ module Node_protocol_environment_sigs = struct end -module type RAW_PROTOCOL = sig - type error = .. - type 'a tzresult = ('a, error list) result +module MakeV1(Name : sig val name: string end)() + : Node_protocol_environment_sigs.V1 = + Protocol_environment.MakeV1(Name)(Context)(Raw)() + + +module type NODE_PROTOCOL = sig val max_block_length: int val validation_passes: quota list type operation @@ -167,11 +180,6 @@ module type RAW_PROTOCOL = sig Context.t -> Data_encoding.json option -> Context.t tzresult Lwt.t end -module type NODE_PROTOCOL = - RAW_PROTOCOL with type error := error - and type 'a tzresult := 'a tzresult - - module LiftProtocol (Name : sig val name: string end) (Env : Node_protocol_environment_sigs.V1) diff --git a/src/lib_protocol_updater/updater.mli b/src/lib_protocol_updater/updater.mli index d22784f46..39b75aeb1 100644 --- a/src/lib_protocol_updater/updater.mli +++ b/src/lib_protocol_updater/updater.mli @@ -37,9 +37,52 @@ type rpc_context = { context: Context.t ; } -module type RAW_PROTOCOL = sig - type error = .. - type 'a tzresult = ('a, error list) result +(* The end of this file is not exported to the protocol... *) + +val compiler_name: string + +module Node_protocol_environment_sigs : sig + + module type V1 = sig + + include Tezos_protocol_environment_sigs.V1.T + with type Format.formatter = Format.formatter + and type 'a Data_encoding.t = 'a Data_encoding.t + and type 'a Lwt.t = 'a Lwt.t + and type ('a, 'b) Pervasives.result = ('a, 'b) result + and type Block_hash.t = Block_hash.t + and type Operation_hash.t = Operation_hash.t + and type Operation_list_hash.t = Operation_list_hash.t + and type Operation_list_list_hash.t = Operation_list_list_hash.t + and type Context_hash.t = Context_hash.t + and type Protocol_hash.t = Protocol_hash.t + and type Context.t = Context.t + and type Time.t = Time.t + and type MBytes.t = MBytes.t + and type Operation.shell_header = Operation.shell_header + and type Operation.t = Operation.t + and type Block_header.shell_header = Block_header.shell_header + and type Block_header.t = Block_header.t + and type 'a RPC_directory.t = 'a RPC_directory.t + and type Updater.validation_result = validation_result + and type Updater.quota = quota + and type Updater.rpc_context = rpc_context + and type Ed25519.Public_key_hash.t = Ed25519.Public_key_hash.t + and type Ed25519.Public_key.t = Ed25519.Public_key.t + and type Ed25519.Signature.t = Ed25519.Signature.t + and type 'a Micheline.canonical = 'a Micheline.canonical + + type error += Ecoproto_error of Error_monad.error list + val wrap_error : 'a Error_monad.tzresult -> 'a tzresult + + end + +end + +module MakeV1(Name : sig val name: string end)() : + Node_protocol_environment_sigs.V1 + +module type NODE_PROTOCOL = sig val max_block_length: int val validation_passes: quota list type operation @@ -78,50 +121,6 @@ module type RAW_PROTOCOL = sig Context.t -> Data_encoding.json option -> Context.t tzresult Lwt.t end -(**/**) - -(* The end of this file is not exported to the protocol... *) - -val compiler_name: string - -module Node_protocol_environment_sigs : sig - - module type V1 = sig - - include Tezos_protocol_environment_sigs.V1.T - with type Format.formatter = Format.formatter - and type 'a Data_encoding.t = 'a Data_encoding.t - and type 'a Lwt.t = 'a Lwt.t - and type ('a, 'b) Pervasives.result = ('a, 'b) result - and type Block_hash.t = Block_hash.t - and type Operation_hash.t = Operation_hash.t - and type Operation_list_hash.t = Operation_list_hash.t - and type Operation_list_list_hash.t = Operation_list_list_hash.t - and type Context_hash.t = Context_hash.t - and type Protocol_hash.t = Protocol_hash.t - and type Context.t = Context.t - and type Time.t = Time.t - and type MBytes.t = MBytes.t - and type Operation.shell_header = Operation.shell_header - and type Operation.t = Operation.t - and type Block_header.shell_header = Block_header.shell_header - and type Block_header.t = Block_header.t - and type 'a RPC_directory.t = 'a RPC_directory.t - and type Updater.validation_result = validation_result - and type Updater.quota = quota - and type Updater.rpc_context = rpc_context - - type error += Ecoproto_error of Error_monad.error list - val wrap_error : 'a Error_monad.tzresult -> 'a tzresult - - end - -end - -module type NODE_PROTOCOL = - RAW_PROTOCOL with type error := error - and type 'a tzresult := 'a tzresult - module LiftProtocol(Name : sig val name: string end) (Env : Node_protocol_environment_sigs.V1) (P : Env.Updater.PROTOCOL) : diff --git a/src/lib_shell/state.ml b/src/lib_shell/state.ml index df79e9548..24c808148 100644 --- a/src/lib_shell/state.ml +++ b/src/lib_shell/state.ml @@ -706,7 +706,7 @@ module Registred_protocol = struct let module Name = struct let name = Protocol_hash.to_b58check hash end in - let module Env = Tezos_protocol_environment.Make(Name)() in + let module Env = Updater.MakeV1(Name)() in (module struct let hash = hash module P = F(Env) diff --git a/src/lib_storage/context.ml b/src/lib_storage/context.ml index 20c9ebe20..a3fc5bdd0 100644 --- a/src/lib_storage/context.ml +++ b/src/lib_storage/context.ml @@ -169,17 +169,6 @@ let fold ctxt key ~init ~f = 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/lib_storage/context.mli b/src/lib_storage/context.mli index a7d9b1c4b..75356779c 100644 --- a/src/lib_storage/context.mli +++ b/src/lib_storage/context.mli @@ -50,10 +50,6 @@ val fold: 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 -> Context_hash.t -> bool Lwt.t diff --git a/src/lib_storage/test/test_context.ml b/src/lib_storage/test/test_context.ml index 5cd1bc2ac..6177c0e75 100644 --- a/src/lib_storage/test/test_context.ml +++ b/src/lib_storage/test/test_context.ml @@ -169,7 +169,17 @@ let test_replay { idx ; genesis } = Assert.equal_string_option ~msg:__LOC__ (Some "Juillet") (c juillet) ; Lwt.return () -let test_keys { idx ; genesis } = +let fold_keys s k ~init ~f = + let rec loop k acc = + fold s k ~init:acc + ~f:(fun file acc -> + match file with + | `Key k -> f k acc + | `Dir k -> loop k acc) in + loop k init +let keys t = fold_keys t ~init:[] ~f:(fun k acc -> Lwt.return (k :: acc)) + +let test_fold { idx ; genesis } = checkout idx genesis >>= function | None -> Assert.fail_msg "checkout genesis_block" @@ -198,7 +208,6 @@ let test_keys { idx ; genesis } = Assert.equal_string_list_list ~msg:__LOC__ [] l ; Lwt.return () - (******************************************************************************) let tests : (string * (t -> unit Lwt.t)) list = [ @@ -206,7 +215,7 @@ let tests : (string * (t -> unit Lwt.t)) list = [ "continuation", test_continuation ; "fork", test_fork ; "replay", test_replay ; - "keys", test_keys ; + "fold", test_fold ; ] let () =