From fe3381358f255c19a7b96446aeea0a3b7f4ed3eb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Fri, 28 Aug 2020 16:26:35 +0200 Subject: [PATCH 1/9] Lib_client: prefer Lwtreslib's standardised traversors --- src/lib_client_base_unix/client_config.ml | 19 ++++++++++--------- src/lib_client_base_unix/client_main_run.ml | 2 +- src/lib_client_commands/client_commands.ml | 3 +-- src/lib_client_commands/client_commands.mli | 2 +- 4 files changed, 13 insertions(+), 13 deletions(-) diff --git a/src/lib_client_base_unix/client_config.ml b/src/lib_client_base_unix/client_config.ml index 422de8d729ee..93a66a286407 100644 --- a/src/lib_client_base_unix/client_config.ml +++ b/src/lib_client_base_unix/client_config.ml @@ -328,15 +328,16 @@ let wait_parameter () = let protocol_parameter () = parameter (fun _ arg -> - try - let (hash, _commands) = - List.find - (fun (hash, _commands) -> - String.has_prefix ~prefix:arg (Protocol_hash.to_b58check hash)) - (Client_commands.get_versions ()) - in - return_some hash - with Not_found -> fail (Invalid_protocol_argument arg)) + match + Seq.find_first + (fun (hash, _commands) -> + String.has_prefix ~prefix:arg (Protocol_hash.to_b58check hash)) + (Client_commands.get_versions ()) + with + | Some (hash, _commands) -> + return_some hash + | None -> + fail (Invalid_protocol_argument arg)) (* Command-line only args (not in config file) *) let base_dir_arg () = diff --git a/src/lib_client_base_unix/client_main_run.ml b/src/lib_client_base_unix/client_main_run.ml index 05aa7c5890a6..5185886434b1 100644 --- a/src/lib_client_base_unix/client_main_run.ml +++ b/src/lib_client_base_unix/client_main_run.ml @@ -35,7 +35,7 @@ let builtin_commands = no_options (fixed ["list"; "understood"; "protocols"]) (fun () (cctxt : #Client_context.full) -> - Lwt_list.iter_s + Seq.iter_s (fun (ver, _) -> cctxt#message "%a" Protocol_hash.pp_short ver) (Client_commands.get_versions ()) >>= fun () -> return_unit) ] diff --git a/src/lib_client_commands/client_commands.ml b/src/lib_client_commands/client_commands.ml index 47587e3d68ed..a2e5ec40e857 100644 --- a/src/lib_client_commands/client_commands.ml +++ b/src/lib_client_commands/client_commands.ml @@ -33,8 +33,7 @@ exception Version_not_found let versions = Protocol_hash.Table.create 7 -let get_versions () = - Protocol_hash.Table.fold (fun k c acc -> (k, c) :: acc) versions [] +let get_versions () = Protocol_hash.Table.to_seq versions let register name commands = let previous = diff --git a/src/lib_client_commands/client_commands.mli b/src/lib_client_commands/client_commands.mli index 361acd889b33..59a9a825980a 100644 --- a/src/lib_client_commands/client_commands.mli +++ b/src/lib_client_commands/client_commands.mli @@ -36,4 +36,4 @@ val register : Protocol_hash.t -> (network option -> command list) -> unit val commands_for_version : Protocol_hash.t -> network option -> command list val get_versions : - unit -> (Protocol_hash.t * (network option -> command list)) list + unit -> (Protocol_hash.t * (network option -> command list)) Seq.t -- GitLab From c4fdbc3f66bf720ca48dcb00d4544a49013a7254 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Fri, 28 Aug 2020 17:06:49 +0200 Subject: [PATCH 2/9] Protocol_updater: use Seq to avoid multiple conversions --- src/lib_protocol_updater/registered_protocol.ml | 4 ++-- src/lib_protocol_updater/registered_protocol.mli | 4 ++-- src/lib_shell/node.ml | 4 ++-- src/lib_shell/protocol_directory.ml | 4 +--- 4 files changed, 7 insertions(+), 9 deletions(-) diff --git a/src/lib_protocol_updater/registered_protocol.ml b/src/lib_protocol_updater/registered_protocol.ml index 52c6e99feaec..6a3e4594a2d3 100644 --- a/src/lib_protocol_updater/registered_protocol.ml +++ b/src/lib_protocol_updater/registered_protocol.ml @@ -117,9 +117,9 @@ let get_result hash = | None -> fail (Unregistered_protocol hash) -let list () = VersionTable.fold (fun _ p acc -> p :: acc) versions [] +let seq () = VersionTable.to_seq_values versions -let list_embedded () = VersionTable.fold (fun k _ acc -> k :: acc) sources [] +let seq_embedded () = VersionTable.to_seq_keys sources let get_embedded_sources hash = VersionTable.find sources hash diff --git a/src/lib_protocol_updater/registered_protocol.mli b/src/lib_protocol_updater/registered_protocol.mli index 12310784de6d..358d0e53174b 100644 --- a/src/lib_protocol_updater/registered_protocol.mli +++ b/src/lib_protocol_updater/registered_protocol.mli @@ -46,13 +46,13 @@ type t = (module T) val mem : Protocol_hash.t -> bool -val list : unit -> t list +val seq : unit -> t Seq.t val get : Protocol_hash.t -> t option val get_result : Protocol_hash.t -> t tzresult Lwt.t -val list_embedded : unit -> Protocol_hash.t list +val seq_embedded : unit -> Protocol_hash.t Seq.t val get_embedded_sources : Protocol_hash.t -> Protocol.t option diff --git a/src/lib_shell/node.ml b/src/lib_shell/node.ml index 9652fc956385..f8305516b7d5 100644 --- a/src/lib_shell/node.ml +++ b/src/lib_shell/node.ml @@ -176,8 +176,8 @@ module Local_logging = Internal_event.Legacy_logging.Make_semantic (struct end) let store_known_protocols state = - let embedded_protocols = Registered_protocol.list_embedded () in - Lwt_list.iter_s + let embedded_protocols = Registered_protocol.seq_embedded () in + Seq.iter_s (fun protocol_hash -> State.Protocol.known state protocol_hash >>= function diff --git a/src/lib_shell/protocol_directory.ml b/src/lib_shell/protocol_directory.ml index 6ed74d1c7eda..b60a3629675e 100644 --- a/src/lib_shell/protocol_directory.ml +++ b/src/lib_shell/protocol_directory.ml @@ -35,9 +35,7 @@ let build_rpc_directory block_validator state = State.Protocol.list state >>= fun set -> let protocols = - Protocol_hash.Set.add_seq - (List.to_seq @@ Registered_protocol.list_embedded ()) - set + Protocol_hash.Set.add_seq (Registered_protocol.seq_embedded ()) set in RPC_answer.return (Protocol_hash.Set.elements protocols)) ; register1 Protocol_services.S.contents (fun hash () () -> -- GitLab From a0a208dd767e1e087093257bfa3aeb8d5cb89948 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Fri, 28 Aug 2020 17:23:42 +0200 Subject: [PATCH 3/9] Shell: prefer Lwtreslib's standardised traversors This also includes using `Seq` to avoid multiple conversions/allocations which is possible because of Lwtreslib's support. --- src/lib_shell/chain_validator.ml | 6 +--- src/lib_shell/distributed_db.ml | 9 +++-- src/lib_shell/monitor_directory.ml | 14 +++++--- src/lib_shell/node.ml | 2 +- src/lib_shell/p2p_reader.ml | 58 +++++++++--------------------- src/lib_shell/prevalidation.ml | 7 ++-- src/lib_shell/snapshots.ml | 6 ++-- src/lib_shell/state.ml | 40 ++++++++------------- src/lib_shell/state.mli | 2 +- 9 files changed, 55 insertions(+), 89 deletions(-) diff --git a/src/lib_shell/chain_validator.ml b/src/lib_shell/chain_validator.ml index 499e2e67256d..9877bf8de537 100644 --- a/src/lib_shell/chain_validator.ml +++ b/src/lib_shell/chain_validator.ml @@ -537,11 +537,7 @@ let on_close w = [] in Lwt.join - ( ( match nv.prevalidator with - | Some prevalidator -> - Prevalidator.shutdown prevalidator - | None -> - Lwt.return_unit ) + ( Lwt_utils.may ~f:Prevalidator.shutdown nv.prevalidator :: Lwt_utils.may ~f:(fun (_, shutdown) -> shutdown ()) nv.child :: pvs ) diff --git a/src/lib_shell/distributed_db.ml b/src/lib_shell/distributed_db.ml index 03f0afe932b8..6962f8a6b185 100644 --- a/src/lib_shell/distributed_db.ml +++ b/src/lib_shell/distributed_db.ml @@ -228,22 +228,21 @@ let deactivate chain_db = let chain_id = State.Chain.id chain_db.reader_chain_db.chain_state in Chain_id.Table.remove active_chains chain_id ; let sends = - P2p_peer.Table.fold - (fun gid conn acc -> + P2p_peer.Table.iter_ep + (fun gid conn -> chain_db.reader_chain_db.callback.disconnection gid ; chain_db.reader_chain_db.active_peers := P2p_peer.Set.remove gid !(chain_db.reader_chain_db.active_peers) ; P2p_peer.Table.remove chain_db.reader_chain_db.active_connections gid ; - P2p.send p2p conn (Deactivate chain_id) :: acc) + P2p.send p2p conn (Deactivate chain_id)) chain_db.reader_chain_db.active_connections - [] in Error_monad.dont_wait (fun exc -> Format.eprintf "Uncaught exception: %s\n%!" (Printexc.to_string exc)) (fun trace -> Format.eprintf "Uncaught error: %a\n%!" Error_monad.pp_print_error trace) - (fun () -> join_ep sends) ; + (fun () -> sends) ; Distributed_db_requester.Raw_operation.shutdown chain_db.reader_chain_db.operation_db >>= fun () -> diff --git a/src/lib_shell/monitor_directory.ml b/src/lib_shell/monitor_directory.ml index a30e2c927810..7361e737ae4f 100644 --- a/src/lib_shell/monitor_directory.ml +++ b/src/lib_shell/monitor_directory.ml @@ -67,12 +67,16 @@ let build_rpc_directory validator mainchain_validator = | [] -> Lwt.return_true | chains -> - let chain_id = State.Block.chain_id block in - Lwt_list.filter_map_p - (Chain_directory.get_chain_id_opt state) + let that_chain_id = State.Block.chain_id block in + Lwt_list.exists_p + (fun chain -> + Chain_directory.get_chain_id_opt state chain + >|= function + | None -> + false + | Some this_chain_id -> + Chain_id.equal this_chain_id that_chain_id) chains - >>= fun chains -> - Lwt.return (List.exists (Chain_id.equal chain_id) chains) in let in_protocols block = match q#protocols with diff --git a/src/lib_shell/node.ml b/src/lib_shell/node.ml index f8305516b7d5..1a1dd1c361f1 100644 --- a/src/lib_shell/node.ml +++ b/src/lib_shell/node.ml @@ -264,7 +264,7 @@ let check_and_fix_storage_consistency state vp = (* Make sure to remove the block only after updating the head *) State.Block.remove block in - iter_s + Seq.iter_es (fun chain_state -> Chain.head chain_state >>= fun block -> check_block 500 chain_state block) chains diff --git a/src/lib_shell/p2p_reader.ml b/src/lib_shell/p2p_reader.ml index c04fd029d71d..19d3f434c0b4 100644 --- a/src/lib_shell/p2p_reader.ml +++ b/src/lib_shell/p2p_reader.ml @@ -105,38 +105,21 @@ let may_handle_global state chain_id f = f chain_db let find_pending_operations {peer_active_chains; _} h i = - Chain_id.Table.fold - (fun _chain_id chain_db acc -> - match acc with - | Some _ -> - acc - | None - when Distributed_db_requester.Raw_operations.pending - chain_db.operations_db - (h, i) -> - Some chain_db - | None -> - None) - peer_active_chains - None + Chain_id.Table.to_seq_values peer_active_chains + |> Seq.find_first (fun chain_db -> + Distributed_db_requester.Raw_operations.pending + chain_db.operations_db + (h, i)) let find_pending_operation {peer_active_chains; _} h = - Chain_id.Table.fold - (fun _chain_id chain_db acc -> - match acc with - | Some _ -> - acc - | None - when Distributed_db_requester.Raw_operation.pending - chain_db.operation_db - h -> - Some chain_db - | None -> - None) - peer_active_chains - None + Chain_id.Table.to_seq_values peer_active_chains + |> Seq.find_first (fun chain_db -> + Distributed_db_requester.Raw_operation.pending chain_db.operation_db h) let read_operation state h = + (* NOTE: to optimise this into an early-return map-and-search we need either a + special [Seq.find_first_map : ('a -> 'b option) -> 'a Seq.t -> 'b option] + or we need a [Seq.map_s] that is lazy. *) Chain_id.Table.fold_s (fun chain_id chain_db acc -> match acc with @@ -161,20 +144,11 @@ let read_block_header {disk; _} h = Lwt.return_none let find_pending_block_header {peer_active_chains; _} h = - Chain_id.Table.fold - (fun _chain_id chain_db acc -> - match acc with - | Some _ -> - acc - | None - when Distributed_db_requester.Raw_block_header.pending - chain_db.block_header_db - h -> - Some chain_db - | None -> - None) - peer_active_chains - None + Chain_id.Table.to_seq_values peer_active_chains + |> Seq.find_first (fun chain_db -> + Distributed_db_requester.Raw_block_header.pending + chain_db.block_header_db + h) let deactivate gid chain_db = chain_db.callback.disconnection gid ; diff --git a/src/lib_shell/prevalidation.ml b/src/lib_shell/prevalidation.ml index a277b5431cea..1877c5bd5afd 100644 --- a/src/lib_shell/prevalidation.ml +++ b/src/lib_shell/prevalidation.ml @@ -290,7 +290,7 @@ let preapply ~user_activated_upgrades ~user_activated_protocol_overrides Prevalidation.create ~protocol_data ~predecessor ~timestamp () >>=? fun validation_state -> Lwt_list.fold_left_s - (fun (acc_validation_result, acc_validation_state) operations -> + (fun (acc_validation_result_rev, acc_validation_state) operations -> Lwt_list.fold_left_s (fun (acc_validation_result, acc_validation_state) op -> match Prevalidation.parse op with @@ -313,9 +313,12 @@ let preapply ~user_activated_upgrades ~user_activated_protocol_overrides } in Lwt.return - (acc_validation_result @ [new_validation_result], new_validation_state)) + ( new_validation_result :: acc_validation_result_rev, + new_validation_state )) ([], validation_state) operations + >>= fun (validation_result_list_rev, validation_state) -> + Lwt.return (List.rev validation_result_list_rev, validation_state) >>= fun (validation_result_list, validation_state) -> let operations_hash = Operation_list_list_hash.compute diff --git a/src/lib_shell/snapshots.ml b/src/lib_shell/snapshots.ml index 25f16ebddf6c..fd5e8c5743a1 100644 --- a/src/lib_shell/snapshots.ml +++ b/src/lib_shell/snapshots.ml @@ -952,7 +952,7 @@ let import ?(reconstruct = false) ?patch_context ~data_dir (fun () -> let k_store_pruned_blocks data = Store.with_atomic_rw store (fun () -> - Error_monad.iter_s + Lwt_list.iter_s (fun (pruned_header_hash, pruned_block) -> Store.Block.Pruned_contents.store (block_store, pruned_header_hash) @@ -972,9 +972,9 @@ let import ?(reconstruct = false) ?patch_context ~data_dir (block_store, pruned_header_hash) i v) - pruned_block.operation_hashes - >>= fun () -> return_unit) + pruned_block.operation_hashes) data) + >>= fun () -> return_unit in (* Restore context and fetch data *) restore_contexts diff --git a/src/lib_shell/state.ml b/src/lib_shell/state.ml index 25462b5bc5d1..71d0c4589c2b 100644 --- a/src/lib_shell/state.ml +++ b/src/lib_shell/state.ml @@ -368,23 +368,17 @@ end let locked_valid_heads_for_checkpoint block_store data checkpoint = Store.Chain_data.Known_heads.read_all data.chain_data_store >>= fun heads -> - Block_hash.Set.fold - (fun head acc -> - let valid_header = - Header.read_opt (block_store, head) - >|= Option.unopt_assert ~loc:__POS__ - >>= fun header -> - Locked_block.is_valid_for_checkpoint block_store head header checkpoint - >>= fun valid -> Lwt.return (valid, header) - in - acc - >>= fun (valid_heads, invalid_heads) -> - valid_header - >>= fun (valid, header) -> + Block_hash.Set.fold_s + (fun head (valid_heads, invalid_heads) -> + Header.read_opt (block_store, head) + >|= Option.unopt_assert ~loc:__POS__ + >>= fun header -> + Locked_block.is_valid_for_checkpoint block_store head header checkpoint + >>= fun valid -> if valid then Lwt.return ((head, header) :: valid_heads, invalid_heads) else Lwt.return (valid_heads, (head, header) :: invalid_heads)) heads - (Lwt.return ([], [])) + ([], []) (* Tag as invalid all blocks in `heads` and their predecessors whose level strictly higher to 'level'. *) @@ -725,8 +719,7 @@ module Chain = struct let all state = Shared.use state.global_data (fun {chains; _} -> - Lwt.return - @@ Chain_id.Table.fold (fun _ chain acc -> chain :: acc) chains []) + Lwt.return @@ Chain_id.Table.to_seq_values chains) let id {chain_id; _} = chain_id @@ -1627,20 +1620,17 @@ let best_known_head_for_checkpoint chain_state checkpoint = header = genesis_header; } in - Block_hash.Set.fold + Block_hash.Set.fold_s (fun head best -> - let valid_predecessor = find_valid_predecessor head in - best - >>= fun best -> - valid_predecessor - >>= fun pred -> + find_valid_predecessor head + >|= fun pred -> if Fitness.( pred.header.shell.fitness > best.header.shell.fitness) - then Lwt.return pred - else Lwt.return best) + then pred + else best) heads - (Lwt.return genesis))) + genesis)) module Protocol = struct include Protocol diff --git a/src/lib_shell/state.mli b/src/lib_shell/state.mli index 032559f403f3..98e4543ccb28 100644 --- a/src/lib_shell/state.mli +++ b/src/lib_shell/state.mli @@ -68,7 +68,7 @@ module Chain : sig val test : chain_state -> Chain_id.t option Lwt.t (** Returns all the known chains. *) - val all : global_state -> chain_state list Lwt.t + val all : global_state -> chain_state Seq.t Lwt.t (** Destroy a chain: this completely removes from the local storage all the data associated to the chain (this includes blocks and -- GitLab From ae6877f41e9741ddfb8a2f527cdb210d96327188 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Tue, 8 Sep 2020 09:39:47 +0200 Subject: [PATCH 4/9] Shell: minor optimisation of prevalidation --- src/lib_shell/prevalidation.ml | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) diff --git a/src/lib_shell/prevalidation.ml b/src/lib_shell/prevalidation.ml index 1877c5bd5afd..5b789e445244 100644 --- a/src/lib_shell/prevalidation.ml +++ b/src/lib_shell/prevalidation.ml @@ -290,7 +290,10 @@ let preapply ~user_activated_upgrades ~user_activated_protocol_overrides Prevalidation.create ~protocol_data ~predecessor ~timestamp () >>=? fun validation_state -> Lwt_list.fold_left_s - (fun (acc_validation_result_rev, acc_validation_state) operations -> + (fun ( acc_validation_passes, + acc_validation_result_rev, + acc_validation_state ) + operations -> Lwt_list.fold_left_s (fun (acc_validation_result, acc_validation_state) op -> match Prevalidation.parse op with @@ -313,19 +316,20 @@ let preapply ~user_activated_upgrades ~user_activated_protocol_overrides } in Lwt.return - ( new_validation_result :: acc_validation_result_rev, + ( acc_validation_passes + 1, + new_validation_result :: acc_validation_result_rev, new_validation_state )) - ([], validation_state) + (0, [], validation_state) operations - >>= fun (validation_result_list_rev, validation_state) -> + >>= fun (validation_passes, validation_result_list_rev, validation_state) -> Lwt.return (List.rev validation_result_list_rev, validation_state) >>= fun (validation_result_list, validation_state) -> let operations_hash = Operation_list_list_hash.compute - (List.map + (List.rev_map (fun r -> Operation_list_hash.compute (List.map fst r.Preapply_result.applied)) - validation_result_list) + validation_result_list_rev) in Prevalidation.status validation_state >>=? fun {block_result; _} -> @@ -353,7 +357,7 @@ let preapply ~user_activated_upgrades ~user_activated_protocol_overrides proto_level; predecessor = State.Block.hash predecessor; timestamp; - validation_passes = List.length validation_result_list; + validation_passes; operations_hash; fitness; context = Context_hash.zero (* place holder *); -- GitLab From 2ce64d5e2df54f7895310ea0baa61e49138451dc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Mon, 31 Aug 2020 10:27:00 +0200 Subject: [PATCH 5/9] P2p: prefer Lwtreslib's standardised traversors --- src/lib_p2p/p2p_maintenance.ml | 6 +++--- src/lib_p2p/p2p_pool.ml | 22 ++++++++++------------ 2 files changed, 13 insertions(+), 15 deletions(-) diff --git a/src/lib_p2p/p2p_maintenance.ml b/src/lib_p2p/p2p_maintenance.ml index aec91cb22b84..d158a3d4cd12 100644 --- a/src/lib_p2p/p2p_maintenance.ml +++ b/src/lib_p2p/p2p_maintenance.ml @@ -104,12 +104,12 @@ let classify pool private_mode start_time seen_points point pi = with points in [contactable]. It returns the number of established connections *) let establish t contactable = - let try_to_connect acc point = + let try_to_connect count point = protect ~canceler:t.canceler (fun () -> P2p_connect_handler.connect t.connect_handler point) - >>= function Ok _ -> acc >|= succ | Error _ -> acc + >|= function Ok _ -> succ count | Error _ -> count in - List.fold_left try_to_connect (Lwt.return 0) contactable + Lwt_list.fold_left_s try_to_connect 0 contactable (* [connectable t start_time expected seen_points] selects at most [expected] connections candidates from the known points, not in [seen] diff --git a/src/lib_p2p/p2p_pool.ml b/src/lib_p2p/p2p_pool.ml index b147a9eb28e8..82f17702d973 100644 --- a/src/lib_p2p/p2p_pool.ml +++ b/src/lib_p2p/p2p_pool.ml @@ -216,17 +216,15 @@ let connection_of_peer_id pool peer_id = (* Every running connection matching the point's ip address is returned. *) let connections_of_addr pool addr = - P2p_point.Table.fold - (fun (addr', _) p acc -> - if Ipaddr.V6.compare addr addr' = 0 then - match P2p_point_state.get p with - | P2p_point_state.Running {data; _} -> - data :: acc - | _ -> - acc - else acc) - pool.connected_points - [] + P2p_point.Table.to_seq pool.connected_points + |> Seq.filter_map (fun ((addr', _), p) -> + if Ipaddr.V6.compare addr addr' = 0 then + match P2p_point_state.get p with + | P2p_point_state.Running {data; _} -> + Some data + | _ -> + None + else None) let get_addr pool peer_id = Option.map @@ -271,7 +269,7 @@ module Points = struct let ban pool (addr, _port) = P2p_acl.IPBlacklist.add pool.acl addr ; (* Kick [addr]:* if it is in `Running` state. *) - Lwt_list.iter_p + Seq.iter_p (fun conn -> P2p_conn.disconnect conn) (connections_of_addr pool addr) -- GitLab From 72e051fc54b06a8cbacd08359e48d604a70f171f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Mon, 31 Aug 2020 11:21:06 +0200 Subject: [PATCH 6/9] Requester: prefer Lwtreslib's standardised traversors --- src/lib_requester/requester.ml | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/src/lib_requester/requester.ml b/src/lib_requester/requester.ml index 26d66e456a97..f3eefe382fa5 100644 --- a/src/lib_requester/requester.ml +++ b/src/lib_requester/requester.ml @@ -437,10 +437,8 @@ end = struct P2p_peer.Map.empty in P2p_peer.Map.iter (Request.send state.param) requests ; - P2p_peer.Map.fold - (fun peer request acc -> - acc - >>= fun () -> + P2p_peer.Map.iter_s + (fun peer request -> Lwt_list.iter_s (fun key -> lwt_debug @@ -451,7 +449,6 @@ end = struct -% a P2p_peer.Id.Logging.tag peer)) request) requests - Lwt.return_unit >>= fun () -> loop state in loop state -- GitLab From bb3ca9c26c559c9fef2808062d80329f2a9db2d8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Mon, 31 Aug 2020 12:10:49 +0200 Subject: [PATCH 7/9] Storage: prefer Lwtreslib's standardised traversors --- src/lib_storage/store_helpers.ml | 30 ++++++------------------------ 1 file changed, 6 insertions(+), 24 deletions(-) diff --git a/src/lib_storage/store_helpers.ml b/src/lib_storage/store_helpers.ml index e8d6da36b0fa..4a025b3380cc 100644 --- a/src/lib_storage/store_helpers.ml +++ b/src/lib_storage/store_helpers.ml @@ -260,9 +260,8 @@ module Make_indexed_substore (S : STORE) (I : INDEX) = struct let store_all s new_set = read_all s >>= fun old_set -> - Lwt_list.iter_p (remove s) Set.(elements (diff old_set new_set)) - >>= fun () -> - Lwt_list.iter_p (store s) Set.(elements (diff new_set old_set)) + Set.iter_p (remove s) (Set.diff old_set new_set) + >>= fun () -> Set.iter_p (store s) (Set.diff new_set old_set) end module Make_map (N : NAME) (V : VALUE) = struct @@ -317,15 +316,7 @@ module Make_indexed_substore (S : STORE) (I : INDEX) = struct let read_all s = fold s ~init:Map.empty ~f:(fun i v set -> Lwt.return (Map.add i v set)) - let store_all s map = - remove_all s - >>= fun () -> - Map.fold - (fun k v acc -> - let res = store s k v in - acc >>= fun () -> res) - map - Lwt.return_unit + let store_all s map = remove_all s >>= fun () -> Map.iter_p (store s) map end end @@ -386,9 +377,8 @@ struct let store_all s new_set = read_all s >>= fun old_set -> - Lwt_list.iter_p (remove s) Set.(elements (diff old_set new_set)) - >>= fun () -> - Lwt_list.iter_p (store s) Set.(elements (diff new_set old_set)) + Set.iter_p (remove s) (Set.diff old_set new_set) + >>= fun () -> Set.iter_p (store s) (Set.diff new_set old_set) end module Make_map (S : STORE) (I : INDEX) (V : VALUE) = struct @@ -480,15 +470,7 @@ struct let read_all s = fold s ~init:Map.empty ~f:(fun i v set -> Lwt.return (Map.add i v set)) - let store_all s map = - remove_all s - >>= fun () -> - Map.fold - (fun k v acc -> - let res = store s k v in - acc >>= fun () -> res) - map - Lwt.return_unit + let store_all s map = remove_all s >>= fun () -> Map.iter_p (store s) map end module Integer_index = struct -- GitLab From af119d10327fd0b2573e994d1177a55d1359fd5f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Tue, 8 Sep 2020 08:43:03 +0200 Subject: [PATCH 8/9] Event logging: prefer Lwtreslib's standardised traversors --- src/lib_event_logging/internal_event.ml | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/src/lib_event_logging/internal_event.ml b/src/lib_event_logging/internal_event.ml index 384a420e69ac..5da1ae9631ab 100644 --- a/src/lib_event_logging/internal_event.ml +++ b/src/lib_event_logging/internal_event.ml @@ -285,10 +285,8 @@ module All_sinks = struct let module S = (val definition : SINK with type t = a) in S.handle ?section sink def v in - List.fold_left - (fun prev -> function Active {sink; definition; _} -> - prev >>=? fun () -> handle sink definition) - return_unit + iter_s + (function Active {sink; definition; _} -> handle sink definition) !active let pp_state fmt () = -- GitLab From af56c09ab2ed0793facdd890c9199ec8c59cc7bc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Tue, 8 Sep 2020 09:16:25 +0200 Subject: [PATCH 9/9] Stdlib_unix: prefer Lwtreslib's standardised traversors --- src/lib_stdlib_unix/internal_event_unix.ml | 14 +++----------- 1 file changed, 3 insertions(+), 11 deletions(-) diff --git a/src/lib_stdlib_unix/internal_event_unix.ml b/src/lib_stdlib_unix/internal_event_unix.ml index 07684ede2f84..0d7d1308c4a3 100644 --- a/src/lib_stdlib_unix/internal_event_unix.ml +++ b/src/lib_stdlib_unix/internal_event_unix.ml @@ -48,12 +48,7 @@ module Configuration = struct >>=? fun json -> protect (fun () -> return (Data_encoding.Json.destruct encoding json)) - let apply {activate} = - List.fold_left - (fun prev uri -> - prev >>=? fun () -> Internal_event.All_sinks.activate uri) - return_unit - activate + let apply {activate} = iter_s Internal_event.All_sinks.activate activate end let env_var_name = "TEZOS_EVENTS_CONFIG" @@ -80,17 +75,14 @@ let init ?lwt_log_sink ?(configuration = Configuration.default) () = |> List.filter (( <> ) "") |> List.map Uri.of_string in - List.fold_left - (fun prev uri -> - prev - >>=? fun () -> + iter_s + (fun uri -> match Uri.scheme uri with | None -> Configuration.of_file (Uri.path uri) >>=? fun cfg -> Configuration.apply cfg | Some _ -> Internal_event.All_sinks.activate uri) - return_unit uris >>=? fun () -> Internal_event.Debug_event.( -- GitLab