From 82857dcb94137b143bd74de7f73a33a2aef6850c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gr=C3=A9goire=20Henry?= Date: Mon, 27 Nov 2017 06:13:12 +0100 Subject: [PATCH] Jbuilder: split `lib_node_net` - `lib_node_p2p_base`: Base datatypes for the P2P layers - `lib_node_services`: RPC service definitions (depends on `node_p2p_base`) - `lib_node_http`: RPC http server - `lib_node_p2p`: the P2P workers --- bin_node/jbuild | 8 +- lib_base/jbuild | 3 +- lib_base/preapply_result.ml | 76 ++ lib_base/preapply_result.mli | 30 + lib_base/test_network_status.ml | 74 ++ lib_base/test_network_status.mli | 25 + lib_base/tzPervasives.ml | 3 + lib_base/tzPervasives.mli | 2 + .../client_debug.ml | 2 +- .../client_debug.mli | 0 lib_client_base/client_network.ml | 24 +- lib_client_base/client_node_rpcs.ml | 4 +- lib_client_base/client_node_rpcs.mli | 18 +- lib_client_base/jbuild | 10 +- .../client_baking_forge.ml | 4 +- lib_embedded_client_alpha/jbuild | 4 +- lib_embedded_client_genesis/jbuild | 4 +- {lib_node_net => lib_node_http}/RPC_server.ml | 21 + .../RPC_server.mli | 44 +- lib_node_http/jbuild | 18 + .../tezos-node-http.opam | 0 lib_node_net/p2p_types.ml | 384 ---------- {lib_node_net => lib_node_p2p}/jbuild | 10 +- .../moving_average.ml | 0 .../moving_average.mli | 0 {lib_node_net => lib_node_p2p}/p2p.ml | 170 +---- {lib_node_net => lib_node_p2p}/p2p.mli | 89 +-- .../p2p_connection.ml | 0 .../p2p_connection.mli | 0 .../p2p_connection_pool.ml | 155 +--- .../p2p_connection_pool.mli | 61 +- .../p2p_discovery.ml | 0 .../p2p_discovery.mli | 0 .../p2p_io_scheduler.ml | 0 .../p2p_io_scheduler.mli | 0 .../p2p_maintenance.ml | 0 .../p2p_maintenance.mli | 0 {lib_node_net => lib_node_p2p}/p2p_welcome.ml | 0 .../p2p_welcome.mli | 0 lib_node_p2p/tezos-node-p2p.opam | 21 + lib_node_p2p_base/jbuild | 12 + .../p2p_connection_pool_types.ml | 50 +- .../p2p_connection_pool_types.mli | 0 lib_node_p2p_base/p2p_types.ml | 717 ++++++++++++++++++ .../p2p_types.mli | 135 +++- lib_node_p2p_base/tezos-node-p2p-base.opam | 21 + {lib_node_net => lib_node_services}/RPC.ml | 20 +- {lib_node_net => lib_node_services}/RPC.mli | 37 +- lib_node_services/jbuild | 17 + .../node_rpc_services.ml | 47 +- .../node_rpc_services.mli | 50 +- lib_node_services/tezos-node-services.opam | 21 + lib_node_shell/jbuild | 9 +- lib_node_shell/node.ml | 36 +- lib_node_shell/node.mli | 77 +- lib_node_shell/node_rpc.ml | 176 ++--- lib_node_shell/node_rpc.mli | 2 +- lib_node_shell/prevalidation.ml | 77 +- lib_node_shell/prevalidation.mli | 21 +- lib_node_shell/prevalidator.ml | 15 +- lib_node_shell/prevalidator.mli | 2 +- lib_node_shell/state.mli | 2 +- lib_node_updater/jbuild | 8 +- .../tezos_protocol_environment.ml | 5 +- lib_node_updater/updater.ml | 4 +- lib_node_updater/updater.mli | 4 +- lib_storage/context.ml | 70 +- lib_storage/context.mli | 20 +- test/p2p/jbuild | 7 +- 69 files changed, 1603 insertions(+), 1323 deletions(-) create mode 100644 lib_base/preapply_result.ml create mode 100644 lib_base/preapply_result.mli create mode 100644 lib_base/test_network_status.ml create mode 100644 lib_base/test_network_status.mli rename {src/client => lib_client_base}/client_debug.ml (99%) rename {src/client => lib_client_base}/client_debug.mli (100%) rename {lib_node_net => lib_node_http}/RPC_server.ml (68%) rename {lib_node_net => lib_node_http}/RPC_server.mli (52%) create mode 100644 lib_node_http/jbuild rename lib_node_net/tezos-node-net.opam => lib_node_http/tezos-node-http.opam (100%) delete mode 100644 lib_node_net/p2p_types.ml rename {lib_node_net => lib_node_p2p}/jbuild (59%) rename {lib_node_net => lib_node_p2p}/moving_average.ml (100%) rename {lib_node_net => lib_node_p2p}/moving_average.mli (100%) rename {lib_node_net => lib_node_p2p}/p2p.ml (76%) rename {lib_node_net => lib_node_p2p}/p2p.mli (77%) rename {lib_node_net => lib_node_p2p}/p2p_connection.ml (100%) rename {lib_node_net => lib_node_p2p}/p2p_connection.mli (100%) rename {lib_node_net => lib_node_p2p}/p2p_connection_pool.ml (84%) rename {lib_node_net => lib_node_p2p}/p2p_connection_pool.mli (85%) rename {lib_node_net => lib_node_p2p}/p2p_discovery.ml (100%) rename {lib_node_net => lib_node_p2p}/p2p_discovery.mli (100%) rename {lib_node_net => lib_node_p2p}/p2p_io_scheduler.ml (100%) rename {lib_node_net => lib_node_p2p}/p2p_io_scheduler.mli (100%) rename {lib_node_net => lib_node_p2p}/p2p_maintenance.ml (100%) rename {lib_node_net => lib_node_p2p}/p2p_maintenance.mli (100%) rename {lib_node_net => lib_node_p2p}/p2p_welcome.ml (100%) rename {lib_node_net => lib_node_p2p}/p2p_welcome.mli (100%) create mode 100644 lib_node_p2p/tezos-node-p2p.opam create mode 100644 lib_node_p2p_base/jbuild rename {lib_node_net => lib_node_p2p_base}/p2p_connection_pool_types.ml (93%) rename {lib_node_net => lib_node_p2p_base}/p2p_connection_pool_types.mli (100%) create mode 100644 lib_node_p2p_base/p2p_types.ml rename {lib_node_net => lib_node_p2p_base}/p2p_types.mli (50%) create mode 100644 lib_node_p2p_base/tezos-node-p2p-base.opam rename {lib_node_net => lib_node_services}/RPC.ml (88%) rename {lib_node_net => lib_node_services}/RPC.mli (56%) create mode 100644 lib_node_services/jbuild rename {lib_node_shell => lib_node_services}/node_rpc_services.ml (94%) rename {lib_node_shell => lib_node_services}/node_rpc_services.mli (77%) create mode 100644 lib_node_services/tezos-node-services.opam diff --git a/bin_node/jbuild b/bin_node/jbuild index 8fdbd58a4..fda2095ab 100644 --- a/bin_node/jbuild +++ b/bin_node/jbuild @@ -5,7 +5,9 @@ (public_name tezos-node) (libraries (tezos-base tezos-node-updater - tezos-node-net + tezos-node-p2p-base + tezos-node-p2p + tezos-node-http tezos-node-shell tezos-embedded-protocol-genesis tezos-embedded-protocol-demo @@ -15,7 +17,9 @@ -safe-string -open Tezos_base__TzPervasives -open Tezos_node_updater - -open Tezos_node_net + -open Tezos_node_p2p_base + -open Tezos_node_p2p + -open Tezos_node_http -open Tezos_node_shell -linkall)))) diff --git a/lib_base/jbuild b/lib_base/jbuild index f16802c6e..68ab59e9b 100644 --- a/lib_base/jbuild +++ b/lib_base/jbuild @@ -13,8 +13,9 @@ tezos-crypto tezos-data-encoding tezos-error-monad + calendar ezjsonm - calendar)))) + mtime.clock.os)))) (alias ((name runtest_indent) diff --git a/lib_base/preapply_result.ml b/lib_base/preapply_result.ml new file mode 100644 index 000000000..2a506ee33 --- /dev/null +++ b/lib_base/preapply_result.ml @@ -0,0 +1,76 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type 'error t = { + applied: (Operation_hash.t * Operation.t) list; + refused: (Operation.t * 'error list) Operation_hash.Map.t; + branch_refused: (Operation.t * 'error list) Operation_hash.Map.t; + branch_delayed: (Operation.t * 'error list) Operation_hash.Map.t; +} + +let empty = { + applied = [] ; + refused = Operation_hash.Map.empty ; + branch_refused = Operation_hash.Map.empty ; + branch_delayed = Operation_hash.Map.empty ; +} + +let map f r = { + applied = r.applied; + refused = Operation_hash.Map.map f r.refused ; + branch_refused = Operation_hash.Map.map f r.branch_refused ; + branch_delayed = Operation_hash.Map.map f r.branch_delayed ; +} + +let encoding error_encoding = + let open Data_encoding in + let operation_encoding = + merge_objs + (obj1 (req "hash" Operation_hash.encoding)) + (dynamic_size Operation.encoding) in + let refused_encoding = + merge_objs + (obj1 (req "hash" Operation_hash.encoding)) + (merge_objs + (dynamic_size Operation.encoding) + (obj1 (req "error" error_encoding))) in + let build_list map = Operation_hash.Map.bindings map in + let build_map list = + List.fold_right + (fun (k, e) m -> Operation_hash.Map.add k e m) + list Operation_hash.Map.empty in + conv + (fun { applied ; refused ; branch_refused ; branch_delayed } -> + (applied, build_list refused, + build_list branch_refused, build_list branch_delayed)) + (fun (applied, refused, branch_refused, branch_delayed) -> + let refused = build_map refused in + let branch_refused = build_map branch_refused in + let branch_delayed = build_map branch_delayed in + { applied ; refused ; branch_refused ; branch_delayed }) + (obj4 + (req "applied" (list operation_encoding)) + (req "refused" (list refused_encoding)) + (req "branch_refused" (list refused_encoding)) + (req "branch_delayed" (list refused_encoding))) + +let operations t = + let ops = + List.fold_left + (fun acc (h, op) -> Operation_hash.Map.add h op acc) + Operation_hash.Map.empty t.applied in + let ops = + Operation_hash.Map.fold + (fun h (op, _err) acc -> Operation_hash.Map.add h op acc) + t.branch_delayed ops in + let ops = + Operation_hash.Map.fold + (fun h (op, _err) acc -> Operation_hash.Map.add h op acc) + t.branch_refused ops in + ops diff --git a/lib_base/preapply_result.mli b/lib_base/preapply_result.mli new file mode 100644 index 000000000..4a87cc81c --- /dev/null +++ b/lib_base/preapply_result.mli @@ -0,0 +1,30 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type 'error t = { + applied: (Operation_hash.t * Operation.t) list; + refused: (Operation.t * 'error list) Operation_hash.Map.t; + (* e.g. invalid signature *) + branch_refused: (Operation.t * 'error list) Operation_hash.Map.t; + (* e.g. insufficent balance *) + branch_delayed: (Operation.t * 'error list) Operation_hash.Map.t; + (* e.g. timestamp in the future *) +} + +val empty : 'error t + +val map : + (Operation.t * 'a list -> Operation.t * 'b list) -> 'a t -> 'b t + +val operations : + 'error t -> Operation.t Operation_hash.Map.t + +val encoding : + 'error list Data_encoding.t -> + 'error t Data_encoding.t diff --git a/lib_base/test_network_status.ml b/lib_base/test_network_status.ml new file mode 100644 index 000000000..585146f9b --- /dev/null +++ b/lib_base/test_network_status.ml @@ -0,0 +1,74 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type t = + | Not_running + | Forking of { + protocol: Protocol_hash.t ; + expiration: Time.t ; + } + | Running of { + net_id: Net_id.t ; + genesis: Block_hash.t ; + protocol: Protocol_hash.t ; + expiration: Time.t ; + } + +let encoding = + let open Data_encoding in + union [ + case ~tag:0 + (obj1 (req "status" (constant "not_running"))) + (function Not_running -> Some () | _ -> None) + (fun () -> Not_running) ; + case ~tag:1 + (obj3 + (req "status" (constant "forking")) + (req "protocol" Protocol_hash.encoding) + (req "expiration" Time.encoding)) + (function + | Forking { protocol ; expiration } -> + Some ((), protocol, expiration) + | _ -> None) + (fun ((), protocol, expiration) -> + Forking { protocol ; expiration }) ; + case ~tag:2 + (obj5 + (req "status" (constant "running")) + (req "net_id" Net_id.encoding) + (req "genesis" Block_hash.encoding) + (req "protocol" Protocol_hash.encoding) + (req "expiration" Time.encoding)) + (function + | Running { net_id ; genesis ; protocol ; expiration } -> + Some ((), net_id, genesis, protocol, expiration) + | _ -> None) + (fun ((), net_id, genesis, protocol, expiration) -> + Running { net_id ; genesis ; protocol ; expiration }) ; + ] + +let pp ppf = function + | Not_running -> Format.fprintf ppf "@[Not running@]" + | Forking { protocol ; expiration } -> + Format.fprintf ppf + "@[Forking %a (expires %a)@]" + Protocol_hash.pp + protocol + Time.pp_hum + expiration + | Running { net_id ; genesis ; protocol ; expiration } -> + Format.fprintf ppf + "@[Running %a\ + @ Genesis: %a\ + @ Net id: %a\ + @ Expiration: %a@]" + Protocol_hash.pp protocol + Block_hash.pp genesis + Net_id.pp net_id + Time.pp_hum expiration diff --git a/lib_base/test_network_status.mli b/lib_base/test_network_status.mli new file mode 100644 index 000000000..61e4a984b --- /dev/null +++ b/lib_base/test_network_status.mli @@ -0,0 +1,25 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type t = + | Not_running + | Forking of { + protocol: Protocol_hash.t ; + expiration: Time.t ; + } + | Running of { + net_id: Net_id.t ; + genesis: Block_hash.t ; + protocol: Protocol_hash.t ; + expiration: Time.t ; + } + +val encoding: t Data_encoding.t + +val pp : Format.formatter -> t -> unit diff --git a/lib_base/tzPervasives.ml b/lib_base/tzPervasives.ml index 461f7c378..d7373e375 100644 --- a/lib_base/tzPervasives.ml +++ b/lib_base/tzPervasives.ml @@ -29,5 +29,8 @@ module Block_header = Block_header module Operation = Operation module Protocol = Protocol +module Test_network_status = Test_network_status +module Preapply_result = Preapply_result + include Utils.Infix include Error_monad diff --git a/lib_base/tzPervasives.mli b/lib_base/tzPervasives.mli index 4e26a615d..294f4f278 100644 --- a/lib_base/tzPervasives.mli +++ b/lib_base/tzPervasives.mli @@ -28,6 +28,8 @@ module Fitness = Fitness module Block_header = Block_header module Operation = Operation module Protocol = Protocol +module Test_network_status = Test_network_status +module Preapply_result = Preapply_result include (module type of (struct include Utils.Infix end)) include (module type of (struct include Error_monad end)) diff --git a/src/client/client_debug.ml b/lib_client_base/client_debug.ml similarity index 99% rename from src/client/client_debug.ml rename to lib_client_base/client_debug.ml index ec7f88447..a6a1e9845 100644 --- a/src/client/client_debug.ml +++ b/lib_client_base/client_debug.ml @@ -28,7 +28,7 @@ let pp_block ppf @ Operations: @[%a@]\ @ Data (hex encoded): \"%s\"@]" Block_hash.pp hash - Context.pp_test_network test_network + Test_network_status.pp test_network level proto_level Block_hash.pp predecessor diff --git a/src/client/client_debug.mli b/lib_client_base/client_debug.mli similarity index 100% rename from src/client/client_debug.mli rename to lib_client_base/client_debug.mli diff --git a/lib_client_base/client_network.ml b/lib_client_base/client_network.ml index c489f6630..a11e9afb3 100644 --- a/lib_client_base/client_network.ml +++ b/lib_client_base/client_network.ml @@ -8,6 +8,7 @@ (**************************************************************************) open Client_commands +open P2p_types let group = { Cli_entries.name = "network" ; @@ -23,32 +24,31 @@ let commands () = [ Client_node_rpcs.Network.peers cctxt.rpc_config >>=? fun peers -> Client_node_rpcs.Network.points cctxt.rpc_config >>=? fun points -> cctxt.message "GLOBAL STATS" >>= fun () -> - cctxt.message " %a" P2p_types.Stat.pp stat >>= fun () -> + cctxt.message " %a" Stat.pp stat >>= fun () -> cctxt.message "CONNECTIONS" >>= fun () -> let incoming, outgoing = - List.partition (fun c -> c.P2p_types.Connection_info.incoming) conns in + List.partition (fun c -> c.Connection_info.incoming) conns in Lwt_list.iter_s begin fun conn -> - cctxt.message " %a" P2p_types.Connection_info.pp conn + cctxt.message " %a" Connection_info.pp conn end incoming >>= fun () -> Lwt_list.iter_s begin fun conn -> - cctxt.message " %a" P2p_types.Connection_info.pp conn + cctxt.message " %a" Connection_info.pp conn end outgoing >>= fun () -> cctxt.message "KNOWN PEERS" >>= fun () -> Lwt_list.iter_s begin fun (p, pi) -> - let open P2p.RPC.Peer_id in cctxt.message " %a %.0f %a %a %s" - pp_state_digram pi.state + Peer_state.pp_digram pi.Peer_info.state pi.score - pp p P2p_types.Stat.pp pi.stat + Peer_id.pp p + Stat.pp pi.stat (if pi.trusted then "★" else " ") end peers >>= fun () -> cctxt.message "KNOWN POINTS" >>= fun () -> Lwt_list.iter_s begin fun (p, pi) -> - let open P2p.RPC in - match pi.Point.state with + match pi.Point_info.state with | Running peer_id -> cctxt.message " %a %a %a %s" - Point.pp_state_digram pi.state + Point_state.pp_digram pi.state Point.pp p Peer_id.pp peer_id (if pi.trusted then "★" else " ") @@ -56,14 +56,14 @@ let commands () = [ match pi.last_seen with | Some (peer_id, ts) -> cctxt.message " %a %a (last seen: %a %a) %s" - Point.pp_state_digram pi.state + Point_state.pp_digram pi.state Point.pp p Peer_id.pp peer_id Time.pp_hum ts (if pi.trusted then "★" else " ") | None -> cctxt.message " %a %a %s" - Point.pp_state_digram pi.state + Point_state.pp_digram pi.state Point.pp p (if pi.trusted then "★" else " ") end points >>= fun () -> diff --git a/lib_client_base/client_node_rpcs.ml b/lib_client_base/client_node_rpcs.ml index 231090ae7..ae4680b7f 100644 --- a/lib_client_base/client_node_rpcs.ml +++ b/lib_client_base/client_node_rpcs.ml @@ -71,7 +71,7 @@ module Blocks = struct data: MBytes.t ; operations: (Operation_hash.t * Operation.t) list list option ; protocol: Protocol_hash.t ; - test_network: Context.test_network; + test_network: Test_network_status.t; } type preapply_param = Services.Blocks.preapply_param = { timestamp: Time.t ; @@ -81,7 +81,7 @@ module Blocks = struct } type preapply_result = Services.Blocks.preapply_result = { shell_header: Block_header.shell_header ; - operations: error Prevalidation.preapply_result ; + operations: error Preapply_result.t ; } let net_id cctxt h = call_service1 cctxt Services.Blocks.net_id h () diff --git a/lib_client_base/client_node_rpcs.mli b/lib_client_base/client_node_rpcs.mli index aad47042b..c0054f492 100644 --- a/lib_client_base/client_node_rpcs.mli +++ b/lib_client_base/client_node_rpcs.mli @@ -74,12 +74,12 @@ module Blocks : sig block -> Protocol_hash.t tzresult Lwt.t val test_network: config -> - block -> Context.test_network tzresult Lwt.t + block -> Test_network_status.t tzresult Lwt.t val pending_operations: config -> block -> - (error Prevalidation.preapply_result * Operation.t Operation_hash.Map.t) tzresult Lwt.t + (error Preapply_result.t * Operation.t Operation_hash.Map.t) tzresult Lwt.t type block_info = { hash: Block_hash.t ; @@ -94,7 +94,7 @@ module Blocks : sig data: MBytes.t ; operations: (Operation_hash.t * Operation.t) list list option ; protocol: Protocol_hash.t ; - test_network: Context.test_network; + test_network: Test_network_status.t ; } val info: @@ -115,7 +115,7 @@ module Blocks : sig type preapply_result = { shell_header: Block_header.shell_header ; - operations: error Prevalidation.preapply_result ; + operations: error Preapply_result.t ; } val preapply: @@ -156,17 +156,19 @@ val bootstrapped: module Network : sig + open P2p_types + val stat: - config -> P2p_types.Stat.t tzresult Lwt.t + config -> Stat.t tzresult Lwt.t val connections: - config -> P2p_types.Connection_info.t list tzresult Lwt.t + config -> Connection_info.t list tzresult Lwt.t val peers: - config -> (P2p.Peer_id.t * P2p.RPC.Peer_id.info) list tzresult Lwt.t + config -> (Peer_id.t * P2p_types.Peer_info.t) list tzresult Lwt.t val points: - config -> (P2p.Point.t * P2p.RPC.Point.info) list tzresult Lwt.t + config -> (Point.t * P2p_types.Point_info.t) list tzresult Lwt.t end diff --git a/lib_client_base/jbuild b/lib_client_base/jbuild index ef7b8639c..ac1eb7a60 100644 --- a/lib_client_base/jbuild +++ b/lib_client_base/jbuild @@ -5,17 +5,17 @@ (public_name tezos-client-base) (libraries (tezos-base tezos-storage - tezos-node-shell - tezos-node-net + tezos-node-p2p-base + tezos-node-services tezos-node-updater tezos-protocol-compiler)) (flags (:standard -w -9+27-30-32-40@8 -safe-string -open Tezos_base__TzPervasives -open Tezos_storage - -open Tezos_node_net - -open Tezos_node_updater - -open Tezos_node_shell)))) + -open Tezos_node_p2p_base + -open Tezos_node_services + -open Tezos_node_updater)))) (alias ((name runtest_indent) diff --git a/lib_embedded_client_alpha/client_baking_forge.ml b/lib_embedded_client_alpha/client_baking_forge.ml index 1c88ae192..1d89dba3e 100644 --- a/lib_embedded_client_alpha/client_baking_forge.ml +++ b/lib_embedded_client_alpha/client_baking_forge.ml @@ -110,7 +110,7 @@ let forge_block cctxt block Operation_hash.Map.bindings @@ Operation_hash.Map.fold Operation_hash.Map.add - (Prevalidation.preapply_result_operations ops) + (Preapply_result.operations ops) pendings in return ops | Some operations -> return operations @@ -465,7 +465,7 @@ let bake cctxt state = List.map snd @@ Operation_hash.Map.bindings @@ Operation_hash.Map.(fold add) - ops (Prevalidation.preapply_result_operations res) in + ops (Preapply_result.operations res) in let request = List.length operations in let proto_header = forge_faked_proto_header ~priority ~seed_nonce_hash in diff --git a/lib_embedded_client_alpha/jbuild b/lib_embedded_client_alpha/jbuild index 193866132..4826707a8 100644 --- a/lib_embedded_client_alpha/jbuild +++ b/lib_embedded_client_alpha/jbuild @@ -6,7 +6,7 @@ (libraries (tezos-base tezos-embedded-protocol-alpha tezos-embedded-protocol-alpha.raw - tezos-node-shell + tezos-node-services tezos-client-base)) (library_flags (:standard -linkall)) (flags (:standard -w -9+27-30-32-40@8 @@ -14,7 +14,7 @@ -open Tezos_base__TzPervasives -open Tezos_embedded_protocol_environment_alpha -open Tezos_embedded_raw_protocol_alpha - -open Tezos_node_shell + -open Tezos_node_services -open Tezos_client_base -open Tezos_context)))) diff --git a/lib_embedded_client_genesis/jbuild b/lib_embedded_client_genesis/jbuild index b19a9b8c8..17d1d5450 100644 --- a/lib_embedded_client_genesis/jbuild +++ b/lib_embedded_client_genesis/jbuild @@ -8,7 +8,7 @@ tezos-embedded-protocol-genesis.raw tezos-embedded-protocol-alpha.environment tezos-embedded-protocol-alpha.raw - tezos-node-shell + tezos-node-services tezos-client-base)) (library_flags (:standard -linkall)) (flags (:standard -w -9+27-30-32-40@8 @@ -16,7 +16,7 @@ -open Tezos_base__TzPervasives -open Tezos_embedded_protocol_environment_genesis -open Tezos_embedded_raw_protocol_genesis - -open Tezos_node_shell + -open Tezos_node_services -open Tezos_client_base)))) (alias diff --git a/lib_node_net/RPC_server.ml b/lib_node_http/RPC_server.ml similarity index 68% rename from lib_node_net/RPC_server.ml rename to lib_node_http/RPC_server.ml index ccc2cee3d..5e0669b76 100644 --- a/lib_node_net/RPC_server.ml +++ b/lib_node_http/RPC_server.ml @@ -12,6 +12,9 @@ type cors = RestoCohttp.cors = { allowed_origins : string list ; } +include RestoDirectory +module Directory = RestoDirectory.MakeDirectory(RPC.Data) + include RestoCohttp.Make(RPC.Data)(Logging.RPC) let json = { @@ -44,3 +47,21 @@ let octet_stream = { | Some data -> Ok data end ; } + +(* Compatibility layer, to be removed ASAP. *) + +type 'a directory = 'a Directory.t + +let empty = Directory.empty +let register d s f = Directory.register d s (fun p () i -> f p i) + +open Directory.Curry +let register0 root s f = register root s (curry Z f) +let register1 root s f = register root s (curry (S Z) f) +let register2 root s f = register root s (curry (S (S Z)) f) +(* let register3 root s f = register root s (curry (S (S (S Z))) f) *) +(* let register4 root s f = register root s (curry (S (S (S (S Z)))) f) *) +(* let register5 root s f = register root s (curry (S (S (S (S (S Z))))) f) *) + +let register_dynamic_directory1 = + Directory.register_dynamic_directory1 diff --git a/lib_node_net/RPC_server.mli b/lib_node_http/RPC_server.mli similarity index 52% rename from lib_node_net/RPC_server.mli rename to lib_node_http/RPC_server.mli index 2df77d472..538c3c14e 100644 --- a/lib_node_net/RPC_server.mli +++ b/lib_node_http/RPC_server.mli @@ -7,6 +7,11 @@ (* *) (**************************************************************************) + +module Directory : + (module type of struct include RestoDirectory.MakeDirectory(RPC.Data) end) +include (module type of struct include RestoDirectory end) + (** Typed RPC services: server implementation. *) type cors = { @@ -32,8 +37,45 @@ val launch : ?cors:cors -> media_types:media_type list -> Conduit_lwt_unix.server -> - unit RPC.Directory.t -> + unit Directory.t -> server Lwt.t (** Kill an RPC server. *) val shutdown : server -> unit Lwt.t + + +(** Compatibility layer, to be removed ASAP. *) + +type 'a directory = 'a Directory.t +val empty: 'a directory +val register: + 'prefix directory -> + ('prefix, 'params, 'input, 'output) RPC.service -> + ('params -> 'input -> [< ('output, unit) RestoDirectory.Answer.t ] Lwt.t) -> + 'prefix directory + +val register0: + unit directory -> + (unit, unit, 'i, 'o) RPC.service -> + ('i -> [< ('o, unit) Answer.t ] Lwt.t) -> + unit directory + +val register1: + 'prefix directory -> + ('prefix, unit * 'a, 'i, 'o) RPC.service -> + ('a -> 'i -> [< ('o, unit) Answer.t ] Lwt.t) -> + 'prefix directory + +val register2: + 'prefix directory -> + ('prefix, (unit * 'a) * 'b, 'i, 'o) RPC.service -> + ('a -> 'b -> 'i -> [< ('o, unit) Answer.t ] Lwt.t) -> + 'prefix directory + +val register_dynamic_directory1: + ?descr:string -> + 'prefix directory -> + ('prefix, unit * 'a) RPC.Path.path -> + ('a -> (unit * 'a) directory Lwt.t) -> + 'prefix directory + diff --git a/lib_node_http/jbuild b/lib_node_http/jbuild new file mode 100644 index 000000000..3f32bbe10 --- /dev/null +++ b/lib_node_http/jbuild @@ -0,0 +1,18 @@ +(jbuild_version 1) + +(library + ((name tezos_node_http) + (public_name tezos-node-http) + (libraries (tezos-base + tezos-node-services + ocplib-resto-directory + ocplib-resto-cohttp)) + (flags (:standard -w -9+27-30-32-40@8 + -safe-string + -open Tezos_base__TzPervasives + -open Tezos_node_services)))) + +(alias + ((name runtest_indent) + (deps ((glob_files *.ml) (glob_files *.mli))) + (action (run bash ${libexec:tezos-stdlib:test-ocp-indent.sh} ${<})))) diff --git a/lib_node_net/tezos-node-net.opam b/lib_node_http/tezos-node-http.opam similarity index 100% rename from lib_node_net/tezos-node-net.opam rename to lib_node_http/tezos-node-http.opam diff --git a/lib_node_net/p2p_types.ml b/lib_node_net/p2p_types.ml deleted file mode 100644 index d658ac94c..000000000 --- a/lib_node_net/p2p_types.ml +++ /dev/null @@ -1,384 +0,0 @@ -(**************************************************************************) -(* *) -(* Copyright (c) 2014 - 2017. *) -(* Dynamic Ledger Solutions, Inc. *) -(* *) -(* All rights reserved. No warranty, explicit or implicit, provided. *) -(* *) -(**************************************************************************) - -module Version = struct - type t = { - name : string ; - major : int ; - minor : int ; - } - - let pp ppf { name ; major ; minor } = - Format.fprintf ppf "%s.%d.%d" name major minor - - let encoding = - let open Data_encoding in - conv - (fun { name; major; minor } -> (name, major, minor)) - (fun (name, major, minor) -> { name; major; minor }) - (obj3 - (req "name" string) - (req "major" int8) - (req "minor" int8)) - - (* the common version for a pair of peers, if any, is the maximum one, - in lexicographic order *) - let common la lb = - let la = List.sort (fun l r -> compare r l) la in - let lb = List.sort (fun l r -> compare r l) lb in - let rec find = function - | [], _ | _, [] -> None - | ((a :: ta) as la), ((b :: tb) as lb) -> - if a = b then Some a - else if a < b then find (ta, lb) - else find (la, tb) - in find (la, lb) -end - -module Stat = struct - - type t = { - total_sent : int64 ; - total_recv : int64 ; - current_inflow : int ; - current_outflow : int ; - } - - let empty = { - total_sent = 0L ; - total_recv = 0L ; - current_inflow = 0 ; - current_outflow = 0 ; - } - - let print_size ppf sz = - let ratio n = (float_of_int sz /. float_of_int (1 lsl n)) in - if sz < 1 lsl 10 then - Format.fprintf ppf "%d B" sz - else if sz < 1 lsl 20 then - Format.fprintf ppf "%.2f kiB" (ratio 10) - else - Format.fprintf ppf "%.2f MiB" (ratio 20) - - let print_size64 ppf sz = - let open Int64 in - let ratio n = (to_float sz /. float_of_int (1 lsl n)) in - if sz < shift_left 1L 10 then - Format.fprintf ppf "%Ld B" sz - else if sz < shift_left 1L 20 then - Format.fprintf ppf "%.2f kiB" (ratio 10) - else if sz < shift_left 1L 30 then - Format.fprintf ppf "%.2f MiB" (ratio 20) - else if sz < shift_left 1L 40 then - Format.fprintf ppf "%.2f GiB" (ratio 30) - else - Format.fprintf ppf "%.2f TiB" (ratio 40) - - let pp ppf stat = - Format.fprintf ppf - "↗ %a (%a/s) ↘ %a (%a/s)" - print_size64 stat.total_sent print_size stat.current_outflow - print_size64 stat.total_recv print_size stat.current_inflow - - let encoding = - let open Data_encoding in - conv - (fun { total_sent ; total_recv ; current_inflow ; current_outflow } -> - (total_sent, total_recv, current_inflow, current_outflow)) - (fun (total_sent, total_recv, current_inflow, current_outflow) -> - { total_sent ; total_recv ; current_inflow ; current_outflow }) - (obj4 - (req "total_sent" int64) - (req "total_recv" int64) - (req "current_inflow" int31) - (req "current_outflow" int31)) -end - -module Peer_id = Crypto_box.Public_key_hash - -(* public types *) -type addr = Ipaddr.V6.t - -let addr_encoding = - let open Data_encoding in - splitted - ~json:begin - conv - Ipaddr.V6.to_string - Ipaddr.V6.of_string_exn - string - end - ~binary:begin - conv - Ipaddr.V6.to_bytes - Ipaddr.V6.of_bytes_exn - string - end - -type port = int - -module Point = struct - - module T = struct - - (* A net point (address x port). *) - type t = addr * port - let compare (a1, p1) (a2, p2) = - match Ipaddr.V6.compare a1 a2 with - | 0 -> p1 - p2 - | x -> x - let equal p1 p2 = compare p1 p2 = 0 - let hash = Hashtbl.hash - let pp ppf (addr, port) = - match Ipaddr.v4_of_v6 addr with - | Some addr -> - Format.fprintf ppf "%a:%d" Ipaddr.V4.pp_hum addr port - | None -> - Format.fprintf ppf "[%a]:%d" Ipaddr.V6.pp_hum addr port - let pp_opt ppf = function - | None -> Format.pp_print_string ppf "none" - | Some point -> pp ppf point - - let is_local (addr, _) = Ipaddr.V6.is_private addr - let is_global (addr, _) = not @@ Ipaddr.V6.is_private addr - - let check_port port = - if String.mem_char port '[' || - String.mem_char port ']' || - String.mem_char port ':' then - invalid_arg "Utils.parse_addr_port (invalid character in port)" - - let parse_addr_port s = - let len = String.length s in - if len = 0 then - ("", "") - else if s.[0] = '[' then begin (* inline IPv6 *) - match String.rindex s ']' with - | exception Not_found -> - invalid_arg "Utils.parse_addr_port (missing ']')" - | pos -> - let addr = String.sub s 1 (pos - 1) in - let port = - if pos = len - 1 then - "" - else if s.[pos+1] <> ':' then - invalid_arg "Utils.parse_addr_port (unexpected char after ']')" - else - String.sub s (pos + 2) (len - pos - 2) in - check_port port ; - addr, port - end else begin - match String.rindex s ']' with - | _pos -> - invalid_arg "Utils.parse_addr_port (unexpected char ']')" - | exception Not_found -> - match String.index s ':' with - | exception _ -> s, "" - | pos -> - match String.index_from s (pos+1) ':' with - | exception _ -> - let addr = String.sub s 0 pos in - let port = String.sub s (pos + 1) (len - pos - 1) in - check_port port ; - addr, port - | _pos -> - invalid_arg "Utils.parse_addr_port: IPv6 addresses must be bracketed" - end - - let of_string_exn str = - let addr, port = parse_addr_port str in - let port = int_of_string port in - if port < 0 && port > 1 lsl 16 - 1 then - invalid_arg "port must be between 0 and 65535" ; - match Ipaddr.of_string_exn addr with - | V4 addr -> Ipaddr.v6_of_v4 addr, port - | V6 addr -> addr, port - - let of_string str = - try Ok (of_string_exn str) with - | Invalid_argument s -> Error s - | Failure s -> Error s - | _ -> Error "Point.of_string" - - let to_string saddr = Format.asprintf "%a" pp saddr - - let encoding = - Data_encoding.conv to_string of_string_exn Data_encoding.string - - end - - include T - - module Map = Map.Make (T) - module Set = Set.Make (T) - module Table = Hashtbl.Make (T) - -end - -module Id_point = struct - - module T = struct - - (* A net point (address x port). *) - type t = addr * port option - let empty = Ipaddr.V6.unspecified, None - let compare (a1, p1) (a2, p2) = - match Ipaddr.V6.compare a1 a2 with - | 0 -> Pervasives.compare p1 p2 - | x -> x - let equal p1 p2 = compare p1 p2 = 0 - let hash = Hashtbl.hash - let pp ppf (addr, port) = - match port with - | None -> - Format.fprintf ppf "[%a]:??" Ipaddr.V6.pp_hum addr - | Some port -> - Format.fprintf ppf "[%a]:%d" Ipaddr.V6.pp_hum addr port - let pp_opt ppf = function - | None -> Format.pp_print_string ppf "none" - | Some point -> pp ppf point - let to_string t = Format.asprintf "%a" pp t - - let is_local (addr, _) = Ipaddr.V6.is_private addr - let is_global (addr, _) = not @@ Ipaddr.V6.is_private addr - - let of_point (addr, port) = addr, Some port - let to_point = function - | _, None -> None - | addr, Some port -> Some (addr, port) - let to_point_exn = function - | _, None -> invalid_arg "to_point_exn" - | addr, Some port -> addr, port - - let encoding = - let open Data_encoding in - (obj2 - (req "addr" addr_encoding) - (opt "port" uint16)) - - end - - include T - - module Map = Map.Make (T) - module Set = Set.Make (T) - module Table = Hashtbl.Make (T) - -end - -module Identity = struct - - type t = { - peer_id : Peer_id.t ; - public_key : Crypto_box.public_key ; - secret_key : Crypto_box.secret_key ; - proof_of_work_stamp : Crypto_box.nonce ; - } - - let encoding = - let open Data_encoding in - conv - (fun { public_key ; secret_key ; proof_of_work_stamp } -> - (public_key, secret_key, proof_of_work_stamp)) - (fun (public_key, secret_key, proof_of_work_stamp) -> - let peer_id = Crypto_box.hash public_key in - { peer_id ; public_key ; secret_key ; proof_of_work_stamp }) - (obj3 - (req "public_key" Crypto_box.public_key_encoding) - (req "secret_key" Crypto_box.secret_key_encoding) - (req "proof_of_work_stamp" Crypto_box.nonce_encoding)) - - let generate ?max target = - let secret_key, public_key, peer_id = Crypto_box.random_keypair () in - let proof_of_work_stamp = - Crypto_box.generate_proof_of_work ?max public_key target in - { peer_id ; public_key ; secret_key ; proof_of_work_stamp } - - let animation = [| - "|.....|" ; - "|o....|" ; - "|oo...|" ; - "|ooo..|" ; - "|.ooo.|" ; - "|..ooo|" ; - "|...oo|" ; - "|....o|" ; - "|.....|" ; - "|.....|" ; - "|.....|" ; - "|.....|" ; - |] - - let init = String.make (String.length animation.(0)) '\ ' - let clean = String.make (String.length animation.(0)) '\b' - let animation = Array.map (fun x -> clean ^ x) animation - let animation_size = Array.length animation - let duration = 1200 / animation_size - - let generate_with_animation ppf target = - Format.fprintf ppf "%s%!" init ; - let count = ref 10000 in - let rec loop n = - let start = Mtime_clock.counter () in - Format.fprintf ppf "%s%!" animation.(n mod animation_size); - try generate ~max:!count target - with Not_found -> - let time = Mtime.Span.to_ms (Mtime_clock.count start) in - count := - if time <= 0. then - !count * 10 - else - !count * duration / int_of_float time ; - loop (n+1) - in - let id = loop 0 in - Format.fprintf ppf "%s%s\n%!" clean init ; - id - - let generate target = generate target - -end - -module Connection_info = struct - - type t = { - incoming : bool; - peer_id : Peer_id.t; - id_point : Id_point.t; - remote_socket_port : port; - versions : Version.t list ; - } - - let encoding = - let open Data_encoding in - conv - (fun { incoming ; peer_id ; id_point ; remote_socket_port ; versions } -> - (incoming, peer_id, id_point, remote_socket_port, versions)) - (fun (incoming, peer_id, id_point, remote_socket_port, versions) -> - { incoming ; peer_id ; id_point ; remote_socket_port ; versions }) - (obj5 - (req "incoming" bool) - (req "peer_id" Peer_id.encoding) - (req "id_point" Id_point.encoding) - (req "remote_socket_port" uint16) - (req "versions" (list Version.encoding))) - - let pp ppf - { incoming ; id_point = (remote_addr, remote_port) ; - remote_socket_port ; peer_id ; versions } = - let version = List.hd versions in - let point = match remote_port with - | None -> remote_addr, remote_socket_port - | Some port -> remote_addr, port in - Format.fprintf ppf "%s %a %a (%a)" - (if incoming then "↘" else "↗") - Peer_id.pp peer_id - Point.pp point - Version.pp version -end diff --git a/lib_node_net/jbuild b/lib_node_p2p/jbuild similarity index 59% rename from lib_node_net/jbuild rename to lib_node_p2p/jbuild index 8ff831853..285b94204 100644 --- a/lib_node_net/jbuild +++ b/lib_node_p2p/jbuild @@ -1,14 +1,14 @@ (jbuild_version 1) (library - ((name tezos_node_net) - (public_name tezos-node-net) + ((name tezos_node_p2p) + (public_name tezos-node-p2p) (libraries (tezos-base - mtime.clock.os - ocplib-resto-cohttp)) + tezos-node-p2p-base)) (flags (:standard -w -9+27-30-32-40@8 -safe-string - -open Tezos_base__TzPervasives)))) + -open Tezos_base__TzPervasives + -open Tezos_node_p2p_base)))) (alias ((name runtest_indent) diff --git a/lib_node_net/moving_average.ml b/lib_node_p2p/moving_average.ml similarity index 100% rename from lib_node_net/moving_average.ml rename to lib_node_p2p/moving_average.ml diff --git a/lib_node_net/moving_average.mli b/lib_node_p2p/moving_average.mli similarity index 100% rename from lib_node_net/moving_average.mli rename to lib_node_p2p/moving_average.mli diff --git a/lib_node_net/p2p.ml b/lib_node_p2p/p2p.ml similarity index 76% rename from lib_node_net/p2p.ml rename to lib_node_p2p/p2p.ml index 588f527f4..3b1c358b4 100644 --- a/lib_node_net/p2p.ml +++ b/lib_node_p2p/p2p.ml @@ -515,107 +515,16 @@ module RPC = struct end module Point = struct - include Point - type state = - | Requested - | Accepted of Peer_id.t - | Running of Peer_id.t - | Disconnected - - let peer_id_of_state = function - | Requested -> None - | Accepted pi -> Some pi - | Running pi -> Some pi - | Disconnected -> None - - let state_of_state_peerid state pi = match state, pi with - | Requested, _ -> Requested - | Accepted _, Some pi -> Accepted pi - | Running _, Some pi -> Running pi - | Disconnected, _ -> Disconnected - | _ -> invalid_arg "state_of_state_peerid" - - let pp_state_digram ppf = function - | Requested -> Format.fprintf ppf "⚎" - | Accepted _ -> Format.fprintf ppf "⚍" - | Running _ -> Format.fprintf ppf "⚌" - | Disconnected -> Format.fprintf ppf "⚏" - - let state_encoding = - let open Data_encoding in - let branch_encoding name obj = - conv (fun x -> (), x) (fun ((), x) -> x) - (merge_objs - (obj1 (req "event_kind" (constant name))) obj) in - union ~tag_size:`Uint8 [ - case ~tag:0 (branch_encoding "requested" empty) - (function Requested -> Some () | _ -> None) - (fun () -> Requested) ; - case ~tag:1 (branch_encoding "accepted" - (obj1 (req "peer_id" Peer_id.encoding))) - (function Accepted peer_id -> Some peer_id | _ -> None) - (fun peer_id -> Accepted peer_id) ; - case ~tag:2 (branch_encoding "running" - (obj1 (req "peer_id" Peer_id.encoding))) - (function Running peer_id -> Some peer_id | _ -> None) - (fun peer_id -> Running peer_id) ; - case ~tag:3 (branch_encoding "disconnected" empty) - (function Disconnected -> Some () | _ -> None) - (fun () -> Disconnected) ; - ] - - type info = { - trusted : bool ; - greylisted_until : Time.t ; - state : state ; - last_failed_connection : Time.t option ; - last_rejected_connection : (Peer_id.t * Time.t) option ; - last_established_connection : (Peer_id.t * Time.t) option ; - last_disconnection : (Peer_id.t * Time.t) option ; - last_seen : (Peer_id.t * Time.t) option ; - last_miss : Time.t option ; - } - - let info_encoding = - let open Data_encoding in - conv - (fun { trusted ; greylisted_until ; state ; - last_failed_connection ; last_rejected_connection ; - last_established_connection ; last_disconnection ; - last_seen ; last_miss } -> - let peer_id = peer_id_of_state state in - (trusted, greylisted_until, state, peer_id, - last_failed_connection, last_rejected_connection, - last_established_connection, last_disconnection, - last_seen, last_miss)) - (fun (trusted, greylisted_until, state, peer_id, - last_failed_connection, last_rejected_connection, - last_established_connection, last_disconnection, - last_seen, last_miss) -> - let state = state_of_state_peerid state peer_id in - { trusted ; greylisted_until ; state ; - last_failed_connection ; last_rejected_connection ; - last_established_connection ; last_disconnection ; - last_seen ; last_miss }) - (obj10 - (req "trusted" bool) - (dft "greylisted_until" Time.encoding Time.epoch) - (req "state" state_encoding) - (opt "peer_id" Peer_id.encoding) - (opt "last_failed_connection" Time.encoding) - (opt "last_rejected_connection" (tup2 Peer_id.encoding Time.encoding)) - (opt "last_established_connection" (tup2 Peer_id.encoding Time.encoding)) - (opt "last_disconnection" (tup2 Peer_id.encoding Time.encoding)) - (opt "last_seen" (tup2 Peer_id.encoding Time.encoding)) - (opt "last_miss" Time.encoding)) + open P2p_types.Point_info + open P2p_types.Point_state let info_of_point_info i = let open P2p_connection_pool_types in let state = match Point_info.State.get i with | Requested _ -> Requested - | Accepted { current_peer_id } -> Accepted current_peer_id - | Running { current_peer_id } -> Running current_peer_id + | Accepted { current_peer_id ; _ } -> Accepted current_peer_id + | Running { current_peer_id ; _ } -> Running current_peer_id | Disconnected -> Disconnected in Point_info.{ trusted = trusted i ; @@ -677,74 +586,9 @@ module RPC = struct end module Peer_id = struct - include Peer_id - type state = - | Accepted - | Running - | Disconnected - - let pp_state_digram ppf = function - | Accepted -> Format.fprintf ppf "⚎" - | Running -> Format.fprintf ppf "⚌" - | Disconnected -> Format.fprintf ppf "⚏" - - let state_encoding = - let open Data_encoding in - string_enum [ - "accepted", Accepted ; - "running", Running ; - "disconnected", Disconnected ; - ] - - type info = { - score : float ; - trusted : bool ; - state : state ; - id_point : Id_point.t option ; - stat : Stat.t ; - last_failed_connection : (Id_point.t * Time.t) option ; - last_rejected_connection : (Id_point.t * Time.t) option ; - last_established_connection : (Id_point.t * Time.t) option ; - last_disconnection : (Id_point.t * Time.t) option ; - last_seen : (Id_point.t * Time.t) option ; - last_miss : (Id_point.t * Time.t) option ; - } - - let info_encoding = - let open Data_encoding in - conv - (fun ( - { score ; trusted ; state ; id_point ; stat ; - last_failed_connection ; last_rejected_connection ; - last_established_connection ; last_disconnection ; - last_seen ; last_miss }) -> - ((score, trusted, state, id_point, stat), - (last_failed_connection, last_rejected_connection, - last_established_connection, last_disconnection, - last_seen, last_miss))) - (fun ((score, trusted, state, id_point, stat), - (last_failed_connection, last_rejected_connection, - last_established_connection, last_disconnection, - last_seen, last_miss)) -> - { score ; trusted ; state ; id_point ; stat ; - last_failed_connection ; last_rejected_connection ; - last_established_connection ; last_disconnection ; - last_seen ; last_miss }) - (merge_objs - (obj5 - (req "score" float) - (req "trusted" bool) - (req "state" state_encoding) - (opt "reachable_at" Id_point.encoding) - (req "stat" Stat.encoding)) - (obj6 - (opt "last_failed_connection" (tup2 Id_point.encoding Time.encoding)) - (opt "last_rejected_connection" (tup2 Id_point.encoding Time.encoding)) - (opt "last_established_connection" (tup2 Id_point.encoding Time.encoding)) - (opt "last_disconnection" (tup2 Id_point.encoding Time.encoding)) - (opt "last_seen" (tup2 Id_point.encoding Time.encoding)) - (opt "last_miss" (tup2 Id_point.encoding Time.encoding)))) + open P2p_types.Peer_info + open P2p_types.Peer_state let info_of_peer_info pool i = let open P2p_connection_pool in @@ -783,8 +627,6 @@ module RPC = struct | None -> None end - module Event = P2p_connection_pool_types.Peer_info.Event - let events ?(max=max_int) ?(rev=false) net peer_id = match net.pool with | None -> [] diff --git a/lib_node_net/p2p.mli b/lib_node_p2p/p2p.mli similarity index 77% rename from lib_node_net/p2p.mli rename to lib_node_p2p/p2p.mli index a2f963d73..4fa640700 100644 --- a/lib_node_net/p2p.mli +++ b/lib_node_p2p/p2p.mli @@ -209,9 +209,9 @@ module RPC : sig val stat : ('msg, 'meta) net -> Stat.t - module Event = P2p_connection_pool.Log_event - - val watch : ('msg, 'meta) net -> Event.t Lwt_stream.t * Lwt_watcher.stopper + val watch : + ('msg, 'meta) net -> + P2p_types.Connection_pool_log_event.t Lwt_stream.t * Lwt_watcher.stopper val connect : ('msg, 'meta) net -> Point.t -> float -> unit tzresult Lwt.t module Connection : sig @@ -222,79 +222,41 @@ module RPC : sig end module Point : sig - include module type of Point - - type state = - | Requested - | Accepted of Peer_id.t - | Running of Peer_id.t - | Disconnected - - val pp_state_digram : Format.formatter -> state -> unit - val state_encoding : state Data_encoding.t - - type info = { - trusted : bool ; - greylisted_until : Time.t ; - state : state ; - last_failed_connection : Time.t option ; - last_rejected_connection : (Peer_id.t * Time.t) option ; - last_established_connection : (Peer_id.t * Time.t) option ; - last_disconnection : (Peer_id.t * Time.t) option ; - last_seen : (Peer_id.t * Time.t) option ; - last_miss : Time.t option ; - } - - val info_encoding : info Data_encoding.t - - module Event = P2p_connection_pool_types.Point_info.Event val info : - ('msg, 'meta) net -> Point.t -> info option + ('msg, 'meta) net -> Point.t -> P2p_types.Point_info.t option + val list : - ?restrict:state list -> ('msg, 'meta) net -> (Point.t * info) list + ?restrict: P2p_types.Point_state.t list -> + ('msg, 'meta) net -> (Point.t * P2p_types.Point_info.t) list + val events : - ?max:int -> ?rev:bool -> ('msg, 'meta) net -> Point.t -> Event.t list + ?max:int -> ?rev:bool -> ('msg, 'meta) net -> Point.t -> + P2p_connection_pool_types.Point_info.Event.t list + val watch : - ('msg, 'meta) net -> Point.t -> Event.t Lwt_stream.t * Lwt_watcher.stopper + ('msg, 'meta) net -> Point.t -> + P2p_connection_pool_types.Point_info.Event.t Lwt_stream.t * Lwt_watcher.stopper + end module Peer_id : sig - include module type of Peer_id - - type state = - | Accepted - | Running - | Disconnected - - val pp_state_digram : Format.formatter -> state -> unit - val state_encoding : state Data_encoding.t - - type info = { - score : float ; - trusted : bool ; - state : state ; - id_point : Id_point.t option ; - stat : Stat.t ; - last_failed_connection : (Id_point.t * Time.t) option ; - last_rejected_connection : (Id_point.t * Time.t) option ; - last_established_connection : (Id_point.t * Time.t) option ; - last_disconnection : (Id_point.t * Time.t) option ; - last_seen : (Id_point.t * Time.t) option ; - last_miss : (Id_point.t * Time.t) option ; - } - val info_encoding : info Data_encoding.t - - module Event = P2p_connection_pool_types.Peer_info.Event val info : - ('msg, 'meta) net -> Peer_id.t -> info option + ('msg, 'meta) net -> Peer_id.t -> P2p_types.Peer_info.t option + val list : - ?restrict:state list -> ('msg, 'meta) net -> (Peer_id.t * info) list + ?restrict: P2p_types.Peer_state.t list -> + ('msg, 'meta) net -> (Peer_id.t * P2p_types.Peer_info.t) list + val events : - ?max:int -> ?rev:bool -> ('msg, 'meta) net -> Peer_id.t -> Event.t list + ?max: int -> ?rev: bool -> + ('msg, 'meta) net -> Peer_id.t -> + P2p_connection_pool_types.Peer_info.Event.t list + val watch : - ('msg, 'meta) net -> Peer_id.t -> Event.t Lwt_stream.t * Lwt_watcher.stopper + ('msg, 'meta) net -> Peer_id.t -> + P2p_connection_pool_types.Peer_info.Event.t Lwt_stream.t * Lwt_watcher.stopper end @@ -313,6 +275,7 @@ val on_new_connection : (Peer_id.t -> ('msg, 'meta) connection -> unit) -> unit (**/**) + module Raw : sig type 'a t = | Bootstrap diff --git a/lib_node_net/p2p_connection.ml b/lib_node_p2p/p2p_connection.ml similarity index 100% rename from lib_node_net/p2p_connection.ml rename to lib_node_p2p/p2p_connection.ml diff --git a/lib_node_net/p2p_connection.mli b/lib_node_p2p/p2p_connection.mli similarity index 100% rename from lib_node_net/p2p_connection.mli rename to lib_node_p2p/p2p_connection.mli diff --git a/lib_node_net/p2p_connection_pool.ml b/lib_node_p2p/p2p_connection_pool.ml similarity index 84% rename from lib_node_net/p2p_connection_pool.ml rename to lib_node_p2p/p2p_connection_pool.ml index f1f40558e..d5636b0b4 100644 --- a/lib_node_net/p2p_connection_pool.ml +++ b/lib_node_p2p/p2p_connection_pool.ml @@ -150,160 +150,7 @@ module Answerer = struct end -module Log_event = struct - - type t = - - | Too_few_connections - | Too_many_connections - - | New_point of Point.t - | New_peer of Peer_id.t - - | Gc_points - | Gc_peer_ids - - | Incoming_connection of Point.t - | Outgoing_connection of Point.t - | Authentication_failed of Point.t - | Accepting_request of Point.t * Id_point.t * Peer_id.t - | Rejecting_request of Point.t * Id_point.t * Peer_id.t - | Request_rejected of Point.t * (Id_point.t * Peer_id.t) option - | Connection_established of Id_point.t * Peer_id.t - - | Swap_request_received of { source : Peer_id.t } - | Swap_ack_received of { source : Peer_id.t } - | Swap_request_sent of { source : Peer_id.t } - | Swap_ack_sent of { source : Peer_id.t } - | Swap_request_ignored of { source : Peer_id.t } - | Swap_success of { source : Peer_id.t } - | Swap_failure of { source : Peer_id.t } - - | Disconnection of Peer_id.t - | External_disconnection of Peer_id.t - - let encoding = - let open Data_encoding in - let branch_encoding name obj = - conv (fun x -> (), x) (fun ((), x) -> x) - (merge_objs - (obj1 (req "event" (constant name))) obj) in - union ~tag_size:`Uint8 [ - case ~tag:0 (branch_encoding "too_few_connections" empty) - (function Too_few_connections -> Some () | _ -> None) - (fun () -> Too_few_connections) ; - case ~tag:1 (branch_encoding "too_many_connections" empty) - (function Too_many_connections -> Some () | _ -> None) - (fun () -> Too_many_connections) ; - case ~tag:2 (branch_encoding "new_point" - (obj1 (req "point" Point.encoding))) - (function New_point p -> Some p | _ -> None) - (fun p -> New_point p) ; - case ~tag:3 (branch_encoding "new_peer" - (obj1 (req "peer_id" Peer_id.encoding))) - (function New_peer p -> Some p | _ -> None) - (fun p -> New_peer p) ; - case ~tag:4 (branch_encoding "incoming_connection" - (obj1 (req "point" Point.encoding))) - (function Incoming_connection p -> Some p | _ -> None) - (fun p -> Incoming_connection p) ; - case ~tag:5 (branch_encoding "outgoing_connection" - (obj1 (req "point" Point.encoding))) - (function Outgoing_connection p -> Some p | _ -> None) - (fun p -> Outgoing_connection p) ; - case ~tag:6 (branch_encoding "authentication_failed" - (obj1 (req "point" Point.encoding))) - (function Authentication_failed p -> Some p | _ -> None) - (fun p -> Authentication_failed p) ; - case ~tag:7 (branch_encoding "accepting_request" - (obj3 - (req "point" Point.encoding) - (req "id_point" Id_point.encoding) - (req "peer_id" Peer_id.encoding))) - (function Accepting_request (p, id_p, g) -> - Some (p, id_p, g) | _ -> None) - (fun (p, id_p, g) -> Accepting_request (p, id_p, g)) ; - case ~tag:8 (branch_encoding "rejecting_request" - (obj3 - (req "point" Point.encoding) - (req "id_point" Id_point.encoding) - (req "peer_id" Peer_id.encoding))) - (function Rejecting_request (p, id_p, g) -> - Some (p, id_p, g) | _ -> None) - (fun (p, id_p, g) -> Rejecting_request (p, id_p, g)) ; - case ~tag:9 (branch_encoding "request_rejected" - (obj2 - (req "point" Point.encoding) - (opt "identity" - (tup2 Id_point.encoding Peer_id.encoding)))) - (function Request_rejected (p, id) -> Some (p, id) | _ -> None) - (fun (p, id) -> Request_rejected (p, id)) ; - case ~tag:10 (branch_encoding "connection_established" - (obj2 - (req "id_point" Id_point.encoding) - (req "peer_id" Peer_id.encoding))) - (function Connection_established (id_p, g) -> - Some (id_p, g) | _ -> None) - (fun (id_p, g) -> Connection_established (id_p, g)) ; - case ~tag:11 (branch_encoding "disconnection" - (obj1 (req "peer_id" Peer_id.encoding))) - (function Disconnection g -> Some g | _ -> None) - (fun g -> Disconnection g) ; - case ~tag:12 (branch_encoding "external_disconnection" - (obj1 (req "peer_id" Peer_id.encoding))) - (function External_disconnection g -> Some g | _ -> None) - (fun g -> External_disconnection g) ; - case ~tag:13 (branch_encoding "gc_points" empty) - (function Gc_points -> Some () | _ -> None) - (fun () -> Gc_points) ; - case ~tag:14 (branch_encoding "gc_peer_ids" empty) - (function Gc_peer_ids -> Some () | _ -> None) - (fun () -> Gc_peer_ids) ; - case ~tag:15 (branch_encoding "swap_request_received" - (obj1 (req "source" Peer_id.encoding))) - (function - | Swap_request_received { source } -> Some source - | _ -> None) - (fun source -> Swap_request_received { source }) ; - case ~tag:16 (branch_encoding "swap_ack_received" - (obj1 (req "source" Peer_id.encoding))) - (function - | Swap_ack_received { source } -> Some source - | _ -> None) - (fun source -> Swap_ack_received { source }) ; - case ~tag:17 (branch_encoding "swap_request_sent" - (obj1 (req "source" Peer_id.encoding))) - (function - | Swap_request_sent { source } -> Some source - | _ -> None) - (fun source -> Swap_request_sent { source }) ; - case ~tag:18 (branch_encoding "swap_ack_sent" - (obj1 (req "source" Peer_id.encoding))) - (function - | Swap_ack_sent { source } -> Some source - | _ -> None) - (fun source -> Swap_ack_sent { source }) ; - case ~tag:19 (branch_encoding "swap_request_ignored" - (obj1 (req "source" Peer_id.encoding))) - (function - | Swap_request_ignored { source } -> Some source - | _ -> None) - (fun source -> Swap_request_ignored { source }) ; - case ~tag:20 (branch_encoding "swap_success" - (obj1 (req "source" Peer_id.encoding))) - (function - | Swap_success { source } -> Some source - | _ -> None) - (fun source -> Swap_success { source }) ; - case ~tag:21 (branch_encoding "swap_failure" - (obj1 (req "source" Peer_id.encoding))) - (function - | Swap_failure { source } -> Some source - | _ -> None) - (fun source -> Swap_failure { source }) ; - ] - -end +module Log_event = Connection_pool_log_event type config = { diff --git a/lib_node_net/p2p_connection_pool.mli b/lib_node_p2p/p2p_connection_pool.mli similarity index 85% rename from lib_node_net/p2p_connection_pool.mli rename to lib_node_p2p/p2p_connection_pool.mli index 1d9fb3dff..e24084763 100644 --- a/lib_node_net/p2p_connection_pool.mli +++ b/lib_node_p2p/p2p_connection_pool.mli @@ -333,66 +333,7 @@ module Points : sig end -module Log_event : sig - - type t = - - (* Pool-level events *) - - | Too_few_connections - | Too_many_connections - - | New_point of Point.t - | New_peer of Peer_id.t - - | Gc_points - (** Garbage collection of known point table has been triggered. *) - - | Gc_peer_ids - (** Garbage collection of known peer_ids table has been triggered. *) - - (* Connection-level events *) - - | Incoming_connection of Point.t - (** We accept(2)-ed an incoming connection *) - | Outgoing_connection of Point.t - (** We connect(2)-ed to a remote endpoint *) - | Authentication_failed of Point.t - (** Remote point failed authentication *) - - | Accepting_request of Point.t * Id_point.t * Peer_id.t - (** We accepted a connection after authentifying the remote peer. *) - | Rejecting_request of Point.t * Id_point.t * Peer_id.t - (** We rejected a connection after authentifying the remote peer. *) - | Request_rejected of Point.t * (Id_point.t * Peer_id.t) option - (** The remote peer rejected our connection. *) - - | Connection_established of Id_point.t * Peer_id.t - (** We succesfully established a authentified connection. *) - - | Swap_request_received of { source : Peer_id.t } - (** A swap request has been received. *) - | Swap_ack_received of { source : Peer_id.t } - (** A swap ack has been received *) - | Swap_request_sent of { source : Peer_id.t } - (** A swap request has been sent *) - | Swap_ack_sent of { source : Peer_id.t } - (** A swap ack has been sent *) - | Swap_request_ignored of { source : Peer_id.t } - (** A swap request has been ignored *) - | Swap_success of { source : Peer_id.t } - (** A swap operation has succeeded *) - | Swap_failure of { source : Peer_id.t } - (** A swap operation has failed *) - - | Disconnection of Peer_id.t - (** We decided to close the connection. *) - | External_disconnection of Peer_id.t - (** The connection was closed for external reason. *) - - val encoding : t Data_encoding.t - -end +module Log_event = Connection_pool_log_event val watch: ('msg, 'meta) pool -> Log_event.t Lwt_stream.t * Lwt_watcher.stopper (** [watch pool] is a [stream, close] a [stream] of events and a diff --git a/lib_node_net/p2p_discovery.ml b/lib_node_p2p/p2p_discovery.ml similarity index 100% rename from lib_node_net/p2p_discovery.ml rename to lib_node_p2p/p2p_discovery.ml diff --git a/lib_node_net/p2p_discovery.mli b/lib_node_p2p/p2p_discovery.mli similarity index 100% rename from lib_node_net/p2p_discovery.mli rename to lib_node_p2p/p2p_discovery.mli diff --git a/lib_node_net/p2p_io_scheduler.ml b/lib_node_p2p/p2p_io_scheduler.ml similarity index 100% rename from lib_node_net/p2p_io_scheduler.ml rename to lib_node_p2p/p2p_io_scheduler.ml diff --git a/lib_node_net/p2p_io_scheduler.mli b/lib_node_p2p/p2p_io_scheduler.mli similarity index 100% rename from lib_node_net/p2p_io_scheduler.mli rename to lib_node_p2p/p2p_io_scheduler.mli diff --git a/lib_node_net/p2p_maintenance.ml b/lib_node_p2p/p2p_maintenance.ml similarity index 100% rename from lib_node_net/p2p_maintenance.ml rename to lib_node_p2p/p2p_maintenance.ml diff --git a/lib_node_net/p2p_maintenance.mli b/lib_node_p2p/p2p_maintenance.mli similarity index 100% rename from lib_node_net/p2p_maintenance.mli rename to lib_node_p2p/p2p_maintenance.mli diff --git a/lib_node_net/p2p_welcome.ml b/lib_node_p2p/p2p_welcome.ml similarity index 100% rename from lib_node_net/p2p_welcome.ml rename to lib_node_p2p/p2p_welcome.ml diff --git a/lib_node_net/p2p_welcome.mli b/lib_node_p2p/p2p_welcome.mli similarity index 100% rename from lib_node_net/p2p_welcome.mli rename to lib_node_p2p/p2p_welcome.mli diff --git a/lib_node_p2p/tezos-node-p2p.opam b/lib_node_p2p/tezos-node-p2p.opam new file mode 100644 index 000000000..679f3f4c2 --- /dev/null +++ b/lib_node_p2p/tezos-node-p2p.opam @@ -0,0 +1,21 @@ +opam-version: "1.2" +version: "dev" +maintainer: "contact@tezos.com" +authors: [ "Tezos devteam" ] +homepage: "https://www.tezos.com/" +bug-reports: "https://gitlab.com/tezos/tezos/issues" +dev-repo: "https://gitlab.com/tezos/tezos.git" +license: "unreleased" +depends: [ + "ocamlfind" { build } + "jbuilder" { build & >= "1.0+beta15" } + "base-bigarray" + "mtime.clock.os" + "ocplib-resto-cohttp" +] +build: [ + [ "jbuilder" "build" "-p" name "-j" jobs ] +] +build-test: [ + [ "jbuilder" "runtest" "-p" name "-j" jobs ] +] diff --git a/lib_node_p2p_base/jbuild b/lib_node_p2p_base/jbuild new file mode 100644 index 000000000..0ac70f10c --- /dev/null +++ b/lib_node_p2p_base/jbuild @@ -0,0 +1,12 @@ +(jbuild_version 1) + +(library + ((name tezos_node_p2p_base) + (public_name tezos-node-p2p-base) + (libraries (tezos-base)) + (flags (:standard -open Tezos_base__TzPervasives)))) + +(alias + ((name runtest_indent) + (deps ((glob_files *.ml) (glob_files *.mli))) + (action (run bash ${libexec:tezos-stdlib:test-ocp-indent.sh} ${<})))) diff --git a/lib_node_net/p2p_connection_pool_types.ml b/lib_node_p2p_base/p2p_connection_pool_types.ml similarity index 93% rename from lib_node_net/p2p_connection_pool_types.ml rename to lib_node_p2p_base/p2p_connection_pool_types.ml index 6fc74991b..73edb0921 100644 --- a/lib_node_net/p2p_connection_pool_types.ml +++ b/lib_node_p2p_base/p2p_connection_pool_types.ml @@ -163,11 +163,11 @@ module Point_info = struct | (Some t1 as a1 , (Some t2 as a2)) -> if Time.compare t1 t2 < 0 then a2 else a1 - let fold_events { events } ~init ~f = Ring.fold events ~init ~f + let fold_events { events ; _ } ~init ~f = Ring.fold events ~init ~f - let watch { watchers } = Lwt_watcher.create_stream watchers + let watch { watchers ; _ } = Lwt_watcher.create_stream watchers - let log { events ; watchers } ?(timestamp = Time.now ()) kind = + let log { events ; watchers ; _ } ?(timestamp = Time.now ()) kind = let event = { Event.kind ; timestamp } in Ring.add events event ; Lwt_watcher.notify watchers event @@ -189,16 +189,16 @@ module Point_info = struct let pp ppf = function | Requested _ -> Format.fprintf ppf "requested" - | Accepted { current_peer_id } -> + | Accepted { current_peer_id ; _ } -> Format.fprintf ppf "accepted %a" Peer_id.pp current_peer_id - | Running { current_peer_id } -> + | Running { current_peer_id ; _ } -> Format.fprintf ppf "running %a" Peer_id.pp current_peer_id | Disconnected -> Format.fprintf ppf "disconnected" - let get { state } = state + let get { state ; _ } = state - let is_disconnected { state } = + let is_disconnected { state ; _ } = match state with | Disconnected -> true | Requested _ | Accepted _ | Running _ -> false @@ -232,7 +232,7 @@ module Point_info = struct match point_info.state with | Disconnected -> true (* request to unknown peer_id. *) | Running _ -> false - | Accepted { current_peer_id } -> Peer_id.equal peer_id current_peer_id + | Accepted { current_peer_id ; _ } -> Peer_id.equal peer_id current_peer_id | Requested _ -> true end ; point_info.state <- Running { data ; current_peer_id = peer_id } ; @@ -255,12 +255,12 @@ module Point_info = struct set_greylisted timestamp point_info ; point_info.last_failed_connection <- Some timestamp ; Request_rejected None - | Accepted { current_peer_id } -> + | Accepted { current_peer_id ; _ } -> set_greylisted timestamp point_info ; point_info.last_rejected_connection <- Some (current_peer_id, timestamp) ; Request_rejected (Some current_peer_id) - | Running { current_peer_id } -> + | Running { current_peer_id ; _ } -> point_info.greylisting_delay <- float_of_int point_info.greylisting.initial_delay ; point_info.greylisting_end <- @@ -368,7 +368,7 @@ module Peer_info = struct conv (fun { peer_id ; trusted ; metadata ; events ; created ; last_failed_connection ; last_rejected_connection ; - last_established_connection ; last_disconnection } -> + last_established_connection ; last_disconnection ; _ } -> (peer_id, created, trusted, metadata, Ring.elements events, last_failed_connection, last_rejected_connection, last_established_connection, last_disconnection)) @@ -402,14 +402,14 @@ module Peer_info = struct (opt "last_disconnection" (tup2 Id_point.encoding Time.encoding))) - let peer_id { peer_id } = peer_id - let created { created } = created - let metadata { metadata } = metadata + let peer_id { peer_id ; _ } = peer_id + let created { created ; _ } = created + let metadata { metadata ; _ } = metadata let set_metadata gi metadata = gi.metadata <- metadata - let trusted { trusted } = trusted + let trusted { trusted ; _ } = trusted let set_trusted gi = gi.trusted <- true let unset_trusted gi = gi.trusted <- false - let fold_events { events } ~init ~f = Ring.fold events ~init ~f + let fold_events { events ; _ } ~init ~f = Ring.fold events ~init ~f let last_established_connection s = s.last_established_connection let last_disconnection s = s.last_disconnection @@ -426,12 +426,12 @@ module Peer_info = struct s.last_failed_connection (recent s.last_rejected_connection s.last_disconnection) - let log { events ; watchers } ?(timestamp = Time.now ()) point kind = + let log { events ; watchers ; _ } ?(timestamp = Time.now ()) point kind = let event = { Event.kind ; timestamp ; point } in Ring.add events event ; Lwt_watcher.notify watchers event - let watch { watchers } = Lwt_watcher.create_stream watchers + let watch { watchers ; _ } = Lwt_watcher.create_stream watchers let log_incoming_rejection ?timestamp peer_info point = log peer_info ?timestamp point Rejecting_request @@ -447,16 +447,16 @@ module Peer_info = struct type 'data state = 'data t let pp ppf = function - | Accepted { current_point } -> + | Accepted { current_point ; _ } -> Format.fprintf ppf "accepted %a" Id_point.pp current_point - | Running { current_point } -> + | Running { current_point ; _ } -> Format.fprintf ppf "running %a" Id_point.pp current_point | Disconnected -> Format.fprintf ppf "disconnected" - let get { state } = state + let get { state ; _ } = state - let is_disconnected { state } = + let is_disconnected { state ; _ } = match state with | Disconnected -> true | Accepted _ | Running _ -> false @@ -479,7 +479,7 @@ module Peer_info = struct match peer_info.state with | Disconnected -> true (* request to unknown peer_id. *) | Running _ -> false - | Accepted { current_point } -> + | Accepted { current_point ; _ } -> Id_point.equal point current_point end ; peer_info.state <- Running { data ; current_point = point } ; @@ -490,11 +490,11 @@ module Peer_info = struct ?(timestamp = Time.now ()) ?(requested = false) peer_info = let current_point, (event : Event.kind) = match peer_info.state with - | Accepted { current_point } -> + | Accepted { current_point ; _ } -> peer_info.last_rejected_connection <- Some (current_point, timestamp) ; current_point, Request_rejected - | Running { current_point } -> + | Running { current_point ; _ } -> peer_info.last_disconnection <- Some (current_point, timestamp) ; current_point, diff --git a/lib_node_net/p2p_connection_pool_types.mli b/lib_node_p2p_base/p2p_connection_pool_types.mli similarity index 100% rename from lib_node_net/p2p_connection_pool_types.mli rename to lib_node_p2p_base/p2p_connection_pool_types.mli diff --git a/lib_node_p2p_base/p2p_types.ml b/lib_node_p2p_base/p2p_types.ml new file mode 100644 index 000000000..58b5f6fd5 --- /dev/null +++ b/lib_node_p2p_base/p2p_types.ml @@ -0,0 +1,717 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +module Version = struct + type t = { + name : string ; + major : int ; + minor : int ; + } + + let pp ppf { name ; major ; minor } = + Format.fprintf ppf "%s.%d.%d" name major minor + + let encoding = + let open Data_encoding in + conv + (fun { name; major; minor } -> (name, major, minor)) + (fun (name, major, minor) -> { name; major; minor }) + (obj3 + (req "name" string) + (req "major" int8) + (req "minor" int8)) + + (* the common version for a pair of peers, if any, is the maximum one, + in lexicographic order *) + let common la lb = + let la = List.sort (fun l r -> compare r l) la in + let lb = List.sort (fun l r -> compare r l) lb in + let rec find = function + | [], _ | _, [] -> None + | ((a :: ta) as la), ((b :: tb) as lb) -> + if a = b then Some a + else if a < b then find (ta, lb) + else find (la, tb) + in find (la, lb) +end + +module Stat = struct + + type t = { + total_sent : int64 ; + total_recv : int64 ; + current_inflow : int ; + current_outflow : int ; + } + + let empty = { + total_sent = 0L ; + total_recv = 0L ; + current_inflow = 0 ; + current_outflow = 0 ; + } + + let print_size ppf sz = + let ratio n = (float_of_int sz /. float_of_int (1 lsl n)) in + if sz < 1 lsl 10 then + Format.fprintf ppf "%d B" sz + else if sz < 1 lsl 20 then + Format.fprintf ppf "%.2f kiB" (ratio 10) + else + Format.fprintf ppf "%.2f MiB" (ratio 20) + + let print_size64 ppf sz = + let open Int64 in + let ratio n = (to_float sz /. float_of_int (1 lsl n)) in + if sz < shift_left 1L 10 then + Format.fprintf ppf "%Ld B" sz + else if sz < shift_left 1L 20 then + Format.fprintf ppf "%.2f kiB" (ratio 10) + else if sz < shift_left 1L 30 then + Format.fprintf ppf "%.2f MiB" (ratio 20) + else if sz < shift_left 1L 40 then + Format.fprintf ppf "%.2f GiB" (ratio 30) + else + Format.fprintf ppf "%.2f TiB" (ratio 40) + + let pp ppf stat = + Format.fprintf ppf + "↗ %a (%a/s) ↘ %a (%a/s)" + print_size64 stat.total_sent print_size stat.current_outflow + print_size64 stat.total_recv print_size stat.current_inflow + + let encoding = + let open Data_encoding in + conv + (fun { total_sent ; total_recv ; current_inflow ; current_outflow } -> + (total_sent, total_recv, current_inflow, current_outflow)) + (fun (total_sent, total_recv, current_inflow, current_outflow) -> + { total_sent ; total_recv ; current_inflow ; current_outflow }) + (obj4 + (req "total_sent" int64) + (req "total_recv" int64) + (req "current_inflow" int31) + (req "current_outflow" int31)) +end + +(* public types *) +type addr = Ipaddr.V6.t + +let addr_encoding = + let open Data_encoding in + splitted + ~json:begin + conv + Ipaddr.V6.to_string + Ipaddr.V6.of_string_exn + string + end + ~binary:begin + conv + Ipaddr.V6.to_bytes + Ipaddr.V6.of_bytes_exn + string + end + +type port = int + + +module Id_point = struct + + module T = struct + + (* A net point (address x port). *) + type t = addr * port option + let compare (a1, p1) (a2, p2) = + match Ipaddr.V6.compare a1 a2 with + | 0 -> Pervasives.compare p1 p2 + | x -> x + let equal p1 p2 = compare p1 p2 = 0 + let hash = Hashtbl.hash + let pp ppf (addr, port) = + match port with + | None -> + Format.fprintf ppf "[%a]:??" Ipaddr.V6.pp_hum addr + | Some port -> + Format.fprintf ppf "[%a]:%d" Ipaddr.V6.pp_hum addr port + let pp_opt ppf = function + | None -> Format.pp_print_string ppf "none" + | Some point -> pp ppf point + let to_string t = Format.asprintf "%a" pp t + + let is_local (addr, _) = Ipaddr.V6.is_private addr + let is_global (addr, _) = not @@ Ipaddr.V6.is_private addr + + let of_point (addr, port) = addr, Some port + let to_point = function + | _, None -> None + | addr, Some port -> Some (addr, port) + let to_point_exn = function + | _, None -> invalid_arg "to_point_exn" + | addr, Some port -> addr, port + + let encoding = + let open Data_encoding in + (obj2 + (req "addr" addr_encoding) + (opt "port" uint16)) + + end + + include T + + module Map = Map.Make (T) + module Set = Set.Make (T) + module Table = Hashtbl.Make (T) + +end + +module Peer_id = Crypto_box.Public_key_hash + +module Peer_state = struct + + type t = + | Accepted + | Running + | Disconnected + + let pp_digram ppf = function + | Accepted -> Format.fprintf ppf "⚎" + | Running -> Format.fprintf ppf "⚌" + | Disconnected -> Format.fprintf ppf "⚏" + + let encoding = + let open Data_encoding in + string_enum [ + "accepted", Accepted ; + "running", Running ; + "disconnected", Disconnected ; + ] + +end + +module Peer_info = struct + + type t = { + score : float ; + trusted : bool ; + state : Peer_state.t ; + id_point : Id_point.t option ; + stat : Stat.t ; + last_failed_connection : (Id_point.t * Time.t) option ; + last_rejected_connection : (Id_point.t * Time.t) option ; + last_established_connection : (Id_point.t * Time.t) option ; + last_disconnection : (Id_point.t * Time.t) option ; + last_seen : (Id_point.t * Time.t) option ; + last_miss : (Id_point.t * Time.t) option ; + } + + let encoding = + let open Data_encoding in + conv + (fun ( + { score ; trusted ; state ; id_point ; stat ; + last_failed_connection ; last_rejected_connection ; + last_established_connection ; last_disconnection ; + last_seen ; last_miss }) -> + ((score, trusted, state, id_point, stat), + (last_failed_connection, last_rejected_connection, + last_established_connection, last_disconnection, + last_seen, last_miss))) + (fun ((score, trusted, state, id_point, stat), + (last_failed_connection, last_rejected_connection, + last_established_connection, last_disconnection, + last_seen, last_miss)) -> + { score ; trusted ; state ; id_point ; stat ; + last_failed_connection ; last_rejected_connection ; + last_established_connection ; last_disconnection ; + last_seen ; last_miss }) + (merge_objs + (obj5 + (req "score" float) + (req "trusted" bool) + (req "state" Peer_state.encoding) + (opt "reachable_at" Id_point.encoding) + (req "stat" Stat.encoding)) + (obj6 + (opt "last_failed_connection" (tup2 Id_point.encoding Time.encoding)) + (opt "last_rejected_connection" (tup2 Id_point.encoding Time.encoding)) + (opt "last_established_connection" (tup2 Id_point.encoding Time.encoding)) + (opt "last_disconnection" (tup2 Id_point.encoding Time.encoding)) + (opt "last_seen" (tup2 Id_point.encoding Time.encoding)) + (opt "last_miss" (tup2 Id_point.encoding Time.encoding)))) + +end + +module Point = struct + + module T = struct + + (* A net point (address x port). *) + type t = addr * port + let compare (a1, p1) (a2, p2) = + match Ipaddr.V6.compare a1 a2 with + | 0 -> p1 - p2 + | x -> x + let equal p1 p2 = compare p1 p2 = 0 + let hash = Hashtbl.hash + let pp ppf (addr, port) = + match Ipaddr.v4_of_v6 addr with + | Some addr -> + Format.fprintf ppf "%a:%d" Ipaddr.V4.pp_hum addr port + | None -> + Format.fprintf ppf "[%a]:%d" Ipaddr.V6.pp_hum addr port + let pp_opt ppf = function + | None -> Format.pp_print_string ppf "none" + | Some point -> pp ppf point + + let is_local (addr, _) = Ipaddr.V6.is_private addr + let is_global (addr, _) = not @@ Ipaddr.V6.is_private addr + + let check_port port = + if TzString.mem_char port '[' || + TzString.mem_char port ']' || + TzString.mem_char port ':' then + invalid_arg "Utils.parse_addr_port (invalid character in port)" + + let parse_addr_port s = + let len = String.length s in + if len = 0 then + ("", "") + else if s.[0] = '[' then begin (* inline IPv6 *) + match String.rindex s ']' with + | exception Not_found -> + invalid_arg "Utils.parse_addr_port (missing ']')" + | pos -> + let addr = String.sub s 1 (pos - 1) in + let port = + if pos = len - 1 then + "" + else if s.[pos+1] <> ':' then + invalid_arg "Utils.parse_addr_port (unexpected char after ']')" + else + String.sub s (pos + 2) (len - pos - 2) in + check_port port ; + addr, port + end else begin + match String.rindex s ']' with + | _pos -> + invalid_arg "Utils.parse_addr_port (unexpected char ']')" + | exception Not_found -> + match String.index s ':' with + | exception _ -> s, "" + | pos -> + match String.index_from s (pos+1) ':' with + | exception _ -> + let addr = String.sub s 0 pos in + let port = String.sub s (pos + 1) (len - pos - 1) in + check_port port ; + addr, port + | _pos -> + invalid_arg "Utils.parse_addr_port: IPv6 addresses must be bracketed" + end + + let of_string_exn str = + let addr, port = parse_addr_port str in + let port = int_of_string port in + if port < 0 && port > 1 lsl 16 - 1 then + invalid_arg "port must be between 0 and 65535" ; + match Ipaddr.of_string_exn addr with + | V4 addr -> Ipaddr.v6_of_v4 addr, port + | V6 addr -> addr, port + + let of_string str = + try Ok (of_string_exn str) with + | Invalid_argument s -> Error s + | Failure s -> Error s + | _ -> Error "Point.of_string" + + let to_string saddr = Format.asprintf "%a" pp saddr + + let encoding = + Data_encoding.conv to_string of_string_exn Data_encoding.string + + end + + include T + + module Map = Map.Make (T) + module Set = Set.Make (T) + module Table = Hashtbl.Make (T) + +end + +module Point_state = struct + + type t = + | Requested + | Accepted of Peer_id.t + | Running of Peer_id.t + | Disconnected + + let of_peer_id = function + | Requested -> None + | Accepted pi -> Some pi + | Running pi -> Some pi + | Disconnected -> None + + let of_peerid_state state pi = + match state, pi with + | Requested, _ -> Requested + | Accepted _, Some pi -> Accepted pi + | Running _, Some pi -> Running pi + | Disconnected, _ -> Disconnected + | _ -> invalid_arg "state_of_state_peerid" + + let pp_digram ppf = function + | Requested -> Format.fprintf ppf "⚎" + | Accepted _ -> Format.fprintf ppf "⚍" + | Running _ -> Format.fprintf ppf "⚌" + | Disconnected -> Format.fprintf ppf "⚏" + + let encoding = + let open Data_encoding in + let branch_encoding name obj = + conv (fun x -> (), x) (fun ((), x) -> x) + (merge_objs + (obj1 (req "event_kind" (constant name))) obj) in + union ~tag_size:`Uint8 [ + case ~tag:0 (branch_encoding "requested" empty) + (function Requested -> Some () | _ -> None) + (fun () -> Requested) ; + case ~tag:1 (branch_encoding "accepted" + (obj1 (req "peer_id" Peer_id.encoding))) + (function Accepted peer_id -> Some peer_id | _ -> None) + (fun peer_id -> Accepted peer_id) ; + case ~tag:2 (branch_encoding "running" + (obj1 (req "peer_id" Peer_id.encoding))) + (function Running peer_id -> Some peer_id | _ -> None) + (fun peer_id -> Running peer_id) ; + case ~tag:3 (branch_encoding "disconnected" empty) + (function Disconnected -> Some () | _ -> None) + (fun () -> Disconnected) ; + ] + +end + +module Point_info = struct + + type t = { + trusted : bool ; + greylisted_until : Time.t ; + state : Point_state.t ; + last_failed_connection : Time.t option ; + last_rejected_connection : (Peer_id.t * Time.t) option ; + last_established_connection : (Peer_id.t * Time.t) option ; + last_disconnection : (Peer_id.t * Time.t) option ; + last_seen : (Peer_id.t * Time.t) option ; + last_miss : Time.t option ; + } + + let encoding = + let open Data_encoding in + conv + (fun { trusted ; greylisted_until ; state ; + last_failed_connection ; last_rejected_connection ; + last_established_connection ; last_disconnection ; + last_seen ; last_miss } -> + let peer_id = Point_state.of_peer_id state in + (trusted, greylisted_until, state, peer_id, + last_failed_connection, last_rejected_connection, + last_established_connection, last_disconnection, + last_seen, last_miss)) + (fun (trusted, greylisted_until, state, peer_id, + last_failed_connection, last_rejected_connection, + last_established_connection, last_disconnection, + last_seen, last_miss) -> + let state = Point_state.of_peerid_state state peer_id in + { trusted ; greylisted_until ; state ; + last_failed_connection ; last_rejected_connection ; + last_established_connection ; last_disconnection ; + last_seen ; last_miss }) + (obj10 + (req "trusted" bool) + (dft "greylisted_until" Time.encoding Time.epoch) + (req "state" Point_state.encoding) + (opt "peer_id" Peer_id.encoding) + (opt "last_failed_connection" Time.encoding) + (opt "last_rejected_connection" (tup2 Peer_id.encoding Time.encoding)) + (opt "last_established_connection" (tup2 Peer_id.encoding Time.encoding)) + (opt "last_disconnection" (tup2 Peer_id.encoding Time.encoding)) + (opt "last_seen" (tup2 Peer_id.encoding Time.encoding)) + (opt "last_miss" Time.encoding)) + +end + + +module Identity = struct + + type t = { + peer_id : Peer_id.t ; + public_key : Crypto_box.public_key ; + secret_key : Crypto_box.secret_key ; + proof_of_work_stamp : Crypto_box.nonce ; + } + + let encoding = + let open Data_encoding in + conv + (fun { public_key ; secret_key ; proof_of_work_stamp ; _ } -> + (public_key, secret_key, proof_of_work_stamp)) + (fun (public_key, secret_key, proof_of_work_stamp) -> + let peer_id = Crypto_box.hash public_key in + { peer_id ; public_key ; secret_key ; proof_of_work_stamp }) + (obj3 + (req "public_key" Crypto_box.public_key_encoding) + (req "secret_key" Crypto_box.secret_key_encoding) + (req "proof_of_work_stamp" Crypto_box.nonce_encoding)) + + let generate ?max target = + let secret_key, public_key, peer_id = Crypto_box.random_keypair () in + let proof_of_work_stamp = + Crypto_box.generate_proof_of_work ?max public_key target in + { peer_id ; public_key ; secret_key ; proof_of_work_stamp } + + let animation = [| + "|.....|" ; + "|o....|" ; + "|oo...|" ; + "|ooo..|" ; + "|.ooo.|" ; + "|..ooo|" ; + "|...oo|" ; + "|....o|" ; + "|.....|" ; + "|.....|" ; + "|.....|" ; + "|.....|" ; + |] + + let init = String.make (String.length animation.(0)) '\ ' + let clean = String.make (String.length animation.(0)) '\b' + let animation = Array.map (fun x -> clean ^ x) animation + let animation_size = Array.length animation + let duration = 1200 / animation_size + + let generate_with_animation ppf target = + Format.fprintf ppf "%s%!" init ; + let count = ref 10000 in + let rec loop n = + let start = Mtime_clock.counter () in + Format.fprintf ppf "%s%!" animation.(n mod animation_size); + try generate ~max:!count target + with Not_found -> + let time = Mtime.Span.to_ms (Mtime_clock.count start) in + count := + if time <= 0. then + !count * 10 + else + !count * duration / int_of_float time ; + loop (n+1) + in + let id = loop 0 in + Format.fprintf ppf "%s%s\n%!" clean init ; + id + + let generate target = generate target + +end + +module Connection_info = struct + + type t = { + incoming : bool; + peer_id : Peer_id.t; + id_point : Id_point.t; + remote_socket_port : port; + versions : Version.t list ; + } + + let encoding = + let open Data_encoding in + conv + (fun { incoming ; peer_id ; id_point ; remote_socket_port ; versions } -> + (incoming, peer_id, id_point, remote_socket_port, versions)) + (fun (incoming, peer_id, id_point, remote_socket_port, versions) -> + { incoming ; peer_id ; id_point ; remote_socket_port ; versions }) + (obj5 + (req "incoming" bool) + (req "peer_id" Peer_id.encoding) + (req "id_point" Id_point.encoding) + (req "remote_socket_port" uint16) + (req "versions" (list Version.encoding))) + + let pp ppf + { incoming ; id_point = (remote_addr, remote_port) ; + remote_socket_port ; peer_id ; versions } = + let version = List.hd versions in + let point = match remote_port with + | None -> remote_addr, remote_socket_port + | Some port -> remote_addr, port in + Format.fprintf ppf "%s %a %a (%a)" + (if incoming then "↘" else "↗") + Peer_id.pp peer_id + Point.pp point + Version.pp version +end + +module Connection_pool_log_event = struct + + type t = + + | Too_few_connections + | Too_many_connections + + | New_point of Point.t + | New_peer of Peer_id.t + + | Gc_points + | Gc_peer_ids + + | Incoming_connection of Point.t + | Outgoing_connection of Point.t + | Authentication_failed of Point.t + | Accepting_request of Point.t * Id_point.t * Peer_id.t + | Rejecting_request of Point.t * Id_point.t * Peer_id.t + | Request_rejected of Point.t * (Id_point.t * Peer_id.t) option + | Connection_established of Id_point.t * Peer_id.t + + | Swap_request_received of { source : Peer_id.t } + | Swap_ack_received of { source : Peer_id.t } + | Swap_request_sent of { source : Peer_id.t } + | Swap_ack_sent of { source : Peer_id.t } + | Swap_request_ignored of { source : Peer_id.t } + | Swap_success of { source : Peer_id.t } + | Swap_failure of { source : Peer_id.t } + + | Disconnection of Peer_id.t + | External_disconnection of Peer_id.t + + let encoding = + let open Data_encoding in + let branch_encoding name obj = + conv (fun x -> (), x) (fun ((), x) -> x) + (merge_objs + (obj1 (req "event" (constant name))) obj) in + union ~tag_size:`Uint8 [ + case ~tag:0 (branch_encoding "too_few_connections" empty) + (function Too_few_connections -> Some () | _ -> None) + (fun () -> Too_few_connections) ; + case ~tag:1 (branch_encoding "too_many_connections" empty) + (function Too_many_connections -> Some () | _ -> None) + (fun () -> Too_many_connections) ; + case ~tag:2 (branch_encoding "new_point" + (obj1 (req "point" Point.encoding))) + (function New_point p -> Some p | _ -> None) + (fun p -> New_point p) ; + case ~tag:3 (branch_encoding "new_peer" + (obj1 (req "peer_id" Peer_id.encoding))) + (function New_peer p -> Some p | _ -> None) + (fun p -> New_peer p) ; + case ~tag:4 (branch_encoding "incoming_connection" + (obj1 (req "point" Point.encoding))) + (function Incoming_connection p -> Some p | _ -> None) + (fun p -> Incoming_connection p) ; + case ~tag:5 (branch_encoding "outgoing_connection" + (obj1 (req "point" Point.encoding))) + (function Outgoing_connection p -> Some p | _ -> None) + (fun p -> Outgoing_connection p) ; + case ~tag:6 (branch_encoding "authentication_failed" + (obj1 (req "point" Point.encoding))) + (function Authentication_failed p -> Some p | _ -> None) + (fun p -> Authentication_failed p) ; + case ~tag:7 (branch_encoding "accepting_request" + (obj3 + (req "point" Point.encoding) + (req "id_point" Id_point.encoding) + (req "peer_id" Peer_id.encoding))) + (function Accepting_request (p, id_p, g) -> + Some (p, id_p, g) | _ -> None) + (fun (p, id_p, g) -> Accepting_request (p, id_p, g)) ; + case ~tag:8 (branch_encoding "rejecting_request" + (obj3 + (req "point" Point.encoding) + (req "id_point" Id_point.encoding) + (req "peer_id" Peer_id.encoding))) + (function Rejecting_request (p, id_p, g) -> + Some (p, id_p, g) | _ -> None) + (fun (p, id_p, g) -> Rejecting_request (p, id_p, g)) ; + case ~tag:9 (branch_encoding "request_rejected" + (obj2 + (req "point" Point.encoding) + (opt "identity" + (tup2 Id_point.encoding Peer_id.encoding)))) + (function Request_rejected (p, id) -> Some (p, id) | _ -> None) + (fun (p, id) -> Request_rejected (p, id)) ; + case ~tag:10 (branch_encoding "connection_established" + (obj2 + (req "id_point" Id_point.encoding) + (req "peer_id" Peer_id.encoding))) + (function Connection_established (id_p, g) -> + Some (id_p, g) | _ -> None) + (fun (id_p, g) -> Connection_established (id_p, g)) ; + case ~tag:11 (branch_encoding "disconnection" + (obj1 (req "peer_id" Peer_id.encoding))) + (function Disconnection g -> Some g | _ -> None) + (fun g -> Disconnection g) ; + case ~tag:12 (branch_encoding "external_disconnection" + (obj1 (req "peer_id" Peer_id.encoding))) + (function External_disconnection g -> Some g | _ -> None) + (fun g -> External_disconnection g) ; + case ~tag:13 (branch_encoding "gc_points" empty) + (function Gc_points -> Some () | _ -> None) + (fun () -> Gc_points) ; + case ~tag:14 (branch_encoding "gc_peer_ids" empty) + (function Gc_peer_ids -> Some () | _ -> None) + (fun () -> Gc_peer_ids) ; + case ~tag:15 (branch_encoding "swap_request_received" + (obj1 (req "source" Peer_id.encoding))) + (function + | Swap_request_received { source } -> Some source + | _ -> None) + (fun source -> Swap_request_received { source }) ; + case ~tag:16 (branch_encoding "swap_ack_received" + (obj1 (req "source" Peer_id.encoding))) + (function + | Swap_ack_received { source } -> Some source + | _ -> None) + (fun source -> Swap_ack_received { source }) ; + case ~tag:17 (branch_encoding "swap_request_sent" + (obj1 (req "source" Peer_id.encoding))) + (function + | Swap_request_sent { source } -> Some source + | _ -> None) + (fun source -> Swap_request_sent { source }) ; + case ~tag:18 (branch_encoding "swap_ack_sent" + (obj1 (req "source" Peer_id.encoding))) + (function + | Swap_ack_sent { source } -> Some source + | _ -> None) + (fun source -> Swap_ack_sent { source }) ; + case ~tag:19 (branch_encoding "swap_request_ignored" + (obj1 (req "source" Peer_id.encoding))) + (function + | Swap_request_ignored { source } -> Some source + | _ -> None) + (fun source -> Swap_request_ignored { source }) ; + case ~tag:20 (branch_encoding "swap_success" + (obj1 (req "source" Peer_id.encoding))) + (function + | Swap_success { source } -> Some source + | _ -> None) + (fun source -> Swap_success { source }) ; + case ~tag:21 (branch_encoding "swap_failure" + (obj1 (req "source" Peer_id.encoding))) + (function + | Swap_failure { source } -> Some source + | _ -> None) + (fun source -> Swap_failure { source }) ; + ] + +end diff --git a/lib_node_net/p2p_types.mli b/lib_node_p2p_base/p2p_types.mli similarity index 50% rename from lib_node_net/p2p_types.mli rename to lib_node_p2p_base/p2p_types.mli index 101602c1d..a529c598c 100644 --- a/lib_node_net/p2p_types.mli +++ b/lib_node_p2p_base/p2p_types.mli @@ -19,7 +19,7 @@ module Version : sig val pp : Format.formatter -> t -> unit val encoding : t Data_encoding.t - val common: t list -> t list -> t option + val common : t list -> t list -> t option end @@ -36,10 +36,13 @@ val addr_encoding : addr Data_encoding.t (** Point, i.e. socket address *) module Point : sig + type t = addr * port val compare : t -> t -> int + val pp : Format.formatter -> t -> unit val pp_opt : Format.formatter -> t option -> unit + val of_string_exn : string -> t val of_string : string -> (t, string) result val to_string : t -> string @@ -47,9 +50,11 @@ module Point : sig val is_local : t -> bool val is_global : t -> bool val parse_addr_port : string -> string * string + module Map : Map.S with type key = t module Set : Set.S with type elt = t module Table : Hashtbl.S with type key = t + end (** Point representing a reachable socket address *) @@ -112,7 +117,7 @@ module Stat : sig } val empty : t - val pp: Format.formatter -> t -> unit + val pp : Format.formatter -> t -> unit val encoding : t Data_encoding.t end @@ -128,7 +133,131 @@ module Connection_info : sig versions : Version.t list ; } - val pp: Format.formatter -> t -> unit + val pp : Format.formatter -> t -> unit val encoding : t Data_encoding.t end + +(** Pool-level events *) + +module Connection_pool_log_event : sig + + type t = + + | Too_few_connections + | Too_many_connections + + | New_point of Point.t + | New_peer of Peer_id.t + + | Gc_points + (** Garbage collection of known point table has been triggered. *) + + | Gc_peer_ids + (** Garbage collection of known peer_ids table has been triggered. *) + + (* Connection-level events *) + + | Incoming_connection of Point.t + (** We accept(2)-ed an incoming connection *) + | Outgoing_connection of Point.t + (** We connect(2)-ed to a remote endpoint *) + | Authentication_failed of Point.t + (** Remote point failed authentication *) + + | Accepting_request of Point.t * Id_point.t * Peer_id.t + (** We accepted a connection after authentifying the remote peer. *) + | Rejecting_request of Point.t * Id_point.t * Peer_id.t + (** We rejected a connection after authentifying the remote peer. *) + | Request_rejected of Point.t * (Id_point.t * Peer_id.t) option + (** The remote peer rejected our connection. *) + + | Connection_established of Id_point.t * Peer_id.t + (** We succesfully established a authentified connection. *) + + | Swap_request_received of { source : Peer_id.t } + (** A swap request has been received. *) + | Swap_ack_received of { source : Peer_id.t } + (** A swap ack has been received *) + | Swap_request_sent of { source : Peer_id.t } + (** A swap request has been sent *) + | Swap_ack_sent of { source : Peer_id.t } + (** A swap ack has been sent *) + | Swap_request_ignored of { source : Peer_id.t } + (** A swap request has been ignored *) + | Swap_success of { source : Peer_id.t } + (** A swap operation has succeeded *) + | Swap_failure of { source : Peer_id.t } + (** A swap operation has failed *) + + | Disconnection of Peer_id.t + (** We decided to close the connection. *) + | External_disconnection of Peer_id.t + (** The connection was closed for external reason. *) + + val encoding : t Data_encoding.t + +end + +module Point_state : sig + + type t = + | Requested + | Accepted of Peer_id.t + | Running of Peer_id.t + | Disconnected + + val pp_digram : Format.formatter -> t -> unit + val encoding : t Data_encoding.t + +end + +module Point_info : sig + + type t = { + trusted : bool ; + greylisted_until : Time.t ; + state : Point_state.t ; + last_failed_connection : Time.t option ; + last_rejected_connection : (Peer_id.t * Time.t) option ; + last_established_connection : (Peer_id.t * Time.t) option ; + last_disconnection : (Peer_id.t * Time.t) option ; + last_seen : (Peer_id.t * Time.t) option ; + last_miss : Time.t option ; + } + + val encoding : t Data_encoding.t + +end + +module Peer_state : sig + + type t = + | Accepted + | Running + | Disconnected + + val pp_digram : Format.formatter -> t -> unit + val encoding : t Data_encoding.t + +end + +module Peer_info : sig + + type t = { + score : float ; + trusted : bool ; + state : Peer_state.t ; + id_point : Id_point.t option ; + stat : Stat.t ; + last_failed_connection : (Id_point.t * Time.t) option ; + last_rejected_connection : (Id_point.t * Time.t) option ; + last_established_connection : (Id_point.t * Time.t) option ; + last_disconnection : (Id_point.t * Time.t) option ; + last_seen : (Id_point.t * Time.t) option ; + last_miss : (Id_point.t * Time.t) option ; + } + val encoding : t Data_encoding.t + +end + diff --git a/lib_node_p2p_base/tezos-node-p2p-base.opam b/lib_node_p2p_base/tezos-node-p2p-base.opam new file mode 100644 index 000000000..679f3f4c2 --- /dev/null +++ b/lib_node_p2p_base/tezos-node-p2p-base.opam @@ -0,0 +1,21 @@ +opam-version: "1.2" +version: "dev" +maintainer: "contact@tezos.com" +authors: [ "Tezos devteam" ] +homepage: "https://www.tezos.com/" +bug-reports: "https://gitlab.com/tezos/tezos/issues" +dev-repo: "https://gitlab.com/tezos/tezos.git" +license: "unreleased" +depends: [ + "ocamlfind" { build } + "jbuilder" { build & >= "1.0+beta15" } + "base-bigarray" + "mtime.clock.os" + "ocplib-resto-cohttp" +] +build: [ + [ "jbuilder" "build" "-p" name "-j" jobs ] +] +build-test: [ + [ "jbuilder" "runtest" "-p" name "-j" jobs ] +] diff --git a/lib_node_net/RPC.ml b/lib_node_services/RPC.ml similarity index 88% rename from lib_node_net/RPC.ml rename to lib_node_services/RPC.ml index 3005b3771..0656d0c22 100644 --- a/lib_node_net/RPC.ml +++ b/lib_node_services/RPC.ml @@ -135,14 +135,10 @@ module Data = struct end include Resto -include RestoDirectory -module Directory = RestoDirectory.MakeDirectory(Data) -module Service = Directory.Service - +module Service = Resto.MakeService(Data) (* Compatibility layer, to be removed ASAP. *) -type 'a directory = 'a Directory.t type ('prefix, 'params, 'input, 'output) service = ([ `POST ], 'prefix, 'params, unit, 'input, 'output, unit) Service.t @@ -157,20 +153,6 @@ let service ?description ~input ~output path = type directory_descr = Data_encoding.json_schema Description.directory -let empty = Directory.empty -let register d s f = Directory.register d s (fun p () i -> f p i) - -open Directory.Curry -let register0 root s f = register root s (curry Z f) -let register1 root s f = register root s (curry (S Z) f) -let register2 root s f = register root s (curry (S (S Z)) f) -(* let register3 root s f = register root s (curry (S (S (S Z))) f) *) -(* let register4 root s f = register root s (curry (S (S (S (S Z)))) f) *) -(* let register5 root s f = register root s (curry (S (S (S (S (S Z))))) f) *) - -let register_dynamic_directory1 = - Directory.register_dynamic_directory1 - let forge_request (type i) (service: (_,_,_,_,i,_,_) Service.t) params body = let { Service.meth ; path } = Service.forge_request service params () in diff --git a/lib_node_net/RPC.mli b/lib_node_services/RPC.mli similarity index 56% rename from lib_node_net/RPC.mli rename to lib_node_services/RPC.mli index 8cca91fef..cbc5a257f 100644 --- a/lib_node_net/RPC.mli +++ b/lib_node_services/RPC.mli @@ -13,13 +13,10 @@ module Data : Resto.ENCODING with type 'a t = 'a Data_encoding.t and type schema = Data_encoding.json_schema include (module type of struct include Resto end) -include (module type of struct include RestoDirectory end) -module Directory : (module type of struct include RestoDirectory.MakeDirectory(Data) end) -module Service : (module type of struct include Directory.Service end) +module Service : (module type of struct include Resto.MakeService(Data) end) (** Compatibility layer, to be removed ASAP. *) -type 'a directory = 'a Directory.t type ('prefix, 'params, 'input, 'output) service = ([ `POST ], 'prefix, 'params, unit, 'input, 'output, unit) Service.t @@ -32,38 +29,6 @@ val service: type directory_descr = Data_encoding.json_schema Description.directory -val empty: 'a directory -val register: - 'prefix directory -> - ('prefix, 'params, 'input, 'output) service -> - ('params -> 'input -> [< ('output, unit) RestoDirectory.Answer.t ] Lwt.t) -> - 'prefix directory - -val register0: - unit directory -> - (unit, unit, 'i, 'o) service -> - ('i -> [< ('o, unit) Answer.t ] Lwt.t) -> - unit directory - -val register1: - 'prefix directory -> - ('prefix, unit * 'a, 'i, 'o) service -> - ('a -> 'i -> [< ('o, unit) Answer.t ] Lwt.t) -> - 'prefix directory - -val register2: - 'prefix directory -> - ('prefix, (unit * 'a) * 'b, 'i, 'o) service -> - ('a -> 'b -> 'i -> [< ('o, unit) Answer.t ] Lwt.t) -> - 'prefix directory - -val register_dynamic_directory1: - ?descr:string -> - 'prefix directory -> - ('prefix, unit * 'a) Path.path -> - ('a -> (unit * 'a) directory Lwt.t) -> - 'prefix directory - val forge_request: (unit, 'params, 'input, _) service -> 'params -> 'input -> MethMap.key * string list * Data_encoding.json diff --git a/lib_node_services/jbuild b/lib_node_services/jbuild new file mode 100644 index 000000000..e85a26684 --- /dev/null +++ b/lib_node_services/jbuild @@ -0,0 +1,17 @@ +(jbuild_version 1) + +(library + ((name tezos_node_services) + (public_name tezos-node-services) + (libraries (tezos-base + tezos-node-p2p-base + ocplib-resto)) + (flags (:standard -w -9+27-30-32-40@8 + -safe-string + -open Tezos_base__TzPervasives + -open Tezos_node_p2p_base)))) + +(alias + ((name runtest_indent) + (deps ((glob_files *.ml) (glob_files *.mli))) + (action (run bash ${libexec:tezos-stdlib:test-ocp-indent.sh} ${<})))) diff --git a/lib_node_shell/node_rpc_services.ml b/lib_node_services/node_rpc_services.ml similarity index 94% rename from lib_node_shell/node_rpc_services.ml rename to lib_node_services/node_rpc_services.ml index 13c52e582..ac372baf3 100644 --- a/lib_node_shell/node_rpc_services.ml +++ b/lib_node_services/node_rpc_services.ml @@ -69,7 +69,7 @@ module Blocks = struct data: MBytes.t ; operations: (Operation_hash.t * Operation.t) list list option ; protocol: Protocol_hash.t ; - test_network: Context.test_network; + test_network: Test_network_status.t ; } let block_info_encoding = @@ -104,7 +104,7 @@ module Blocks = struct (opt "operations" (dynamic_size (list (dynamic_size (list (dynamic_size operation_encoding)))))) (req "protocol" Protocol_hash.encoding) (dft "test_network" - Context.test_network_encoding Context.Not_running)) + Test_network_status.encoding Not_running)) Block_header.encoding)) let parse_block s = @@ -243,7 +243,7 @@ module Blocks = struct RPC.service ~description:"Returns the status of the associated test network." ~input: empty - ~output: Context.test_network_encoding + ~output: Test_network_status.encoding RPC.Path.(block_path / "test_network") let pending_operations = @@ -259,7 +259,8 @@ module Blocks = struct ~output: (conv (fun (preapplied, unprocessed) -> - ({ preapplied with Prevalidation.refused = Operation_hash.Map.empty }, + ({ preapplied with + Preapply_result.refused = Operation_hash.Map.empty }, Operation_hash.Map.bindings unprocessed)) (fun (preapplied, unprocessed) -> (preapplied, @@ -268,7 +269,7 @@ module Blocks = struct unprocessed Operation_hash.Map.empty)) (merge_objs (dynamic_size - (Prevalidation.preapply_result_encoding Error.encoding)) + (Preapply_result.encoding Error.encoding)) (obj1 (req "unprocessed" (list (dynamic_size operation_encoding)))))) RPC.Path.(block_path / "pending_operations") @@ -296,7 +297,7 @@ module Blocks = struct type preapply_result = { shell_header: Block_header.shell_header ; - operations: error Prevalidation.preapply_result ; + operations: error Preapply_result.t ; } let preapply_result_encoding = @@ -308,7 +309,7 @@ module Blocks = struct (obj2 (req "shell_header" Block_header.shell_header_encoding) (req "operations" - (Prevalidation.preapply_result_encoding Error.encoding)))) + (Preapply_result.encoding Error.encoding)))) let preapply = RPC.service @@ -498,21 +499,21 @@ module Network = struct RPC.service ~description:"Supported network layer versions." ~input: empty - ~output: (list P2p.Version.encoding) + ~output: (list P2p_types.Version.encoding) RPC.Path.(root / "network" / "versions") let stat = RPC.service ~description:"Global network bandwidth statistics in B/s." ~input: empty - ~output: P2p.Stat.encoding + ~output: P2p_types.Stat.encoding RPC.Path.(root / "network" / "stat") let events = RPC.service ~description:"Stream of all network events" ~input: empty - ~output: P2p.RPC.Event.encoding + ~output: P2p_types.Connection_pool_log_event.encoding RPC.Path.(root / "network" / "log") let connect = @@ -530,13 +531,13 @@ module Network = struct RPC.service ~description:"List the running P2P connection." ~input: empty - ~output: (list P2p.Connection_info.encoding) + ~output: (list P2p_types.Connection_info.encoding) RPC.Path.(root / "network" / "connection") let info = RPC.service ~input: empty - ~output: (option P2p.Connection_info.encoding) + ~output: (option P2p_types.Connection_info.encoding) ~description:"Details about the current P2P connection to the given peer." RPC.Path.(root / "network" / "connection" /: peer_id_arg) @@ -554,23 +555,26 @@ module Network = struct let info = RPC.service ~input: empty - ~output: (option P2p.RPC.Point.info_encoding) + ~output: (option P2p_types.Point_info.encoding) ~description: "Details about a given `IP:addr`." RPC.Path.(root / "network" / "point" /: point_arg) let events = RPC.service ~input: monitor_encoding - ~output: (list P2p.RPC.Point.Event.encoding) + ~output: (list P2p_connection_pool_types.Point_info.Event.encoding) ~description: "Monitor network events related to an `IP:addr`." RPC.Path.(root / "network" / "point" /: point_arg / "log") let list = let filter = - obj1 (dft "filter" (list P2p.RPC.Point.state_encoding) []) in + obj1 (dft "filter" (list P2p_types.Point_state.encoding) []) in RPC.service ~input: filter - ~output: (list (tup2 P2p.Point.encoding P2p.RPC.Point.info_encoding)) + ~output: + (list (tup2 + P2p_types.Point.encoding + P2p_types.Point_info.encoding)) ~description:"List the pool of known `IP:port` \ used for establishing P2P connections ." RPC.Path.(root / "network" / "point") @@ -582,23 +586,26 @@ module Network = struct let info = RPC.service ~input: empty - ~output: (option P2p.RPC.Peer_id.info_encoding) + ~output: (option P2p_types.Peer_info.encoding) ~description:"Details about a given peer." RPC.Path.(root / "network" / "peer_id" /: peer_id_arg) let events = RPC.service ~input: monitor_encoding - ~output: (list P2p.RPC.Peer_id.Event.encoding) + ~output: (list P2p_connection_pool_types.Peer_info.Event.encoding) ~description:"Monitor network events related to a given peer." RPC.Path.(root / "network" / "peer_id" /: peer_id_arg / "log") let list = let filter = - obj1 (dft "filter" (list P2p.RPC.Peer_id.state_encoding) []) in + obj1 (dft "filter" (list P2p_types.Peer_state.encoding) []) in RPC.service ~input: filter - ~output: (list (tup2 P2p.Peer_id.encoding P2p.RPC.Peer_id.info_encoding)) + ~output: + (list (tup2 + P2p_types.Peer_id.encoding + P2p_types.Peer_info.encoding)) ~description:"List the peers the node ever met." RPC.Path.(root / "network" / "peer_id") diff --git a/lib_node_shell/node_rpc_services.mli b/lib_node_services/node_rpc_services.mli similarity index 77% rename from lib_node_shell/node_rpc_services.mli rename to lib_node_services/node_rpc_services.mli index 6571207f6..e83d83995 100644 --- a/lib_node_shell/node_rpc_services.mli +++ b/lib_node_services/node_rpc_services.mli @@ -39,7 +39,7 @@ module Blocks : sig data: MBytes.t ; operations: (Operation_hash.t * Operation.t) list list option ; protocol: Protocol_hash.t ; - test_network: Context.test_network; + test_network: Test_network_status.t ; } val info: @@ -70,10 +70,10 @@ module Blocks : sig val protocol: (unit, unit * block, unit, Protocol_hash.t) RPC.service val test_network: - (unit, unit * block, unit, Context.test_network) RPC.service + (unit, unit * block, unit, Test_network_status.t) RPC.service val pending_operations: (unit, unit * block, unit, - error Prevalidation.preapply_result * Operation.t Operation_hash.Map.t) RPC.service + error Preapply_result.t * Operation.t Operation_hash.Map.t) RPC.service type list_param = { include_ops: bool ; @@ -99,7 +99,7 @@ module Blocks : sig type preapply_result = { shell_header: Block_header.shell_header ; - operations: error Prevalidation.preapply_result ; + operations: error Preapply_result.t ; } val preapply: (unit, unit * block, preapply_param, preapply_result tzresult) RPC.service @@ -131,44 +131,56 @@ end module Network : sig val stat : - (unit, unit, unit, P2p.Stat.t) RPC.service + (unit, unit, unit, P2p_types.Stat.t) RPC.service val versions : - (unit, unit, unit, P2p.Version.t list) RPC.service + (unit, unit, unit, P2p_types.Version.t list) RPC.service val events : - (unit, unit, unit, P2p.RPC.Event.t) RPC.service + (unit, unit, unit, P2p_types.Connection_pool_log_event.t) RPC.service val connect : - (unit, unit * P2p.Point.t, float, unit tzresult) RPC.service + (unit, unit * P2p_types.Point.t, float, unit tzresult) RPC.service module Connection : sig + val list : - (unit, unit, unit, P2p.Connection_info.t list) RPC.service + (unit, unit, unit, P2p_types.Connection_info.t list) RPC.service + val info : - (unit, unit * P2p.Peer_id.t, unit, P2p.Connection_info.t option) RPC.service + (unit, unit * P2p_types.Peer_id.t, unit, + P2p_types.Connection_info.t option) RPC.service + val kick : - (unit, unit * P2p.Peer_id.t, bool, unit) RPC.service + (unit, unit * P2p_types.Peer_id.t, bool, unit) RPC.service + end module Point : sig val list : - (unit, unit, P2p.RPC.Point.state list, - (P2p.Point.t * P2p.RPC.Point.info) list) RPC.service + (unit, unit, P2p_types.Point_state.t list, + (P2p_types.Point.t * P2p_types.Point_info.t) list) RPC.service val info : - (unit, unit * P2p.Point.t, unit, P2p.RPC.Point.info option) RPC.service + (unit, unit * P2p_types.Point.t, unit, P2p_types.Point_info.t option) RPC.service val events : - (unit, unit * P2p.Point.t, bool, P2p.RPC.Point.Event.t list) RPC.service + (unit, unit * P2p_types.Point.t, bool, + P2p_connection_pool_types.Point_info.Event.t list) RPC.service end module Peer_id : sig + val list : - (unit, unit, P2p.RPC.Peer_id.state list, - (P2p.Peer_id.t * P2p.RPC.Peer_id.info) list) RPC.service + (unit, unit, P2p_types.Peer_state.t list, + (P2p_types.Peer_id.t * P2p_types.Peer_info.t) list) RPC.service + val info : - (unit, unit * P2p.Peer_id.t, unit, P2p.RPC.Peer_id.info option) RPC.service + (unit, unit * P2p_types.Peer_id.t, unit, + P2p_types.Peer_info.t option) RPC.service + val events : - (unit, unit * P2p.Peer_id.t, bool, P2p.RPC.Peer_id.Event.t list) RPC.service + (unit, unit * P2p_types.Peer_id.t, bool, + P2p_connection_pool_types.Peer_info.Event.t list) RPC.service + end end diff --git a/lib_node_services/tezos-node-services.opam b/lib_node_services/tezos-node-services.opam new file mode 100644 index 000000000..679f3f4c2 --- /dev/null +++ b/lib_node_services/tezos-node-services.opam @@ -0,0 +1,21 @@ +opam-version: "1.2" +version: "dev" +maintainer: "contact@tezos.com" +authors: [ "Tezos devteam" ] +homepage: "https://www.tezos.com/" +bug-reports: "https://gitlab.com/tezos/tezos/issues" +dev-repo: "https://gitlab.com/tezos/tezos.git" +license: "unreleased" +depends: [ + "ocamlfind" { build } + "jbuilder" { build & >= "1.0+beta15" } + "base-bigarray" + "mtime.clock.os" + "ocplib-resto-cohttp" +] +build: [ + [ "jbuilder" "build" "-p" name "-j" jobs ] +] +build-test: [ + [ "jbuilder" "runtest" "-p" name "-j" jobs ] +] diff --git a/lib_node_shell/jbuild b/lib_node_shell/jbuild index 180b11da3..e85c4780d 100644 --- a/lib_node_shell/jbuild +++ b/lib_node_shell/jbuild @@ -5,13 +5,18 @@ (public_name tezos-node-shell) (libraries (tezos-base tezos-storage - tezos-node-net + tezos-node-services + tezos-node-p2p-base + tezos-node-p2p tezos-node-updater)) (flags (:standard -w -9+27-30-32-40@8 -safe-string -open Tezos_base__TzPervasives -open Tezos_storage - -open Tezos_node_net + -open Tezos_node_services + -open Tezos_node_http + -open Tezos_node_p2p_base + -open Tezos_node_p2p -open Tezos_node_updater)))) (alias diff --git a/lib_node_shell/node.ml b/lib_node_shell/node.ml index aa3373379..9ac59d7ae 100644 --- a/lib_node_shell/node.ml +++ b/lib_node_shell/node.ml @@ -152,7 +152,7 @@ module RPC = struct data: MBytes.t ; operations: (Operation_hash.t * Operation.t) list list option ; protocol: Protocol_hash.t ; - test_network: Context.test_network; + test_network: Test_network_status.t ; } let convert (block: State.Block.t) = @@ -377,7 +377,7 @@ module RPC = struct | (`Prevalidation | `Test_prevalidation) as block -> let validator = get_validator node block in let pv = Net_validator.prevalidator validator in - let { Prevalidation.applied }, _ = Prevalidator.operations pv in + let { Preapply_result.applied }, _ = Prevalidator.operations pv in Lwt.return [List.map fst applied] | `Hash hash -> read_valid_block node hash >>= function @@ -398,7 +398,7 @@ module RPC = struct | (`Prevalidation | `Test_prevalidation) as block -> let validator = get_validator node block in let pv = Net_validator.prevalidator validator in - let { Prevalidation.applied }, _ = Prevalidator.operations pv in + let { Preapply_result.applied }, _ = Prevalidator.operations pv in Lwt.return [List.map snd applied] | `Hash hash -> read_valid_block node hash >>= function @@ -421,24 +421,24 @@ module RPC = struct Chain.head net_state >>= fun head -> predecessor net_db n head >>= fun b -> Prevalidator.pending ~block:b prevalidator >|= fun ops -> - Prevalidation.empty_result, ops + Preapply_result.empty, ops | `Genesis -> let net_state = Net_validator.net_state node.mainnet_validator in let prevalidator = Net_validator.prevalidator node.mainnet_validator in Chain.genesis net_state >>= fun b -> Prevalidator.pending ~block:b prevalidator >|= fun ops -> - Prevalidation.empty_result, ops + Preapply_result.empty, ops | `Hash h -> begin get_validator_per_hash node h >>= function | None -> - Lwt.return (Prevalidation.empty_result, Operation_hash.Map.empty) + Lwt.return (Preapply_result.empty, Operation_hash.Map.empty) | Some validator -> let net_state = Net_validator.net_state validator in let prevalidator = Net_validator.prevalidator validator in State.Block.read_exn net_state h >>= fun block -> Prevalidator.pending ~block prevalidator >|= fun ops -> - Prevalidation.empty_result, ops + Preapply_result.empty, ops end let protocols { state } = @@ -522,8 +522,8 @@ module RPC = struct | Some rpc_context -> Context.get_protocol rpc_context.context >>= fun protocol_hash -> let (module Proto) = State.Registred_protocol.get_exn protocol_hash in - let dir = RPC.Directory.map (fun () -> rpc_context) Proto.rpc_services in - Lwt.return (Some (RPC.Directory.map (fun _ -> ()) dir)) + let dir = RPC_server.Directory.map (fun () -> rpc_context) Proto.rpc_services in + Lwt.return (Some (RPC_server.Directory.map (fun _ -> ()) dir)) let heads node = let net_state = Net_validator.net_state node.mainnet_validator in @@ -627,7 +627,7 @@ module RPC = struct ] end in let shutdown () = Lwt_watcher.shutdown stopper in - RPC.Answer.{ next ; shutdown } + RPC_server.Answer.{ next ; shutdown } module Network = struct @@ -661,11 +661,11 @@ module RPC = struct let info (node : t) = P2p.RPC.Point.info node.p2p - let list (node : t) restrict = - P2p.RPC.Point.list ~restrict node.p2p + let list ?restrict (node : t) = + P2p.RPC.Point.list ?restrict node.p2p - let events (node : t) = - P2p.RPC.Point.events node.p2p + let events ?max ?rev (node : t) = + P2p.RPC.Point.events node.p2p ?max ?rev let watch (node : t) = P2p.RPC.Point.watch node.p2p @@ -677,11 +677,11 @@ module RPC = struct let info (node : t) = P2p.RPC.Peer_id.info node.p2p - let list (node : t) restrict = - P2p.RPC.Peer_id.list ~restrict node.p2p + let list ?restrict (node : t) = + P2p.RPC.Peer_id.list ?restrict node.p2p - let events (node : t) = - P2p.RPC.Peer_id.events node.p2p + let events ?max ?rev (node : t) = + P2p.RPC.Peer_id.events node.p2p ?max ?rev let watch (node : t) = P2p.RPC.Peer_id.watch node.p2p diff --git a/lib_node_shell/node.mli b/lib_node_shell/node.mli index eb504d335..1a1565981 100644 --- a/lib_node_shell/node.mli +++ b/lib_node_shell/node.mli @@ -78,7 +78,8 @@ module RPC : sig t -> (Operation_hash.t * Operation.t) Lwt_stream.t * Lwt_watcher.stopper val pending_operations: - t -> block -> (error Prevalidation.preapply_result * Operation.t Operation_hash.Map.t) Lwt.t + t -> block -> + (error Preapply_result.t * Operation.t Operation_hash.Map.t) Lwt.t val protocols: t -> Protocol_hash.t list Lwt.t @@ -88,52 +89,78 @@ module RPC : sig t -> (Protocol_hash.t * Protocol.t) Lwt_stream.t * Lwt_watcher.stopper val context_dir: - t -> block -> 'a RPC.directory option Lwt.t + t -> block -> 'a RPC_server.directory option Lwt.t val preapply: t -> block -> timestamp:Time.t -> proto_header:MBytes.t -> sort_operations:bool -> Operation.t list -> - (Block_header.shell_header * error Prevalidation.preapply_result) tzresult Lwt.t + (Block_header.shell_header * error Preapply_result.t) tzresult Lwt.t val context_dir: - t -> block -> 'a RPC.directory option Lwt.t + t -> block -> 'a RPC_server.directory option Lwt.t val complete: t -> ?block:block -> string -> string list Lwt.t val bootstrapped: - t -> (Block_hash.t * Time.t) RPC.Answer.stream + t -> (Block_hash.t * Time.t) RPC_server.Answer.stream module Network : sig - val stat : t -> P2p.Stat.t - val watch : t -> P2p.RPC.Event.t Lwt_stream.t * Lwt_watcher.stopper - val connect : t -> P2p.Point.t -> float -> unit tzresult Lwt.t + open P2p_types + + val stat : t -> Stat.t + + val watch : + t -> + P2p_types.Connection_pool_log_event.t Lwt_stream.t * Lwt_watcher.stopper + val connect : t -> Point.t -> float -> unit tzresult Lwt.t module Connection : sig - val info : t -> P2p.Peer_id.t -> P2p.Connection_info.t option - val kick : t -> P2p.Peer_id.t -> bool -> unit Lwt.t - val list : t -> P2p.Connection_info.t list + val info : t -> Peer_id.t -> Connection_info.t option + val kick : t -> Peer_id.t -> bool -> unit Lwt.t + val list : t -> Connection_info.t list val count : t -> int end - module Peer_id : sig - val list : t -> - P2p.RPC.Peer_id.state list -> (P2p.Peer_id.t * P2p.RPC.Peer_id.info) list - val info : t -> P2p.Peer_id.t -> P2p.RPC.Peer_id.info option - val events : t -> P2p.Peer_id.t -> P2p.RPC.Peer_id.Event.t list - val watch : t -> P2p.Peer_id.t -> - P2p.RPC.Peer_id.Event.t Lwt_stream.t * Lwt_watcher.stopper + module Point : sig + + val info : + t -> Point.t -> P2p_types.Point_info.t option + + val list : + ?restrict: P2p_types.Point_state.t list -> + t -> (Point.t * P2p_types.Point_info.t) list + + val events : + ?max:int -> ?rev:bool -> t -> Point.t -> + P2p_connection_pool_types.Point_info.Event.t list + + val watch : + t -> Point.t -> + P2p_connection_pool_types.Point_info.Event.t Lwt_stream.t * Lwt_watcher.stopper + end - module Point : sig - val list : t -> - P2p.RPC.Point.state list -> (P2p.Point.t * P2p.RPC.Point.info) list - val info : t -> P2p.Point.t -> P2p.RPC.Point.info option - val events : t -> P2p.Point.t -> P2p.RPC.Point.Event.t list - val watch : t -> P2p.Point.t -> - P2p.RPC.Point.Event.t Lwt_stream.t * Lwt_watcher.stopper + module Peer_id : sig + + val info : + t -> Peer_id.t -> P2p_types.Peer_info.t option + + val list : + ?restrict: P2p_types.Peer_state.t list -> + t -> (Peer_id.t * P2p_types.Peer_info.t) list + + val events : + ?max: int -> ?rev: bool -> + t -> Peer_id.t -> + P2p_connection_pool_types.Peer_info.Event.t list + + val watch : + t -> Peer_id.t -> + P2p_connection_pool_types.Peer_info.Event.t Lwt_stream.t * Lwt_watcher.stopper + end end diff --git a/lib_node_shell/node_rpc.ml b/lib_node_shell/node_rpc.ml index d2120e96a..1333c942b 100644 --- a/lib_node_shell/node_rpc.ml +++ b/lib_node_shell/node_rpc.ml @@ -36,70 +36,70 @@ let monitor_operations node contents = Lwt.return_some @@ List.map (List.map (fun h -> h, None)) hashes end in - RPC.Answer.return_stream { next ; shutdown } + RPC_server.Answer.return_stream { next ; shutdown } let register_bi_dir node dir = let dir = let implementation b include_ops = Node.RPC.block_info node b >>= fun bi -> - RPC.Answer.return (filter_bi include_ops bi) in - RPC.register1 dir + RPC_server.Answer.return (filter_bi include_ops bi) in + RPC_server.register1 dir Services.Blocks.info implementation in let dir = let implementation b () = Node.RPC.block_info node b >>= fun bi -> - RPC.Answer.return bi.hash in - RPC.register1 dir + RPC_server.Answer.return bi.hash in + RPC_server.register1 dir Services.Blocks.hash implementation in let dir = let implementation b () = Node.RPC.block_info node b >>= fun bi -> - RPC.Answer.return bi.net_id in - RPC.register1 dir + RPC_server.Answer.return bi.net_id in + RPC_server.register1 dir Services.Blocks.net_id implementation in let dir = let implementation b () = Node.RPC.block_info node b >>= fun bi -> - RPC.Answer.return bi.level in - RPC.register1 dir + RPC_server.Answer.return bi.level in + RPC_server.register1 dir Services.Blocks.level implementation in let dir = let implementation b () = Node.RPC.block_info node b >>= fun bi -> - RPC.Answer.return bi.predecessor in - RPC.register1 dir + RPC_server.Answer.return bi.predecessor in + RPC_server.register1 dir Services.Blocks.predecessor implementation in let dir = let implementation b len = Node.RPC.block_info node b >>= fun bi -> Node.RPC.predecessors node len bi.hash >>= fun hashes -> - RPC.Answer.return hashes in - RPC.register1 dir + RPC_server.Answer.return hashes in + RPC_server.register1 dir Services.Blocks.predecessors implementation in let dir = let implementation b () = Node.RPC.block_info node b >>= fun bi -> - RPC.Answer.return bi.fitness in - RPC.register1 dir + RPC_server.Answer.return bi.fitness in + RPC_server.register1 dir Services.Blocks.fitness implementation in let dir = let implementation b () = Node.RPC.block_info node b >>= fun bi -> - RPC.Answer.return bi.timestamp in - RPC.register1 dir + RPC_server.Answer.return bi.timestamp in + RPC_server.register1 dir Services.Blocks.timestamp implementation in let dir = let implementation b () = Node.RPC.block_info node b >>= fun bi -> - RPC.Answer.return bi.protocol in - RPC.register1 dir + RPC_server.Answer.return bi.protocol in + RPC_server.register1 dir Services.Blocks.protocol implementation in let dir = let implementation b () = Node.RPC.block_info node b >>= fun bi -> - RPC.Answer.return bi.test_network in - RPC.register1 dir + RPC_server.Answer.return bi.test_network in + RPC_server.register1 dir Services.Blocks.test_network implementation in let dir = let implementation b { Node_rpc_services.Blocks.contents ; monitor } = @@ -110,19 +110,19 @@ let register_bi_dir node dir = Node.RPC.operation_hashes node b >>= fun hashes -> if contents then Node.RPC.operations node b >>= fun ops -> - RPC.Answer.return @@ + RPC_server.Answer.return @@ List.map2 (List.map2 (fun h op -> h, Some op)) hashes ops else - RPC.Answer.return @@ + RPC_server.Answer.return @@ List.map (List.map (fun h -> h, None)) hashes in - RPC.register1 dir + RPC_server.register1 dir Services.Blocks.operations implementation in let dir = let implementation b () = Node.RPC.pending_operations node b >>= fun res -> - RPC.Answer.return res in - RPC.register1 dir + RPC_server.Answer.return res in + RPC_server.register1 dir Services.Blocks.pending_operations implementation in let dir = @@ -132,15 +132,15 @@ let register_bi_dir node dir = Node.RPC.preapply node b ~timestamp ~proto_header ~sort_operations operations >>= function | Ok (shell_header, operations) -> - RPC.Answer.return + RPC_server.Answer.return (Ok { Services.Blocks.shell_header ; operations }) - | Error _ as err -> RPC.Answer.return err in - RPC.register1 dir + | Error _ as err -> RPC_server.Answer.return err in + RPC_server.register1 dir Services.Blocks.preapply implementation in dir let ops_dir _node = - let ops_dir = RPC.empty in + let ops_dir = RPC_server.empty in ops_dir let rec insert_future_block (bi: Services.Blocks.block_info) = function @@ -303,7 +303,7 @@ let list_blocks List.map (List.map (filter_bi include_ops)) requested_blocks in - RPC.Answer.return infos + RPC_server.Answer.return infos else begin let (bi_stream, stopper) = Node.RPC.block_watcher node in let stream = @@ -325,12 +325,12 @@ let list_blocks List.map (List.map (filter_bi include_ops)) requested_blocks in Lwt.return (Some infos) end in - RPC.Answer.return_stream { next ; shutdown } + RPC_server.Answer.return_stream { next ; shutdown } end let list_invalid node () = Node.RPC.list_invalid node >>= fun l -> - RPC.Answer.return l + RPC_server.Answer.return l let list_protocols node {Services.Protocols.monitor; contents} = let monitor = match monitor with None -> false | Some x -> x in @@ -346,7 +346,7 @@ let list_protocols node {Services.Protocols.monitor; contents} = Lwt.return (hash, None)) protocols >>= fun protocols -> if not monitor then - RPC.Answer.return protocols + RPC_server.Answer.return protocols else let stream, stopper = Node.RPC.protocol_watcher node in let shutdown () = Lwt_watcher.shutdown stopper in @@ -361,19 +361,19 @@ let list_protocols node {Services.Protocols.monitor; contents} = first_request := false ; Lwt.return (Some protocols) end in - RPC.Answer.return_stream { next ; shutdown } + RPC_server.Answer.return_stream { next ; shutdown } let get_protocols node hash () = Node.RPC.protocol_content node hash >>= function - | Ok bytes -> RPC.Answer.return bytes + | Ok bytes -> RPC_server.Answer.return bytes | Error _ -> raise Not_found let build_rpc_directory node = - let dir = RPC.empty in + let dir = RPC_server.empty in let dir = - RPC.register0 dir Services.Blocks.list (list_blocks node) in + RPC_server.register0 dir Services.Blocks.list (list_blocks node) in let dir = - RPC.register0 dir Services.Blocks.list_invalid (list_invalid node) in + RPC_server.register0 dir Services.Blocks.list_invalid (list_invalid node) in let dir = register_bi_dir node dir in let dir = let implementation block = @@ -381,21 +381,21 @@ let build_rpc_directory node = Node.RPC.context_dir node block >>= function | None -> Lwt.fail Not_found | Some context_dir -> Lwt.return context_dir) - (fun _ -> Lwt.return RPC.empty) in - RPC.register_dynamic_directory1 + (fun _ -> Lwt.return RPC_server.empty) in + RPC_server.register_dynamic_directory1 ~descr: "All the RPCs which are specific to the protocol version." dir Services.Blocks.proto_path implementation in let dir = - RPC.register0 dir Services.Protocols.list (list_protocols node) in + RPC_server.register0 dir Services.Protocols.list (list_protocols node) in let dir = - RPC.register1 dir Services.Protocols.contents (get_protocols node) in + RPC_server.register1 dir Services.Protocols.contents (get_protocols node) in let dir = let implementation header = let res = Data_encoding.Binary.to_bytes Block_header.encoding header in - RPC.Answer.return res in - RPC.register0 dir Services.forge_block_header implementation in + RPC_server.Answer.return res in + RPC_server.register0 dir Services.forge_block_header implementation in let dir = let implementation { Node_rpc_services.raw ; blocking ; force ; operations } = @@ -404,88 +404,88 @@ let build_rpc_directory node = node ~force raw operations >>=? fun (hash, wait) -> (if blocking then wait else return ()) >>=? fun () -> return hash - end >>= RPC.Answer.return in - RPC.register0 dir Services.inject_block implementation in + end >>= RPC_server.Answer.return in + RPC_server.register0 dir Services.inject_block implementation in let dir = let implementation (contents, blocking, net_id, force) = Node.RPC.inject_operation node ?force ?net_id contents >>= fun (hash, wait) -> begin (if blocking then wait else return ()) >>=? fun () -> return hash - end >>= RPC.Answer.return in - RPC.register0 dir Services.inject_operation implementation in + end >>= RPC_server.Answer.return in + RPC_server.register0 dir Services.inject_operation implementation in let dir = let implementation (proto, blocking, force) = Node.RPC.inject_protocol ?force node proto >>= fun (hash, wait) -> begin (if blocking then wait else return ()) >>=? fun () -> return hash - end >>= RPC.Answer.return in - RPC.register0 dir Services.inject_protocol implementation in + end >>= RPC_server.Answer.return in + RPC_server.register0 dir Services.inject_protocol implementation in let dir = let implementation () = - RPC.Answer.return_stream (Node.RPC.bootstrapped node) in - RPC.register0 dir Services.bootstrapped implementation in + RPC_server.Answer.return_stream (Node.RPC.bootstrapped node) in + RPC_server.register0 dir Services.bootstrapped implementation in let dir = let implementation () = - RPC.Answer.return + RPC_server.Answer.return Data_encoding.Json.(schema Error_monad.error_encoding) in - RPC.register0 dir Services.Error.service implementation in + RPC_server.register0 dir Services.Error.service implementation in let dir = - RPC.register1 dir Services.complete + RPC_server.register1 dir Services.complete (fun s () -> - Node.RPC.complete node s >>= RPC.Answer.return) in + Node.RPC.complete node s >>= RPC_server.Answer.return) in let dir = - RPC.register2 dir Services.Blocks.complete + RPC_server.register2 dir Services.Blocks.complete (fun block s () -> - Node.RPC.complete node ~block s >>= RPC.Answer.return) in + Node.RPC.complete node ~block s >>= RPC_server.Answer.return) in (* Network : Global *) let dir = let implementation () = - Node.RPC.Network.stat node |> RPC.Answer.return in - RPC.register0 dir Services.Network.stat implementation in + Node.RPC.Network.stat node |> RPC_server.Answer.return in + RPC_server.register0 dir Services.Network.stat implementation in let dir = let implementation () = - RPC.Answer.return Distributed_db.Raw.supported_versions in - RPC.register0 dir Services.Network.versions implementation in + RPC_server.Answer.return Distributed_db.Raw.supported_versions in + RPC_server.register0 dir Services.Network.versions implementation in let dir = let implementation () = let stream, stopper = Node.RPC.Network.watch node in let shutdown () = Lwt_watcher.shutdown stopper in let next () = Lwt_stream.get stream in - RPC.Answer.return_stream { next ; shutdown } in - RPC.register0 dir Services.Network.events implementation in + RPC_server.Answer.return_stream { next ; shutdown } in + RPC_server.register0 dir Services.Network.events implementation in let dir = let implementation point timeout = - Node.RPC.Network.connect node point timeout >>= RPC.Answer.return in - RPC.register1 dir Services.Network.connect implementation in + Node.RPC.Network.connect node point timeout >>= RPC_server.Answer.return in + RPC_server.register1 dir Services.Network.connect implementation in (* Network : Connection *) let dir = let implementation peer_id () = - Node.RPC.Network.Connection.info node peer_id |> RPC.Answer.return in - RPC.register1 dir Services.Network.Connection.info implementation in + Node.RPC.Network.Connection.info node peer_id |> RPC_server.Answer.return in + RPC_server.register1 dir Services.Network.Connection.info implementation in let dir = let implementation peer_id wait = - Node.RPC.Network.Connection.kick node peer_id wait >>= RPC.Answer.return in - RPC.register1 dir Services.Network.Connection.kick implementation in + Node.RPC.Network.Connection.kick node peer_id wait >>= RPC_server.Answer.return in + RPC_server.register1 dir Services.Network.Connection.kick implementation in let dir = let implementation () = - Node.RPC.Network.Connection.list node |> RPC.Answer.return in - RPC.register0 dir Services.Network.Connection.list implementation in + Node.RPC.Network.Connection.list node |> RPC_server.Answer.return in + RPC_server.register0 dir Services.Network.Connection.list implementation in (* Network : Peer_id *) let dir = let implementation state = - Node.RPC.Network.Peer_id.list node state |> RPC.Answer.return in - RPC.register0 dir Services.Network.Peer_id.list implementation in + Node.RPC.Network.Peer_id.list node ~restrict:state |> RPC_server.Answer.return in + RPC_server.register0 dir Services.Network.Peer_id.list implementation in let dir = let implementation peer_id () = - Node.RPC.Network.Peer_id.info node peer_id |> RPC.Answer.return in - RPC.register1 dir Services.Network.Peer_id.info implementation in + Node.RPC.Network.Peer_id.info node peer_id |> RPC_server.Answer.return in + RPC_server.register1 dir Services.Network.Peer_id.info implementation in let dir = let implementation peer_id monitor = if monitor then @@ -499,21 +499,21 @@ let build_rpc_directory node = first_request := false ; Lwt.return_some @@ Node.RPC.Network.Peer_id.events node peer_id end in - RPC.Answer.return_stream { next ; shutdown } + RPC_server.Answer.return_stream { next ; shutdown } else - Node.RPC.Network.Peer_id.events node peer_id |> RPC.Answer.return in - RPC.register1 dir Services.Network.Peer_id.events implementation in + Node.RPC.Network.Peer_id.events node peer_id |> RPC_server.Answer.return in + RPC_server.register1 dir Services.Network.Peer_id.events implementation in (* Network : Point *) let dir = let implementation state = - Node.RPC.Network.Point.list node state |> RPC.Answer.return in - RPC.register0 dir Services.Network.Point.list implementation in + Node.RPC.Network.Point.list node ~restrict:state |> RPC_server.Answer.return in + RPC_server.register0 dir Services.Network.Point.list implementation in let dir = let implementation point () = - Node.RPC.Network.Point.info node point |> RPC.Answer.return in - RPC.register1 dir Services.Network.Point.info implementation in + Node.RPC.Network.Point.info node point |> RPC_server.Answer.return in + RPC_server.register1 dir Services.Network.Point.info implementation in let dir = let implementation point monitor = if monitor then @@ -527,10 +527,10 @@ let build_rpc_directory node = first_request := false ; Lwt.return_some @@ Node.RPC.Network.Point.events node point end in - RPC.Answer.return_stream { next ; shutdown } + RPC_server.Answer.return_stream { next ; shutdown } else - Node.RPC.Network.Point.events node point |> RPC.Answer.return in - RPC.register1 dir Services.Network.Point.events implementation in + Node.RPC.Network.Point.events node point |> RPC_server.Answer.return in + RPC_server.register1 dir Services.Network.Point.events implementation in let dir = - RPC.Directory.register_describe_directory_service dir Services.describe in + RPC_server.Directory.register_describe_directory_service dir Services.describe in dir diff --git a/lib_node_shell/node_rpc.mli b/lib_node_shell/node_rpc.mli index 31844ce52..2f7b2603f 100644 --- a/lib_node_shell/node_rpc.mli +++ b/lib_node_shell/node_rpc.mli @@ -7,4 +7,4 @@ (* *) (**************************************************************************) -val build_rpc_directory: Node.t -> unit RPC.directory +val build_rpc_directory: Node.t -> unit RPC_server.directory diff --git a/lib_node_shell/prevalidation.ml b/lib_node_shell/prevalidation.ml index 364d22cda..a4449d1a0 100644 --- a/lib_node_shell/prevalidation.ml +++ b/lib_node_shell/prevalidation.ml @@ -7,80 +7,7 @@ (* *) (**************************************************************************) - -type 'error preapply_result = { - applied: (Operation_hash.t * Operation.t) list; - refused: (Operation.t * 'error list) Operation_hash.Map.t; - branch_refused: (Operation.t * 'error list) Operation_hash.Map.t; - branch_delayed: (Operation.t * 'error list) Operation_hash.Map.t; -} - -let empty_result = { - applied = [] ; - refused = Operation_hash.Map.empty ; - branch_refused = Operation_hash.Map.empty ; - branch_delayed = Operation_hash.Map.empty ; -} - -let map_result f r = { - applied = r.applied; - refused = Operation_hash.Map.map f r.refused ; - branch_refused = Operation_hash.Map.map f r.branch_refused ; - branch_delayed = Operation_hash.Map.map f r.branch_delayed ; -} - -let preapply_result_encoding error_encoding = - let open Data_encoding in - let operation_encoding = - merge_objs - (obj1 (req "hash" Operation_hash.encoding)) - (dynamic_size Operation.encoding) in - let refused_encoding = - merge_objs - (obj1 (req "hash" Operation_hash.encoding)) - (merge_objs - (dynamic_size Operation.encoding) - (obj1 (req "error" error_encoding))) in - let build_list map = Operation_hash.Map.bindings map in - let build_map list = - List.fold_right - (fun (k, e) m -> Operation_hash.Map.add k e m) - list Operation_hash.Map.empty in - conv - (fun { applied ; refused ; branch_refused ; branch_delayed } -> - (applied, build_list refused, - build_list branch_refused, build_list branch_delayed)) - (fun (applied, refused, branch_refused, branch_delayed) -> - let refused = build_map refused in - let branch_refused = build_map branch_refused in - let branch_delayed = build_map branch_delayed in - { applied ; refused ; branch_refused ; branch_delayed }) - (obj4 - (req "applied" (list operation_encoding)) - (req "refused" (list refused_encoding)) - (req "branch_refused" (list refused_encoding)) - (req "branch_delayed" (list refused_encoding))) - -let preapply_result_operations t = - let ops = - List.fold_left - (fun acc (h, op) -> Operation_hash.Map.add h op acc) - Operation_hash.Map.empty t.applied in - let ops = - Operation_hash.Map.fold - (fun h (op, _err) acc -> Operation_hash.Map.add h op acc) - t.branch_delayed ops in - let ops = - Operation_hash.Map.fold - (fun h (op, _err) acc -> Operation_hash.Map.add h op acc) - t.branch_refused ops in - ops - -let empty_result = - { applied = [] ; - refused = Operation_hash.Map.empty ; - branch_refused = Operation_hash.Map.empty ; - branch_delayed = Operation_hash.Map.empty } +open Preapply_result let rec apply_operations apply_operation state r max_ops ~sort ops = Lwt_list.fold_left_s @@ -235,7 +162,7 @@ let prevalidate Proto.apply_operation state parse_op in apply_operations apply_operation - state empty_result max_number_of_operations + state Preapply_result.empty max_number_of_operations ~sort sorted_ops >>= fun (state, max_number_of_operations, r) -> let r = { r with diff --git a/lib_node_shell/prevalidation.mli b/lib_node_shell/prevalidation.mli index 45deaf2f0..547e37aee 100644 --- a/lib_node_shell/prevalidation.mli +++ b/lib_node_shell/prevalidation.mli @@ -7,25 +7,6 @@ (* *) (**************************************************************************) -type 'error preapply_result = { - applied: (Operation_hash.t * Operation.t) list; - refused: (Operation.t * 'error list) Operation_hash.Map.t; - (* e.g. invalid signature *) - branch_refused: (Operation.t * 'error list) Operation_hash.Map.t; - (* e.g. insufficent balance *) - branch_delayed: (Operation.t * 'error list) Operation_hash.Map.t; - (* e.g. timestamp in the future *) -} - -val empty_result : 'error preapply_result - -val preapply_result_operations : - 'error preapply_result -> Operation.t Operation_hash.Map.t - -val preapply_result_encoding : - 'error list Data_encoding.t -> - 'error preapply_result Data_encoding.t - type prevalidation_state val start_prevalidation : @@ -38,7 +19,7 @@ val start_prevalidation : val prevalidate : prevalidation_state -> sort:bool -> (Operation_hash.t * Operation.t) list -> - (prevalidation_state * error preapply_result) Lwt.t + (prevalidation_state * error Preapply_result.t) Lwt.t val end_prevalidation : prevalidation_state -> Updater.validation_result tzresult Lwt.t diff --git a/lib_node_shell/prevalidator.ml b/lib_node_shell/prevalidator.ml index 1117cb271..fee49e483 100644 --- a/lib_node_shell/prevalidator.ml +++ b/lib_node_shell/prevalidator.ml @@ -8,6 +8,7 @@ (**************************************************************************) open Logging.Node.Prevalidator +open Preapply_result let list_pendings ?maintain_net_db ~from_block ~to_block old_mempool = let rec pop_blocks ancestor block mempool = @@ -59,8 +60,8 @@ type t = { notify_operations: P2p.Peer_id.t -> Mempool.t -> unit ; prevalidate_operations: bool -> Operation.t list -> - (Operation_hash.t list * error preapply_result) tzresult Lwt.t ; - operations: unit -> error preapply_result * Operation.t Operation_hash.Map.t ; + (Operation_hash.t list * error Preapply_result.t) tzresult Lwt.t ; + operations: unit -> error Preapply_result.t * Operation.t Operation_hash.Map.t ; pending: ?block:State.Block.t -> unit -> Operation.t Operation_hash.Map.t Lwt.t ; timestamp: unit -> Time.t ; context: unit -> Updater.validation_result tzresult Lwt.t ; @@ -95,7 +96,7 @@ let create let pending = Operation_hash.Table.create 53 in let head = ref head in let mempool = ref Mempool.empty in - let operations = ref empty_result in + let operations = ref Preapply_result.empty in let operation_count = ref 0 in (* unprocessed + operations/mempool *) Chain_traversal.live_blocks !head @@ -171,7 +172,7 @@ let create Lwt.return (Ok state, r) | Error err -> let r = - { empty_result with + { Preapply_result.empty with branch_delayed = List.fold_left (fun m (h, op) -> Operation_hash.Map.add h (op, err) m) @@ -354,7 +355,7 @@ let create list_pendings ~maintain_net_db:net_db ~from_block:!head ~to_block:new_head - (preapply_result_operations !operations) >>= fun new_mempool -> + (Preapply_result.operations !operations) >>= fun new_mempool -> Chain_traversal.live_blocks new_head (State.Block.max_operations_ttl new_head) @@ -365,7 +366,7 @@ let create (* Reset the pre-validation context *) head := new_head ; mempool := Mempool.empty ; - operations := empty_result ; + operations := Preapply_result.empty ; broadcast_unprocessed := false ; unprocessed := new_mempool ; operation_count := Operation_hash.Map.cardinal new_mempool ; @@ -410,7 +411,7 @@ let create cancel () >>= fun () -> prevalidation_worker in let pending ?block () = - let ops = preapply_result_operations !operations in + let ops = Preapply_result.operations !operations in match block with | None -> Lwt.return ops | Some to_block -> list_pendings ~from_block:!head ~to_block ops in diff --git a/lib_node_shell/prevalidator.mli b/lib_node_shell/prevalidator.mli index ae6561205..a081c918b 100644 --- a/lib_node_shell/prevalidator.mli +++ b/lib_node_shell/prevalidator.mli @@ -47,7 +47,7 @@ val inject_operation: t -> ?force:bool -> Operation.t -> unit tzresult Lwt.t val flush: t -> State.Block.t -> unit val timestamp: t -> Time.t -val operations: t -> error Prevalidation.preapply_result * Operation.t Operation_hash.Map.t +val operations: t -> error Preapply_result.t * Operation.t Operation_hash.Map.t val context: t -> Updater.validation_result tzresult Lwt.t val pending: ?block:State.Block.t -> t -> Operation.t Operation_hash.Map.t Lwt.t diff --git a/lib_node_shell/state.mli b/lib_node_shell/state.mli index 8e3b47010..a87782707 100644 --- a/lib_node_shell/state.mli +++ b/lib_node_shell/state.mli @@ -139,7 +139,7 @@ module Block : sig val context: t -> Context.t Lwt.t val protocol_hash: t -> Protocol_hash.t Lwt.t - val test_network: t -> Context.test_network Lwt.t + val test_network: t -> Test_network_status.t Lwt.t val operation_hashes: t -> int -> diff --git a/lib_node_updater/jbuild b/lib_node_updater/jbuild index 7abfb5f54..4e5cb2bfb 100644 --- a/lib_node_updater/jbuild +++ b/lib_node_updater/jbuild @@ -7,7 +7,9 @@ tezos-micheline tezos-protocol-compiler tezos-storage - tezos-node-net + tezos-node-services + tezos-node-p2p-base + tezos-node-http dynlink)) (flags (:standard -w -9+27-30-32-40@8 -safe-string @@ -15,7 +17,9 @@ -open Tezos_micheline -open Tezos_protocol_compiler -open Tezos_storage - -open Tezos_node_net)))) + -open Tezos_node_services + -open Tezos_node_http + -open Tezos_node_p2p_base)))) (alias ((name runtest_indent) diff --git a/lib_node_updater/tezos_protocol_environment.ml b/lib_node_updater/tezos_protocol_environment.ml index d764974da..327768c02 100644 --- a/lib_node_updater/tezos_protocol_environment.ml +++ b/lib_node_updater/tezos_protocol_environment.ml @@ -56,7 +56,10 @@ module Make(Param : sig val name: string end)() = struct module Block_header = Block_header module Protocol = Protocol end - module RPC = RPC + module RPC = struct + include RPC + include RPC_server + end module Micheline = Tezos_micheline.Micheline module Fitness = Fitness module Error_monad = struct diff --git a/lib_node_updater/updater.ml b/lib_node_updater/updater.ml index 82576f75e..6afaa7389 100644 --- a/lib_node_updater/updater.ml +++ b/lib_node_updater/updater.ml @@ -137,7 +137,7 @@ module Node_protocol_environment_sigs = struct and type Tezos_data.Operation.t = Operation.t and type Tezos_data.Block_header.shell_header = Block_header.shell_header and type Tezos_data.Block_header.t = Block_header.t - and type 'a RPC.Directory.t = 'a RPC.Directory.t + and type 'a RPC.Directory.t = 'a RPC_server.Directory.t and type Updater.validation_result = validation_result and type Updater.rpc_context = rpc_context @@ -182,7 +182,7 @@ module type RAW_PROTOCOL = sig 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 + val rpc_services: rpc_context RPC_server.directory val configure_sandbox: Context.t -> Data_encoding.json option -> Context.t tzresult Lwt.t end diff --git a/lib_node_updater/updater.mli b/lib_node_updater/updater.mli index b613e6375..e7296b8eb 100644 --- a/lib_node_updater/updater.mli +++ b/lib_node_updater/updater.mli @@ -68,7 +68,7 @@ module type RAW_PROTOCOL = sig 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 + val rpc_services: rpc_context RPC_server.directory val configure_sandbox: Context.t -> Data_encoding.json option -> Context.t tzresult Lwt.t end @@ -99,7 +99,7 @@ module Node_protocol_environment_sigs : sig and type Tezos_data.Operation.t = Operation.t and type Tezos_data.Block_header.shell_header = Block_header.shell_header and type Tezos_data.Block_header.t = Block_header.t - and type 'a RPC.Directory.t = 'a RPC.Directory.t + and type 'a RPC.Directory.t = 'a RPC_server.Directory.t and type Updater.validation_result = validation_result and type Updater.rpc_context = rpc_context diff --git a/lib_storage/context.ml b/lib_storage/context.ml index 7728f1df1..e5fb62fcb 100644 --- a/lib_storage/context.ml +++ b/lib_storage/context.ml @@ -177,83 +177,17 @@ let get_protocol v = let set_protocol v key = raw_set v current_protocol_key (Protocol_hash.to_bytes key) -type test_network = - | Not_running - | Forking of { - protocol: Protocol_hash.t ; - expiration: Time.t ; - } - | Running of { - net_id: Net_id.t ; - genesis: Block_hash.t ; - protocol: Protocol_hash.t ; - expiration: Time.t ; - } - -let pp_test_network ppf = function - | Not_running -> Format.fprintf ppf "@[Not running@]" - | Forking { protocol ; expiration } -> - Format.fprintf ppf - "@[Forking %a (expires %a)@]" - Protocol_hash.pp - protocol - Time.pp_hum - expiration - | Running { net_id ; genesis ; protocol ; expiration } -> - Format.fprintf ppf - "@[Running %a\ - @ Genesis: %a\ - @ Net id: %a\ - @ Expiration: %a@]" - Protocol_hash.pp protocol - Block_hash.pp genesis - Net_id.pp net_id - Time.pp_hum expiration - -let test_network_encoding = - let open Data_encoding in - union [ - case ~tag:0 - (obj1 (req "status" (constant "not_running"))) - (function Not_running -> Some () | _ -> None) - (fun () -> Not_running) ; - case ~tag:1 - (obj3 - (req "status" (constant "forking")) - (req "protocol" Protocol_hash.encoding) - (req "expiration" Time.encoding)) - (function - | Forking { protocol ; expiration } -> - Some ((), protocol, expiration) - | _ -> None) - (fun ((), protocol, expiration) -> - Forking { protocol ; expiration }) ; - case ~tag:2 - (obj5 - (req "status" (constant "running")) - (req "net_id" Net_id.encoding) - (req "genesis" Block_hash.encoding) - (req "protocol" Protocol_hash.encoding) - (req "expiration" Time.encoding)) - (function - | Running { net_id ; genesis ; protocol ; expiration } -> - Some ((), net_id, genesis, protocol, expiration) - | _ -> None) - (fun ((), net_id, genesis, protocol, expiration) -> - Running { net_id ; genesis ; protocol ; expiration }) ; - ] - let get_test_network v = raw_get v current_test_network_key >>= function | None -> Lwt.fail (Failure "Unexpected error (Context.get_test_network)") | Some data -> - match Data_encoding.Binary.of_bytes test_network_encoding data with + match Data_encoding.Binary.of_bytes Test_network_status.encoding data with | None -> Lwt.fail (Failure "Unexpected error (Context.get_test_network)") | Some r -> Lwt.return r let set_test_network v id = raw_set v current_test_network_key - (Data_encoding.Binary.to_bytes test_network_encoding id) + (Data_encoding.Binary.to_bytes Test_network_status.encoding id) let del_test_network v = raw_del v current_test_network_key let fork_test_network v ~protocol ~expiration = diff --git a/lib_storage/context.mli b/lib_storage/context.mli index 2cd91ab38..b29c3921d 100644 --- a/lib_storage/context.mli +++ b/lib_storage/context.mli @@ -77,25 +77,9 @@ val set_master: index -> commit -> unit Lwt.t val get_protocol: context -> Protocol_hash.t Lwt.t val set_protocol: context -> Protocol_hash.t -> context Lwt.t -type test_network = - | Not_running - | Forking of { - protocol: Protocol_hash.t ; - expiration: Time.t ; - } - | Running of { - net_id: Net_id.t ; - genesis: Block_hash.t ; - protocol: Protocol_hash.t ; - expiration: Time.t ; - } +val get_test_network: context -> Test_network_status.t Lwt.t +val set_test_network: context -> Test_network_status.t -> context Lwt.t -val pp_test_network : Format.formatter -> test_network -> unit - -val test_network_encoding: test_network Data_encoding.t - -val get_test_network: context -> test_network Lwt.t -val set_test_network: context -> test_network -> context Lwt.t val del_test_network: context -> context Lwt.t val reset_test_network: context -> Block_hash.t -> Time.t -> context Lwt.t diff --git a/test/p2p/jbuild b/test/p2p/jbuild index 7ce71825c..e18571328 100644 --- a/test/p2p/jbuild +++ b/test/p2p/jbuild @@ -5,13 +5,16 @@ test_p2p_connection_pool test_p2p_io_scheduler)) (libraries (tezos-base - tezos-node-net + tezos-node-p2p-base + tezos-node-p2p + lwt.unix test_lib)) (flags (:standard -w -9-32 -linkall -safe-string -open Tezos_base__TzPervasives - -open Tezos_node_net)))) + -open Tezos_node_p2p_base + -open Tezos_node_p2p)))) (alias ((name buildtest)