diff --git a/.gitignore b/.gitignore index ab918853d..c1f626690 100644 --- a/.gitignore +++ b/.gitignore @@ -39,7 +39,9 @@ /test/test-context /test/test-basic /test/test-data-encoding -/test/test-p2p +/test/test-p2p-io-scheduler +/test/test-p2p-connection +/test/test-p2p-connection-pool /test/LOG *~ diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 3b44d3a45..87b7a28df 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -107,6 +107,36 @@ test:data-encoding: - build - build:test +test:p2p-io-scheduler: + stage: test + tags: + - tezos_builder + script: + - make -C test run-test-p2p-io-scheduler + dependencies: + - build + - build:test + +test:p2p-connection: + stage: test + tags: + - tezos_builder + script: + - make -C test run-test-p2p-connection + dependencies: + - build + - build:test + +test:p2p-connection-pool: + stage: test + tags: + - tezos_builder + script: + - make -C test run-test-p2p-connection-pool + dependencies: + - build + - build:test + expurge: stage: expurge tags: diff --git a/scripts/create_docker_builder.sh b/scripts/create_docker_builder.sh index 1a5592443..c89f6328d 100755 --- a/scripts/create_docker_builder.sh +++ b/scripts/create_docker_builder.sh @@ -9,6 +9,8 @@ image_name=${1:=tezos_build} ocaml_version=${2:=alpine_ocaml-4.03.0} image_version=$3 +docker pull ocaml/opam:${ocaml_version} + cp ${cur_dir}/install_build_deps.sh ${dir} cp ${cur_dir}/../src/tezos-deps.opam ${dir} cat > ${dir}/Dockerfile <>= fun net -> - let peer = - match peers net with - | [peer] -> peer - | _ -> Pervasives.failwith "" in - action net peer >>= fun () -> shutdown net + let socket = Lwt_unix.socket PF_INET6 SOCK_STREAM 0 in + let uaddr = Ipaddr_unix.V6.to_inet_addr addr in + Lwt_unix.connect socket (Lwt_unix.ADDR_INET (uaddr, port)) >>= fun () -> + let io_sched = P2p_io_scheduler.create ~read_buffer_size:(1 lsl 14) () in + let conn = P2p_io_scheduler.register io_sched socket in + P2p_connection.authenticate + ~proof_of_work_target:Crypto_box.default_target + ~incoming:false + conn + (addr, port) + identity Tezos_p2p.Raw.supported_versions >>=? fun (_, auth_fd) -> + P2p_connection.accept auth_fd Tezos_p2p.Raw.encoding >>= function + | Error _ -> failwith "Connection rejected by peer." + | Ok conn -> + action conn >>=? fun () -> + P2p_connection.close conn >>= fun () -> + return () let replicate n x = let rec replicate_acc acc n x = if n <= 0 then acc else replicate_acc (x :: acc) (n-1) x in replicate_acc [] n x -let request_block_times block_hash n net peer = - let open Block_hash in - let () = printf "requesting %a block %a times\n" - pp_short block_hash pp_print_int n in - let block_hashes = replicate n block_hash in - send net peer (Get_blocks block_hashes) +let send conn (msg : Tezos_p2p.msg) = + P2p_connection.write conn (Tezos_p2p.Raw.Message msg) -let request_op_times op_signed n net peer = +let request_block_times block_hash n conn = + let open Block_hash in + lwt_log_notice + "requesting %a block %d times" + pp_short block_hash n >>= fun () -> + let block_hashes = replicate n block_hash in + send conn (Get_blocks block_hashes) + +let request_op_times op_signed n conn = let open Operation_hash in let op_hash = hash_bytes [op_signed] in - let () = printf "sending %a transaction\n" pp_short op_hash in - send net peer (Operation op_signed) >>= fun () -> - let () = printf "requesting %a transaction %a times\n" - pp_short op_hash pp_print_int n in + lwt_log_notice "sending %a transaction" pp_short op_hash >>= fun () -> + send conn (Operation op_signed) >>=? fun () -> + lwt_log_notice + "requesting %a transaction %d times" + pp_short op_hash n >>= fun () -> let op_hashes = replicate n op_hash in - send net peer (Get_operations op_hashes) + send conn (Get_operations op_hashes) -let send_block_size n net peer = +let send_block_size n conn = let bytes = MBytes.create n in let open Block_hash in - let () = printf "propagating fake %a byte block %a\n" - pp_print_int n pp_short (hash_bytes [bytes]) in - send net peer (Block bytes) + lwt_log_notice + "propagating fake %d byte block %a" n pp_short (hash_bytes [bytes]) >>= fun () -> + send conn (Block bytes) -let send_protocol_size n net peer = +let send_protocol_size n conn = let bytes = MBytes.create n in let open Protocol_hash in - let () = printf "propagating fake %a byte protocol %a\n" - pp_print_int n pp_short (hash_bytes [bytes]) in - send net peer (Protocol bytes) + lwt_log_notice + "propagating fake %d byte protocol %a" + n pp_short (hash_bytes [bytes]) >>= fun () -> + send conn (Protocol bytes) -let send_operation_size n net peer = +let send_operation_size n conn = let op_faked = MBytes.create n in let op_hashed = Operation_hash.hash_bytes [op_faked] in - let () = printf "propagating fake %a byte operation %a\n" - pp_print_int n Operation_hash.pp_short op_hashed in - send net peer (Operation op_faked) >>= fun () -> + lwt_log_notice + "propagating fake %d byte operation %a" + n Operation_hash.pp_short op_hashed >>= fun () -> + send conn (Operation op_faked) >>=? fun () -> let block = signed (block_forged [op_hashed]) in let block_hashed = Block_hash.hash_bytes [block] in - let () = printf "propagating block %a with operation\n" - Block_hash.pp_short block_hashed in - send net peer (Block block) + lwt_log_notice + "propagating block %a with operation" + Block_hash.pp_short block_hashed >>= fun () -> + send conn (Block block) -let send_operation_bad_signature () net peer = +let send_operation_bad_signature () conn = let open Operation_hash in let signed_wrong_op = signed_wrong (tx_forged 5L 1L) in let hashed_wrong_op = hash_bytes [signed_wrong_op] in - let () = printf "propagating operation %a with wrong signature\n" - pp_short hashed_wrong_op in - send net peer (Operation signed_wrong_op) >>= fun () -> + lwt_log_notice + "propagating operation %a with wrong signature" + pp_short hashed_wrong_op >>= fun () -> + send conn (Operation signed_wrong_op) >>=? fun () -> let block = signed (block_forged [hashed_wrong_op]) in let block_hashed = Block_hash.hash_bytes [block] in - let () = printf "propagating block %a with operation\n" - Block_hash.pp_short block_hashed in - send net peer (Block block) + lwt_log_notice + "propagating block %a with operation" + Block_hash.pp_short block_hashed >>= fun () -> + send conn (Block block) -let send_block_bad_signature () net peer = +let send_block_bad_signature () conn = let open Block_hash in let signed_wrong_block = signed_wrong (block_forged []) in - let () = printf "propagating block %a with wrong signature\n" - pp_short (hash_bytes [signed_wrong_block]) in - send net peer (Block signed_wrong_block) + lwt_log_notice + "propagating block %a with wrong signature" + pp_short (hash_bytes [signed_wrong_block]) >>= fun () -> + send conn (Block signed_wrong_block) -let double_spend () net peer = +let double_spend () conn = let spend account = let op_signed = signed (tx_forged ~dest:account 199999999L 1L) in let op_hashed = Operation_hash.hash_bytes [op_signed] in let block_signed = signed (block_forged [op_hashed]) in let block_hashed = Block_hash.hash_bytes [block_signed] in - let () = printf "propagating operation %a\n" - Operation_hash.pp_short op_hashed in - send net peer (Operation op_signed) >>= fun () -> - let () = printf "propagating block %a\n" - Block_hash.pp_short block_hashed in - send net peer (Block block_signed) in - spend destination_account <&> spend another_account + lwt_log_notice + "propagating operation %a" + Operation_hash.pp_short op_hashed >>= fun () -> + send conn (Operation op_signed) >>=? fun () -> + lwt_log_notice + "propagating block %a" + Block_hash.pp_short block_hashed >>= fun () -> + send conn (Block block_signed) in + spend destination_account >>=? fun () -> + spend another_account -let long_chain n net peer = - let () = printf "propogating %a blocks\n" - pp_print_int n in +let long_chain n conn = + lwt_log_notice "propogating %d blocks" n >>= fun () -> let prev_ref = ref genesis_block_hashed in - let rec loop k = if k < 1 then return_unit else + let rec loop k = + if k < 1 then + return () + else let block = signed (block_forged ~prev:!prev_ref []) in - let () = prev_ref := Block_hash.hash_bytes [block] in - send net peer (Block block) >>= fun () -> loop (k-1) in + prev_ref := Block_hash.hash_bytes [block] ; + send conn (Block block) >>=? fun () -> + loop (k-1) in loop n -let lots_transactions amount fee n net peer = +let lots_transactions amount fee n conn = let signed_op = signed (tx_forged amount fee) in - let rec loop k = if k < 1 then return_unit else - send net peer (Operation signed_op) >>= fun () -> loop (k-1) in + let rec loop k = + if k < 1 then + return () + else + send conn (Operation signed_op) >>=? fun () -> + loop (k-1) in let ops = replicate n (Operation_hash.hash_bytes [signed_op]) in let signed_block = signed (block_forged ops) in - let () = printf "propogating %a transactions\n" - pp_print_int n in - loop n >>= fun () -> - let () = printf "propagating block %a with wrong signature\n" - Block_hash.pp_short (Block_hash.hash_bytes [signed_block]) in - send net peer (Block signed_block) + lwt_log_notice "propogating %d transactions" n >>= fun () -> + loop n >>=? fun () -> + lwt_log_notice + "propagating block %a with wrong signature" + Block_hash.pp_short (Block_hash.hash_bytes [signed_block]) >>= fun () -> + send conn (Block signed_block) let main () = - let addr = Ipaddr.V4 Ipaddr.V4.localhost in + let addr = Ipaddr.V6.localhost in let port = 9732 in let run_action action = try_action addr port action in - let run_cmd_unit lwt = Arg.Unit (fun () -> Lwt_main.run (lwt ())) in - let run_cmd_int_suffix lwt = Arg.String (fun str -> + let run_cmd_unit lwt = + Arg.Unit begin fun () -> + Lwt_main.run begin + lwt () >>= function + | Ok () -> Lwt.return_unit + | Error err -> + lwt_log_error "Error: %a" pp_print_error err >>= fun () -> + Lwt.return_unit + end + end in + let run_cmd_int_suffix lwt = + Arg.String begin fun str -> let last = str.[String.length str - 1] in let init = String.sub str 0 (String.length str - 1) in let n = @@ -249,7 +277,14 @@ let main () = else if last == 'g' || last == 'G' then int_of_string init * 1 lsl 30 else int_of_string str in - Lwt_main.run (lwt n)) in + Lwt_main.run begin + lwt n >>= function + | Ok () -> Lwt.return_unit + | Error err -> + lwt_log_error "Error: %a" pp_print_error err >>= fun () -> + Lwt.return_unit + end + end in let cmds = [( "-1", run_cmd_int_suffix (run_action << request_block_times genesis_block_hashed), diff --git a/src/client/embedded/bootstrap/mining/client_mining_forge.ml b/src/client/embedded/bootstrap/mining/client_mining_forge.ml index 68a621970..3ea587027 100644 --- a/src/client/embedded/bootstrap/mining/client_mining_forge.ml +++ b/src/client/embedded/bootstrap/mining/client_mining_forge.ml @@ -198,7 +198,7 @@ end = struct let lock = Lwt_mutex.create () - let get_block cctxt level = + let get_block _cctxt level = Lwt_mutex.with_lock lock (fun () -> load () >>=? fun map -> diff --git a/src/client/embedded/bootstrap/mining/client_mining_operations.ml b/src/client/embedded/bootstrap/mining/client_mining_operations.ml index e6841e7db..2e3d16ff3 100644 --- a/src/client/embedded/bootstrap/mining/client_mining_operations.ml +++ b/src/client/embedded/bootstrap/mining/client_mining_operations.ml @@ -93,12 +93,15 @@ let filter_valid_endorsement cctxt { hash; content } = let monitor_endorsement cctxt = monitor cctxt ~contents:true ~check:true () >>= fun ops_stream -> let endorsement_stream, push = Lwt_stream.create () in - Lwt_stream.on_termination ops_stream (fun () -> push None) ; - Lwt.async (fun () -> - Lwt_stream.iter_p - (Lwt_list.iter_p (fun e -> - filter_valid_endorsement cctxt e >>= function - | None -> Lwt.return_unit - | Some e -> push (Some e) ; Lwt.return_unit)) - ops_stream) ; + Lwt.async begin fun () -> + Lwt_stream.closed ops_stream >|= fun () -> push None + end; + Lwt.async begin fun () -> + Lwt_stream.iter_p + (Lwt_list.iter_p (fun e -> + filter_valid_endorsement cctxt e >>= function + | None -> Lwt.return_unit + | Some e -> push (Some e) ; Lwt.return_unit)) + ops_stream + end ; Lwt.return endorsement_stream diff --git a/src/client/embedded/bootstrap/webclient/webclient_proto_service_directory.ml b/src/client/embedded/bootstrap/webclient/webclient_proto_service_directory.ml index 71023c1ec..5dd2f12c9 100644 --- a/src/client/embedded/bootstrap/webclient/webclient_proto_service_directory.ml +++ b/src/client/embedded/bootstrap/webclient/webclient_proto_service_directory.ml @@ -15,7 +15,7 @@ let cctxt = Client_commands.ignore_context let root = let root = - RPC.register RPC.empty Services.contracts @@ fun block () -> + RPC.register RPC.empty Services.contracts @@ fun _block () -> Client_proto_contracts.RawContractAlias.load cctxt >>= fun list -> let (names, _) = List.split list in RPC.Answer.return names in diff --git a/src/minutils/data_encoding.ml b/src/minutils/data_encoding.ml index 3de84af44..2da130d06 100644 --- a/src/minutils/data_encoding.ml +++ b/src/minutils/data_encoding.ml @@ -1178,4 +1178,14 @@ let rec length : type x. x t -> x -> int = fun e -> let to_bytes = to_bytes let length = length + + let fixed_length e = + match classify e with + | `Fixed n -> Some n + | `Dynamic | `Variable -> None + let fixed_length_exn e = + match fixed_length e with + | Some n -> n + | None -> invalid_arg "Data_encoding.Binary.fixed_length_exn" + end diff --git a/src/minutils/data_encoding.mli b/src/minutils/data_encoding.mli index be410b820..8bac5d62f 100644 --- a/src/minutils/data_encoding.mli +++ b/src/minutils/data_encoding.mli @@ -236,4 +236,7 @@ module Binary : sig val to_bytes : 'a encoding -> 'a -> MBytes.t val of_bytes : 'a encoding -> MBytes.t -> 'a option + val fixed_length : 'a encoding -> int option + val fixed_length_exn : 'a encoding -> int + end diff --git a/src/minutils/utils.ml b/src/minutils/utils.ml index d083f5cb4..bf6f36792 100644 --- a/src/minutils/utils.ml +++ b/src/minutils/utils.ml @@ -59,6 +59,10 @@ let unopt x = function | None -> x | Some x -> x +let unopt_map ~f ~default = function + | None -> default + | Some x -> f x + let unopt_list l = let may_cons xs x = match x with None -> xs | Some x -> x :: xs in List.rev @@ List.fold_left may_cons [] l @@ -72,6 +76,13 @@ let filter_map f l = let may_cons xs x = match f x with None -> xs | Some x -> x :: xs in List.rev @@ List.fold_left may_cons [] l +let list_rev_sub l n = + ListLabels.fold_left l ~init:(n, []) ~f:begin fun (n, l) elt -> + if n <= 0 then (n, l) else (n - 1, elt :: l) + end |> snd + +let list_sub l n = list_rev_sub l n |> List.rev + let display_paragraph ppf description = Format.fprintf ppf "@[%a@]" (fun ppf words -> List.iter (Format.fprintf ppf "%s@ ") words) @@ -111,3 +122,68 @@ let write_file ?(bin=false) fn contents = (fun () -> close_out oc) let (<<) g f = fun a -> g (f a) + +let rec (--) i j = + let rec loop acc j = + if j < i then acc else loop (j :: acc) (pred j) in + loop [] j + +let take_n_unsorted n l = + let rec loop acc n = function + | [] -> l + | _ when n <= 0 -> List.rev acc + | x :: xs -> loop (x :: acc) (pred n) xs in + loop [] n l + +module Bounded(E: Set.OrderedType) = struct + + (* TODO one day replace list by an heap array *) + + type t = { + bound : int ; + mutable size : int ; + mutable data : E.t list ; + } + let create bound = { bound ; size = 0 ; data = [] } + + let rec push x = function + | [] -> [x] + | (y :: xs) as ys -> + let c = compare x y in + if c < 0 then x :: ys else if c = 0 then ys else y :: push x xs + + let replace x xs = + match xs with + | y :: xs when compare x y > 0 -> + push x xs + | xs -> xs + + let insert x t = + if t.size < t.bound then begin + t.size <- t.size + 1 ; + t.data <- push x t.data + end else if E.compare (List.hd t.data) x < 0 then + t.data <- replace x t.data + + let get { data } = data + +end + +let take_n_sorted (type a) compare n l = + let module B = Bounded(struct type t = a let compare = compare end) in + let t = B.create n in + List.iter (fun x -> B.insert x t) l ; + B.get t + +let take_n ?compare n l = + match compare with + | None -> take_n_unsorted n l + | Some compare -> take_n_sorted compare n l + +let select n l = + let rec loop n acc = function + | [] -> invalid_arg "Utils.select" + | x :: xs when n <= 0 -> x, List.rev_append acc xs + | x :: xs -> loop (pred n) (x :: acc) xs + in + loop n [] l diff --git a/src/minutils/utils.mli b/src/minutils/utils.mli index 1c5a3f00a..0b3ec0f00 100644 --- a/src/minutils/utils.mli +++ b/src/minutils/utils.mli @@ -22,6 +22,7 @@ val map_option: f:('a -> 'b) -> 'a option -> 'b option val apply_option: f:('a -> 'b option) -> 'a option -> 'b option val iter_option: f:('a -> unit) -> 'a option -> unit val unopt: 'a -> 'a option -> 'a +val unopt_map: f:('a -> 'b) -> default:'b -> 'a option -> 'b val unopt_list: 'a option list -> 'a list val first_some: 'a option -> 'a option -> 'a option @@ -34,6 +35,11 @@ val remove_prefix: prefix:string -> string -> string option val filter_map: ('a -> 'b option) -> 'a list -> 'b list +(** [list_rev_sub l n] is (List.rev l) capped to max n elements *) +val list_rev_sub : 'a list -> int -> 'a list +(** [list_sub l n] is l capped to max n elements *) +val list_sub: 'a list -> int -> 'a list + val finalize: (unit -> 'a) -> (unit -> unit) -> 'a val read_file: ?bin:bool -> string -> string @@ -41,3 +47,20 @@ val write_file: ?bin:bool -> string -> string -> unit (** Compose functions from right to left. *) val (<<) : ('b -> 'c) -> ('a -> 'b) -> 'a -> 'c + +(** Sequence: [i--j] is the sequence [i;i+1;...;j-1;j] *) +val (--) : int -> int -> int list + +(** [take_n n l] returns the [n] first elements of [n]. When [compare] + is provided, it returns the [n] greatest element of [l]. *) +val take_n: ?compare:('a -> 'a -> int) -> int -> 'a list -> 'a list + +(** Bounded sequence: keep only the [n] greatest elements. *) +module Bounded(E: Set.OrderedType) : sig + type t + val create: int -> t + val insert: E.t -> t -> unit + val get: t -> E.t list +end + +val select: int -> 'a list -> 'a * 'a list diff --git a/src/node/net/p2p.ml b/src/node/net/p2p.ml index 9b7f9875d..87d9352b3 100644 --- a/src/node/net/p2p.ml +++ b/src/node/net/p2p.ml @@ -7,1430 +7,323 @@ (* *) (**************************************************************************) -module LU = Lwt_unix -module LC = Lwt_condition +include P2p_types -open Lwt.Infix -open Logging.Net - -type error += Encoding_error -type error += Message_too_big -type error += Write_would_block -type error += Decipher_error -type error += Canceled -type error += Timeout - -(* public types *) -type addr = Ipaddr.t -type port = int -type version = { - name : string ; - major : int ; - minor : int ; +type 'meta meta_config = 'meta P2p_connection_pool.meta_config = { + encoding : 'meta Data_encoding.t; + initial : 'meta; } -let version_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)) +type 'msg app_message_encoding = 'msg P2p_connection_pool.encoding = + Encoding : { + tag: int ; + encoding: 'a Data_encoding.t ; + wrap: 'a -> 'msg ; + unwrap: 'msg -> 'a option ; + max_length: int option ; + } -> 'msg app_message_encoding -type limits = { - max_message_size : int ; - peer_answer_timeout : float ; - expected_connections : int ; - min_connections : int ; - max_connections : int ; - blacklist_time : float ; +type 'msg message_config = 'msg P2p_connection_pool.message_config = { + encoding : 'msg app_message_encoding list ; + versions : Version.t list; } + type config = { - incoming_port : port option ; - discovery_port : port option ; - known_peers : (addr * port) list ; + listening_port : port option ; + listening_addr : addr option ; + trusted_points : Point.t list ; peers_file : string ; closed_network : bool ; + identity : Identity.t ; + proof_of_work_target : Crypto_box.target ; } -(* The global net identificator. *) -type gid = string +type limits = { -let gid_length = 16 + authentification_timeout : float ; -let pp_gid ppf gid = - Format.pp_print_string ppf (Hex_encode.hex_encode gid) + min_connections : int ; + expected_connections : int ; + max_connections : int ; -let zero_gid = String.make 16 '\x00' + backlog : int ; + max_incoming_connections : int ; -(* the common version for a pair of peers, if any, is the maximum one, - in lexicographic order *) -let common_version 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) + max_download_speed : int option ; + max_upload_speed : int option ; -(* A net point (address x port). *) -type point = addr * port + read_buffer_size : int ; + read_queue_size : int option ; + write_queue_size : int option ; + incoming_app_message_queue_size : int option ; + incoming_message_queue_size : int option ; + outgoing_message_queue_size : int option ; -let point_encoding = - let open Data_encoding in - let open Ipaddr in - conv - (fun (addr, port) -> - (match addr with - | V4 v4 -> V4.to_bytes v4 - | V6 v6 -> V6.to_bytes v6), port) - (fun (addr, port) -> - (match String.length addr with - | 4 -> V4 (V4.of_bytes_exn addr) - | 16 -> V6 (V6.of_bytes_exn addr) - | _ -> Pervasives.failwith "point_encoding"), port) - (obj2 - (req "addr" string) - (req "port" int16)) +} -type 'msg encoding = Encoding : { - tag: int ; - encoding: 'a Data_encoding.t ; - wrap: 'a -> 'msg ; - unwrap: 'msg -> 'a option ; - max_length: int option ; - } -> 'msg encoding +let create_scheduler limits = + P2p_io_scheduler.create + ~read_buffer_size:limits.read_buffer_size + ?max_upload_speed:limits.max_upload_speed + ?max_download_speed:limits.max_download_speed + ?read_queue_size:limits.read_queue_size + ?write_queue_size:limits.write_queue_size + () -module type PARAMS = sig +let create_connection_pool config limits meta_cfg msg_cfg io_sched = + let pool_cfg = { + P2p_connection_pool.identity = config.identity ; + proof_of_work_target = config.proof_of_work_target ; + listening_port = config.listening_port ; + trusted_points = config.trusted_points ; + peers_file = config.peers_file ; + closed_network = config.closed_network ; + min_connections = limits.min_connections ; + max_connections = limits.max_connections ; + max_incoming_connections = limits.max_incoming_connections ; + authentification_timeout = limits.authentification_timeout ; + incoming_app_message_queue_size = limits.incoming_app_message_queue_size ; + incoming_message_queue_size = limits.incoming_message_queue_size ; + outgoing_message_queue_size = limits.outgoing_message_queue_size ; + } + in + let pool = + P2p_connection_pool.create pool_cfg meta_cfg msg_cfg io_sched in + pool - (** Type of message used by higher layers *) - type msg - - val encodings : msg encoding list - - (** Type of metadata associated to an identity *) - type metadata - - val initial_metadata : metadata - val metadata_encoding : metadata Data_encoding.t - val score : metadata -> float - - (** High level protocol(s) talked by the peer. When two peers - initiate a connection, they exchange their list of supported - versions. The chosen one, if any, is the maximum common one (in - lexicographic order) *) - val supported_versions : version list - -end - -module Make (P: PARAMS) = struct - - (* Low-level network protocol messages (internal). The protocol is - completely symmetrical and asynchronous. First both peers must - present their credentials with a [Connect] message, then any - combination of the other messages can be received at any time. An - exception is the [Disconnect] message, which should mark the end of - transmission (and needs not being replied). *) - type msg = - | Connect of { - gid : string ; - port : int option ; - versions : version list ; - public_key : Crypto_box.public_key ; - proof_of_work : Crypto_box.nonce ; - message_nonce : Crypto_box.nonce ; - } - | Disconnect - | Bootstrap - | Advertise of point list - | Message of P.msg - - let msg_encoding = - let open Data_encoding in - union ~tag_size:`Uint16 - ([ case ~tag:0x00 - (obj6 - (req "gid" (Fixed.string gid_length)) - (req "port" uint16) - (req "pubkey" Crypto_box.public_key_encoding) - (req "proof_of_work" Crypto_box.nonce_encoding) - (req "message_nonce" Crypto_box.nonce_encoding) - (req "versions" (Variable.list version_encoding))) - (function - | Connect { gid ; port ; public_key ; - proof_of_work ; message_nonce ; versions } -> - let port = match port with None -> 0 | Some port -> port in - Some (gid, port, public_key, - proof_of_work, message_nonce, versions) - | _ -> None) - (fun (gid, port, public_key, - proof_of_work, message_nonce, versions) -> - let port = if port = 0 then None else Some port in - Connect { gid ; port ; versions ; - public_key ; proof_of_work ; message_nonce }); - case ~tag:0x01 null - (function Disconnect -> Some () | _ -> None) - (fun () -> Disconnect); - case ~tag:0x02 null - (function Bootstrap -> Some () | _ -> None) - (fun () -> Bootstrap); - case ~tag:0x03 (Variable.list point_encoding) - (function Advertise points -> Some points | _ -> None) - (fun points -> Advertise points); - ] @ - ListLabels.map P.encodings - ~f:(function Encoding { tag ; encoding ; wrap ; unwrap } -> - case ~tag encoding - (function Message msg -> unwrap msg | _ -> None) - (fun msg -> Message (wrap msg)))) - - let hdrlen = 2 - let maxlen = hdrlen + 2 lsl 16 - - (* read a message from a TCP socket *) - let recv_msg ?(uncrypt = (fun buf -> Some buf)) fd buf = - Lwt.catch begin fun () -> - assert (MBytes.length buf >= 2 lsl 16) ; - Lwt_utils.read_mbytes ~len:hdrlen fd buf >>= fun () -> - let len = EndianBigstring.BigEndian.get_uint16 buf 0 in - (* TODO timeout read ??? *) - Lwt_utils.read_mbytes ~len fd buf >>= fun () -> - let buf = MBytes.sub buf 0 len in - match uncrypt buf with - | None -> - (* TODO track invalid message *) - Error_monad.fail Decipher_error - | Some buf -> - match Data_encoding.Binary.of_bytes msg_encoding buf with - | None -> - (* TODO track invalid message *) - Error_monad.fail Encoding_error - | Some msg -> - Error_monad.return (len, msg) - end - (fun exn -> Lwt.return @@ Error_monad.error_exn exn) - - (* send a message over a TCP socket *) - let send_msg ?crypt fd buf msg = - Lwt.catch begin fun () -> - match crypt, Data_encoding.Binary.write msg_encoding msg buf hdrlen with - | _, None -> Error_monad.fail Encoding_error - | None, Some len -> - if len > maxlen then Error_monad.fail Message_too_big - else begin - EndianBigstring.BigEndian.set_int16 buf 0 (len - hdrlen) ; - (* TODO timeout write ??? *) - Lwt_utils.write_mbytes ~len fd buf >>= fun () -> - Error_monad.return len - end - | Some crypt, Some len -> - let encbuf = crypt (MBytes.sub buf hdrlen (len - hdrlen)) in - let len = MBytes.length encbuf in - if len > maxlen then Error_monad.fail Message_too_big - else begin - let lenbuf = MBytes.create 2 in - EndianBigstring.BigEndian.set_int16 lenbuf 0 len ; - Lwt_utils.write_mbytes fd lenbuf >>= fun () -> - Lwt_utils.write_mbytes fd encbuf >>= fun () -> - Error_monad.return len - end - end - (fun exn -> Lwt.return @@ Error_monad.error_exn exn) - - (* The (internal) type of network events, those dispatched from peer - workers to the net and others internal to net workers. *) - type event = - | Disconnected of peer - | Bootstrap of peer - | Recv of peer * P.msg - | Peers of point list - | Contact of point * LU.file_descr - | Connected of peer - | Shutdown - - (* A peer handle, as a record-encoded object, abstract from the - outside world. A hidden Lwt worker is associated to a peer at its - creation and is killed using the disconnect callback by net - workers (on shutdown of during maintenance). *) - and peer = { - gid : gid ; - public_key : Crypto_box.public_key ; - point : point ; - listening_port : port option ; - version : version ; - last_seen : unit -> float ; - disconnect : unit -> unit Lwt.t; - send : msg -> unit Lwt.t ; - try_send : msg -> bool ; - reader : event Lwt_pipe.t ; - writer : msg Lwt_pipe.t ; - total_sent : unit -> int ; - total_recv : unit -> int ; - current_inflow : unit -> float ; - current_outflow : unit -> float ; +let bounds ~min ~expected ~max = + assert (min <= expected) ; + assert (expected <= max) ; + let step_min = + (expected - min) / 3 + and step_max = + (max - expected) / 3 in + { P2p_maintenance.min_threshold = min + step_min ; + min_target = min + 2 * step_min ; + max_target = max - 2 * step_max ; + max_threshold = max - step_max ; } - type peer_info = { - gid : gid ; - addr : addr ; - port : port ; - version : version ; - total_sent : int ; - total_recv : int ; - current_inflow : float ; - current_outflow : float ; +let may_create_discovery_worker _config pool = + Some (P2p_discovery.create pool) + +let create_maintenance_worker limits pool disco = + let bounds = + bounds + limits.min_connections + limits.expected_connections + limits.max_connections + in + P2p_maintenance.run + ~connection_timeout:limits.authentification_timeout bounds pool disco + +let may_create_welcome_worker config limits pool = + match config.listening_port with + | None -> Lwt.return None + | Some port -> + P2p_welcome.run + ~backlog:limits.backlog pool + ?addr:config.listening_addr port >>= fun w -> + Lwt.return (Some w) + +type ('msg, 'meta) connection = ('msg, 'meta) P2p_connection_pool.connection + +module Real = struct + + type ('msg, 'meta) net = { + config: config ; + limits: limits ; + io_sched: P2p_io_scheduler.t ; + pool: ('msg, 'meta) P2p_connection_pool.t ; + discoverer: P2p_discovery.t option ; + maintenance: 'meta P2p_maintenance.t ; + welcome: P2p_welcome.t option ; } - (* A net handler, as a record-encoded object, abstract from the - outside world. Hidden Lwt workers are associated to a net at its - creation and can be killed using the shutdown callback. *) - type net = { - gid : gid ; - recv_from : unit -> (peer * P.msg) Lwt.t ; - send_to : peer -> P.msg -> unit Lwt.t ; - try_send_to : peer -> P.msg -> bool ; - broadcast : P.msg -> unit ; - blacklist : ?duration:float -> addr -> unit ; - whitelist : peer -> unit ; - maintain : unit -> unit Lwt.t ; - roll : unit -> unit Lwt.t ; - shutdown : unit -> unit Lwt.t ; - peers : unit -> peer list ; - find_peer : gid -> peer option ; - peer_info : peer -> peer_info ; - set_metadata : gid -> P.metadata -> unit ; - get_metadata : gid -> P.metadata option ; - } - - (* Run-time point-or-gid indexed storage, one point is bound to at - most one gid, which is the invariant we want to keep both for the - connected peers table and the known peers one *) - module GidMap = Map.Make (struct type t = gid let compare = compare end) - module GidSet = Set.Make (struct type t = gid let compare = compare end) - module PointMap = Map.Make (struct type t = point let compare = compare end) - module PointSet = Set.Make (struct type t = point let compare = compare end) - module PeerMap : sig - type 'a t - val empty : 'a t - val by_point : point -> 'a t -> 'a - val by_gid : gid -> 'a t -> 'a - val gid_by_point : point -> 'a t -> gid option - val point_by_gid : gid -> 'a t -> point - val mem_by_point : point -> 'a t -> bool - val mem_by_gid : gid -> 'a t -> bool - val remove_by_point : point -> 'a t -> 'a t - val remove_by_gid : gid -> 'a t -> 'a t - val update : point -> ?gid : gid -> 'a -> 'a t -> 'a t - val fold : (point -> gid option -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b - val iter : (point -> gid option -> 'a -> unit) -> 'a t -> unit - val bindings : 'a t -> (point * gid option * 'a) list - val cardinal : 'a t -> int - end = struct - type 'a t = - { by_point : (gid option * 'a) PointMap.t ; - by_gid : (point * 'a) GidMap.t } - - let empty = - { by_point = PointMap.empty ; - by_gid = GidMap.empty } - - let by_point point { by_point } = - let (_, v) = PointMap.find point by_point in v - - let by_gid gid { by_gid } = - let (_, v) = GidMap.find gid by_gid in v - - let gid_by_point point { by_point } = - let (gid, _) = PointMap.find point by_point in gid - - let point_by_gid gid { by_gid } = - let (point, _) = GidMap.find gid by_gid in point - - let mem_by_point point { by_point } = - PointMap.mem point by_point - - let mem_by_gid gid { by_gid } = - GidMap.mem gid by_gid - - let remove_by_point point ({ by_point ; by_gid } as map) = - try - let (gid, _) = PointMap.find point by_point in - { by_point = PointMap.remove point by_point ; - by_gid = match gid with - | None -> by_gid - | Some gid -> GidMap.remove gid by_gid } - with Not_found -> map - - let remove_by_gid gid ({ by_point ; by_gid } as map) = - try - let (point, _) = GidMap.find gid by_gid in - { by_point = PointMap.remove point by_point ; - by_gid = GidMap.remove gid by_gid } - with Not_found -> map - - let update point ?gid v map = - let { by_point ; by_gid } = - let map = remove_by_point point map in - match gid with Some gid -> remove_by_gid gid map | None -> map in - { by_point = PointMap.add point (gid, v) by_point ; - by_gid = match gid with Some gid -> GidMap.add gid (point, v) by_gid - | None -> by_gid } - - let fold f { by_point } init = - PointMap.fold - (fun point (gid, v) r -> f point gid v r) by_point init - - let iter f { by_point } = - PointMap.iter - (fun point (gid, v) -> f point gid v) by_point - - let cardinal { by_point } = - PointMap.cardinal by_point - - let bindings map = - fold (fun point gid v l -> (point, gid, v) :: l) map [] - end - - (* Builds a peer and launches its associated worker. Takes a push - function for communicating with the main worker using events - (including the one sent when the connection is alive). Returns a - canceler. *) - let connect_to_peer - config limits my_gid my_public_key my_secret_key my_proof_of_work - socket (addr, port) control_events white_listed = - (* a non exception-based cancelation mechanism *) - let cancelation, cancel, on_cancel = Lwt_utils.canceler () in - (* a cancelable encrypted reception *) - let recv ?uncrypt buf = - Lwt.pick [ recv_msg ?uncrypt socket buf ; - (cancelation () >>= fun () -> Error_monad.fail Canceled) ] - in - (* First step: send and receive credentials, makes no difference - whether we're trying to connect to a peer or checking an incoming - connection, both parties must first present themselves. *) - let rec connect buf = - let local_nonce = Crypto_box.random_nonce () in - send_msg socket buf - (Connect { gid = my_gid ; - public_key = my_public_key ; - proof_of_work = my_proof_of_work ; - message_nonce = local_nonce ; - port = config.incoming_port ; - versions = P.supported_versions }) >>= fun _ -> - Lwt.pick - [ ( LU.sleep limits.peer_answer_timeout >>= fun () -> Error_monad.fail Timeout ) ; - recv buf ] >>= function - | Error [Timeout] - | Error [Canceled] - | Error [Exn End_of_file] -> - debug "(%a) Closed connection to %a:%d." - pp_gid my_gid Ipaddr.pp_hum addr port ; - cancel () - | Error err -> - log_error "(%a) error receiving from %a:%d: %a" - pp_gid my_gid Ipaddr.pp_hum addr port - Error_monad.pp_print_error err ; - cancel () - | Ok (_, (Connect { gid; port = listening_port; versions ; - public_key ; proof_of_work ; message_nonce })) -> - debug "(%a) connection requested from %a @@ %a:%d" - pp_gid my_gid pp_gid gid Ipaddr.pp_hum addr port ; - let work_proved = - Crypto_box.check_proof_of_work - public_key proof_of_work Crypto_box.default_target in - if not work_proved then begin - debug "connection rejected (invalid proof of work)" ; - cancel () - end else begin - match common_version P.supported_versions versions with - | None -> - debug - "(%a) connection rejected (incompatible versions) from %a:%d" - pp_gid my_gid Ipaddr.pp_hum addr port ; - cancel () - | Some version -> - if config.closed_network then - match listening_port with - | Some port when white_listed (addr, port) -> - connected - buf local_nonce version gid - public_key message_nonce listening_port - | Some port -> - debug - "(%a) connection rejected (out of the closed network) from %a:%d" - pp_gid my_gid Ipaddr.pp_hum addr port ; - cancel () - | None -> - debug - "(%a) connection rejected (out of the closed network) from %a:unknown" - pp_gid my_gid Ipaddr.pp_hum addr ; - cancel () - else - connected - buf local_nonce version gid - public_key message_nonce listening_port - end - | Ok (_, Disconnect) -> - debug "(%a) connection rejected (closed by peer or timeout) from %a:%d" - pp_gid my_gid Ipaddr.pp_hum addr port ; - cancel () - | _ -> - debug "(%a) connection rejected (bad connection request) from %a:%d" - pp_gid my_gid Ipaddr.pp_hum addr port ; - cancel () - - (* Them we can build the net object and launch the worker. *) - and connected buf local_nonce version gid public_key nonce listening_port = - let feed_ma ?(freq=1.) ma counter = - let rec inner old_received = - Lwt_unix.sleep freq >>= fun () -> - let received = !counter in - ma#add_int (received - old_received); - inner received in - Lwt.async (fun () -> Lwt.pick [cancelation (); inner !counter]) - in - (* net object state *) - let last = ref (Unix.gettimeofday ()) in - let local_nonce = ref local_nonce in - let remote_nonce = ref nonce in - let received = ref 0 in - let sent = ref 0 in - let received_ema = new Moving_average.ema ~init:0. ~alpha:0.2 () in - let sent_ema = new Moving_average.ema ~init:0. ~alpha:0.2 () in - feed_ma received_ema received ; - feed_ma sent_ema sent ; - (* net object callbaks *) - let last_seen () = !last in - let get_nonce nonce = - let current_nonce = !nonce in - nonce := Crypto_box.increment_nonce !nonce ; - current_nonce in - let disconnect () = cancel () in - let crypt buf = - let nonce = get_nonce remote_nonce in - Crypto_box.box my_secret_key public_key buf nonce in - let writer = Lwt_pipe.create 2 in - let send p = Lwt_pipe.push writer p in - let try_send p = Lwt_pipe.push_now writer p in - let reader = Lwt_pipe.create 2 in - let total_sent () = !sent in - let total_recv () = !received in - let current_inflow () = received_ema#get in - let current_outflow () = sent_ema#get in - (* net object construction *) - let peer = { gid ; public_key ; point = (addr, port) ; - listening_port ; version ; last_seen ; - disconnect ; send ; try_send ; reader ; writer ; - total_sent ; total_recv ; current_inflow ; current_outflow } in - let uncrypt buf = - let nonce = get_nonce local_nonce in - match Crypto_box.box_open my_secret_key public_key buf nonce with - | None -> - debug "(%a) cannot decrypt message (from peer) %a @ %a:%d" - pp_gid my_gid pp_gid gid Ipaddr.pp_hum addr port ; - None - | Some _ as res -> res in - (* The message reception loop. *) - let rec receiver () = - recv ~uncrypt buf >>= function - | Error err -> - debug "(%a) error receiving: %a" - pp_gid my_gid Error_monad.pp_print_error err ; - cancel () - | Ok (size, msg) -> - received := !received + size; - match msg with - | Connect _ - | Disconnect -> - debug "(%a) disconnected (by peer) %a @@ %a:%d" - pp_gid my_gid pp_gid gid Ipaddr.pp_hum addr port ; - cancel () - | Bootstrap -> Lwt_pipe.push reader (Bootstrap peer) >>= receiver - | Advertise peers -> Lwt_pipe.push reader (Peers peers) >>= receiver - | Message msg -> Lwt_pipe.push reader (Recv (peer, msg)) >>= receiver - in - let rec sender () = - Lwt_pipe.pop peer.writer >>= fun msg -> - send_msg ~crypt socket buf msg >>= function - | Ok size -> - sent := !sent + size; - sender () - | Error err -> - debug "(%a) error sending to %a: %a" - pp_gid my_gid pp_gid gid Error_monad.pp_print_error err ; - cancel () - in - (* Events for the main worker *) - Lwt_pipe.push control_events (Connected peer) >>= fun () -> - on_cancel (fun () -> Lwt_pipe.push control_events (Disconnected peer)) ; - (* Launch the workers *) - Lwt.join [receiver () ; sender ()] - in - let buf = MBytes.create maxlen in - on_cancel (fun () -> - (* send_msg ~crypt socket buf Disconnect >>= fun _ -> *) - LU.close socket >>= fun _ -> - Lwt.return_unit) ; - let worker_name = - Format.asprintf - "(%a) connection handler for %a:%d" - pp_gid my_gid Ipaddr.pp_hum addr port in - ignore (Lwt_utils.worker worker_name - ~safe:true ~run:(fun () -> connect buf) ~cancel) ; - (* return the canceler *) - cancel - - - (* JSON format for on-disk peers cache file *) - let addr_encoding = - let open Data_encoding in - splitted - ~json: - (conv - Ipaddr.to_string - (Data_encoding.Json.wrap_error Ipaddr.of_string_exn) - string) - ~binary: - (union ~tag_size:`Uint8 - [ case ~tag:4 - (Fixed.string 4) - (fun ip -> Utils.map_option Ipaddr.V4.to_bytes (Ipaddr.to_v4 ip) ) - (fun b -> Ipaddr.(V4 (V4.of_bytes_exn b))) ; - case ~tag:6 - (Fixed.string 32) - (fun ip -> Some (Ipaddr.V6.to_bytes (Ipaddr.to_v6 ip))) - (fun b -> Ipaddr.(V6 (V6.of_bytes_exn b))) ; - ]) - - let peers_file_encoding = - let open Data_encoding in - obj5 - (req "gid" string) - (req "public_key" Crypto_box.public_key_encoding) - (req "secret_key" Crypto_box.secret_key_encoding) - (req "proof_of_work" Crypto_box.nonce_encoding) - (req "peers" - (obj3 - (req "known" - (list (obj3 - (req "addr" addr_encoding) - (req "port" int31) - (opt "infos" - (obj4 - (req "connections" int31) - (req "lastSeen" float) - (req "gid" string) - (req "public_key" - Crypto_box.public_key_encoding)))))) - (req "blacklisted" - (list (obj2 - (req "addr" addr_encoding) - (req "until" float)))) - (req "whitelisted" - (list (obj2 - (req "addr" addr_encoding) - (req "port" int31)))))) - - (* Info on peers maintained between connections *) - type source = { - unreachable_since : float option; - connections : (int * float * Crypto_box.public_key) option ; - white_listed : bool ; - meta : P.metadata ; - } - - (* Ad hoc comparison on sources such as good source < bad source *) - let compare_sources s1 s2 = - match s1.white_listed, s2.white_listed with - | true, false -> -1 | false, true -> 1 - | _, _ -> - match s1.unreachable_since, s2.unreachable_since with - | None, Some _ -> -1 | Some _, None -> 1 - | _, _ -> - match s1.connections, s2.connections with - | Some _, None -> -1 | None, Some _ -> 1 | None, None -> 0 - | Some (n1, t1, _), Some (n2, t2, _) -> - if n1 = n2 then compare t2 t1 - else compare n2 n1 - - (* A store for blacklisted addresses (we ban any peer on a blacklisted - address, which is the policy that seems to make the most sense) *) - module BlackList = Map.Make (struct type t = addr let compare = compare end) - - (* A good random string so it is probably unique on the network *) - let fresh_gid () = - Bytes.to_string @@ Sodium.Random.Bytes.generate gid_length - - (* The (fixed size) broadcast frame. *) - let discovery_message_encoding = - let open Data_encoding in - tup3 (Fixed.string 8) (Fixed.string gid_length) int16 - - let discovery_message gid port = - Data_encoding.Binary.to_bytes - discovery_message_encoding - ("DISCOVER", gid, port) - - (* Broadcast frame verifier. *) - let answerable_discovery_message msg my_gid when_ok when_not = - match msg with - | Some ("DISCOVER", gid, port) when gid <> my_gid -> when_ok gid port - | _ -> when_not () - - let string_of_unix_exn = function - | Unix.Unix_error (err, fn, _) -> "in " ^ fn ^ ", " ^ Unix.error_message err - | exn -> Printexc.to_string exn - - (* Launch an answer machine for the discovery mechanism, takes a - callback to fill the answers and returns a canceler function *) - let discovery_answerer my_gid disco_port cancelation callback = - (* init a UDP listening socket on the broadcast canal *) - Lwt.catch begin fun () -> - let main_socket = LU.(socket PF_INET SOCK_DGRAM 0) in - LU.(setsockopt main_socket SO_BROADCAST true) ; - LU.(setsockopt main_socket SO_REUSEADDR true) ; - LU.(bind main_socket (ADDR_INET (Unix.inet_addr_any, disco_port))) ; - Lwt.return (Some main_socket) - end - (fun exn -> - debug "(%a) will not listen to discovery requests (%s)" - pp_gid my_gid (string_of_unix_exn exn) ; - Lwt.return_none) >>= function - | None -> Lwt.return_unit - | Some main_socket -> - (* the answering function *) - let rec step () = - let buffer = discovery_message my_gid 0 in - let len = MBytes.length buffer in - Lwt.pick - [ (cancelation () >>= fun () -> Lwt.return_none) ; - (Lwt_bytes.recvfrom main_socket buffer 0 len [] >>= fun r -> - Lwt.return (Some r)) ] >>= function - | None -> Lwt.return_unit - | Some (len', LU.ADDR_INET (addr, _)) when len' = len -> - answerable_discovery_message - (Data_encoding.Binary.of_bytes - discovery_message_encoding buffer) - my_gid - (fun _ port -> - Lwt.catch begin fun () -> - callback addr port - end - (fun _ -> (* ignore errors *) Lwt.return_unit) >>= fun () -> - step ()) - step - | Some _ -> step () - in step () - - (* Sends dicover messages into space in an exponentially delayed loop, - restartable using a condition *) - let discovery_sender my_gid disco_port inco_port cancelation restart = - let msg = discovery_message my_gid inco_port in - let rec loop delay n = - Lwt.catch begin fun () -> - let socket = LU.(socket PF_INET SOCK_DGRAM 0) in - LU.setsockopt socket LU.SO_BROADCAST true ; - let broadcast_ipv4 = Unix.inet_addr_of_string "255.255.255.255" in - LU.connect socket - LU.(ADDR_INET (broadcast_ipv4, disco_port)) >>= fun () -> - Lwt_utils.write_mbytes socket msg >>= fun _ -> - LU.close socket - end - (fun _ -> - debug "(%a) error broadcasting a discovery request" pp_gid my_gid ; - Lwt.return_unit) >>= fun () -> - Lwt.pick - [ (LU.sleep delay >>= fun () -> Lwt.return (Some (delay, n + 1))) ; - (cancelation () >>= fun () -> Lwt.return_none) ; - (LC.wait restart >>= fun () -> Lwt.return (Some (0.1, 0))) ] - >>= function - | Some (delay, n) when n = 10 -> - loop delay 9 - | Some (delay, n) -> - loop (delay *. 2.) n - | None -> Lwt.return_unit - in loop 0.2 1 - - (* Main network creation and initialisation function *) - let bootstrap ~config ~limits = - (* we need to ignore SIGPIPEs *) - Sys.(set_signal sigpipe Signal_ignore) ; - (* a non exception-based cancelation mechanism *) - let cancelation, cancel, on_cancel = Lwt_utils.canceler () in - (* create the internal event pipe *) - let events = Lwt_pipe.create 100 in - (* create the external message pipe *) - let messages = Lwt_pipe.create 100 in - (* fill the known peers pools from last time *) - Data_encoding_ezjsonm.read_file config.peers_file >>= fun res -> - let known_peers, black_list, my_gid, - my_public_key, my_secret_key, my_proof_of_work = - let init_peers () = - let my_gid = - fresh_gid () in - let (my_secret_key, my_public_key) = - Crypto_box.random_keypair () in - let my_proof_of_work = - Crypto_box.generate_proof_of_work - my_public_key Crypto_box.default_target in - let known_peers = - let source = { unreachable_since = None ; - connections = None ; - white_listed = true ; - meta = P.initial_metadata ; - } - in - List.fold_left - (fun r point -> PeerMap.update point source r) - PeerMap.empty config.known_peers in - let black_list = - BlackList.empty in - known_peers, black_list, my_gid, - my_public_key, my_secret_key, my_proof_of_work in - match res with - | None -> - let known_peers, black_list, my_gid, - my_public_key, my_secret_key, my_proof_of_work = init_peers () in - debug "(%a) peer cache initiated" pp_gid my_gid ; - ref known_peers, ref black_list, my_gid, - my_public_key, my_secret_key, my_proof_of_work - | Some json -> - match Data_encoding.Json.destruct peers_file_encoding json with - | exception _ -> - let known_peers, black_list, my_gid, - my_public_key, my_secret_key, my_proof_of_work = init_peers () in - debug "(%a) peer cache reset" pp_gid my_gid ; - ref known_peers, ref black_list, - my_gid, my_public_key, my_secret_key, my_proof_of_work - | (my_gid, my_public_key, my_secret_key, my_proof_of_work, (k, b, w)) -> - let white_list = - List.fold_right PointSet.add w PointSet.empty in - let known_peers = - List.fold_left - (fun r (addr, port, infos) -> - match infos with - | None -> - let source = - { unreachable_since = None ; - connections = None ; - white_listed = true ; - meta = P.initial_metadata ; } in - PeerMap.update (addr, port) source r - | Some (c, t, gid, pk) -> - let source = - { unreachable_since = None ; - connections = Some (c, t, pk) ; - white_listed = PointSet.mem (addr, port) white_list ; - meta = P.initial_metadata ; } in - PeerMap.update (addr, port) ~gid source r) - PeerMap.empty k in - let black_list = - List.fold_left - (fun r (a, d) -> BlackList.add a d r) - BlackList.empty b in - debug "(%a) peer cache loaded" pp_gid my_gid ; - ref known_peers, ref black_list, - my_gid, my_public_key, my_secret_key, my_proof_of_work - in - (* some peer reachability predicates *) - let black_listed (addr, _) = - BlackList.mem addr !black_list in - let white_listed point = - try (PeerMap.by_point point !known_peers).white_listed - with Not_found -> false in - let grey_listed point = - try match (PeerMap.by_point point !known_peers).unreachable_since with - | None -> false | Some t -> Unix.gettimeofday () -. t > 5. - with Not_found -> false in - (* save the cache at exit *) - on_cancel (fun () -> - (* save the known peers cache *) - let json = - Data_encoding.Json.construct peers_file_encoding @@ - (my_gid, - my_public_key, - my_secret_key, - my_proof_of_work, - PeerMap.fold - (fun (addr, port) gid source (k, b, w) -> - let infos = match gid, source.connections with - | Some gid, Some (n, t, pk) -> Some (n, t, gid, pk) - | _ -> None in - ((addr, port, infos) :: k, - b, - if source.white_listed then (addr, port) :: w else w)) - !known_peers ([], BlackList.bindings !black_list, [])) - in - Data_encoding_ezjsonm.write_file config.peers_file json >>= fun _ -> - debug "(%a) peer cache saved" pp_gid my_gid ; - Lwt.return_unit) ; - (* storage of active and not yet active peers *) - let incoming = ref PointMap.empty in - let connected = ref PeerMap.empty in - (* peer welcoming (accept) loop *) - let welcome () = - match config.incoming_port with - | None -> (* no input port => no welcome worker *) Lwt.return_unit - | Some port -> - (* open port for incoming connexions *) - let addr = Unix.inet6_addr_any in - Lwt.catch begin fun () -> - let main_socket = LU.(socket PF_INET6 SOCK_STREAM 0) in - LU.(setsockopt main_socket SO_REUSEADDR true) ; - LU.(bind main_socket (ADDR_INET (addr, port))) ; - LU.listen main_socket limits.max_connections ; - Lwt.return (Some main_socket) - end - (fun exn -> - debug "(%a) cannot accept incoming peers (%s)" - pp_gid my_gid (string_of_unix_exn exn) ; - Lwt.return_none) - >>= function - | None -> - (* FIXME: run in degraded mode, better exit ? *) - Lwt.return_unit - | Some main_socket -> - (* then loop *) - let rec step () = - Lwt.pick - [ ( LU.accept main_socket >>= fun (s, a) -> - Lwt.return (Some (s, a)) ) ; - ( cancelation () >>= fun _ -> - Lwt.return_none ) ] - >>= function - | None -> - LU.close main_socket - | Some (socket, addr) -> - match addr with - | LU.ADDR_INET (addr, port) -> - let addr = Ipaddr_unix.of_inet_addr addr in - Lwt_pipe.push events (Contact ((addr, port), socket)) >>= - step - | _ -> - Lwt.async (fun () -> LU.close socket) ; - step () - in step () - in - (* input maintenance events *) - let too_many_peers = LC.create () in - let too_few_peers = LC.create () in - let new_peer = LC.create () in - let new_contact = LC.create () in - let please_maintain = LC.create () in - let restart_discovery = LC.create () in - (* output maintenance events *) - let just_maintained = LC.create () in - (* maintenance worker, returns when [connections] peers are connected *) - let rec maintenance () = - Lwt.pick - [ ( LU.sleep 120. >>= fun () -> - Lwt.return_true) ; (* every two minutes *) - ( LC.wait please_maintain >>= fun () -> - Lwt.return_true) ; (* when asked *) - ( LC.wait too_few_peers >>= fun () -> - Lwt.return_true) ; (* limits *) - ( LC.wait too_many_peers >>= fun () -> - Lwt.return_true) ; - ( cancelation () >>= fun () -> - Lwt.return_false) ] >>= fun continue -> - let rec maintain () = - let n_connected = PeerMap.cardinal !connected in - if n_connected >= limits.expected_connections - && n_connected <= limits.max_connections then - (* end of maintenance when enough users have been reached *) - (LC.broadcast just_maintained () ; - debug "(%a) maintenance step ended" - pp_gid my_gid ; - maintenance ()) - else if n_connected < limits.expected_connections then - (* too few peers, try and contact many peers *) - let contact nb = - let contactable = - (* we sort sources by level (prefered first) *) - PeerMap.bindings !known_peers |> - List.sort (fun (_, _, s1) (_, _, s2) -> compare_sources s1 s2) |> - (* remove the ones we're connect(ed/ing) to and the blacklisted *) - List.filter (fun (point, gid, source) -> - (not (black_listed point) || source.white_listed) - && not (grey_listed point) - && not (gid = Some my_gid) - && not (PeerMap.mem_by_point point !connected) - && not (PointMap.mem point !incoming) - && match gid with | None -> true | Some gid -> - not (PeerMap.mem_by_gid gid !connected)) in - let rec do_contact_loop strec = - match strec with - | 0, _ -> Lwt.return_true - | _, [] -> - Lwt.return_false (* we didn't manage to contact enough peers *) - | nb, ((addr, port), gid, source) :: tl -> - (* we try to open a connection *) - let socket = - let open LU in - let open Ipaddr in - let family = - match addr with V4 _ -> PF_INET | V6 _ -> PF_INET6 in - socket family SOCK_STREAM 0 in - let uaddr = Ipaddr_unix.to_inet_addr addr in - Lwt.catch begin fun () -> - debug "(%a) trying to connect to %a:%d" - pp_gid my_gid Ipaddr.pp_hum addr port ; - Lwt.pick - [ (Lwt_unix.sleep 2.0 >>= fun _ -> Lwt.fail Not_found) ; - LU.connect socket (LU.ADDR_INET (uaddr, port)) - ] >>= fun () -> - debug "(%a) connected to %a:%d" - pp_gid my_gid Ipaddr.pp_hum addr port; - Lwt_pipe.push events - (Contact ((addr, port), socket)) >>= fun () -> - Lwt.return (nb - 1) - end - (fun exn -> - debug "(%a) connection failed to %a:%d (%s)" - pp_gid my_gid Ipaddr.pp_hum addr port - (string_of_unix_exn exn); - (* if we didn't succes, we greylist it *) - let now = Unix.gettimeofday () in - known_peers := - PeerMap.update (addr, port) ?gid - { source with unreachable_since = Some now } - !known_peers ; - LU.close socket >>= fun () -> - Lwt.return nb) >>= fun nrec -> - do_contact_loop (nrec, tl) - in do_contact_loop (nb, contactable) - in - let to_contact = limits.max_connections - n_connected in - debug "(%a) too few connections (%d)" pp_gid my_gid n_connected ; - contact to_contact >>= function - | true -> (* enough contacts, now wait for connections *) - Lwt.pick - [ (LC.wait new_peer >>= fun _ -> Lwt.return_true) ; - (LU.sleep 1.0 >>= fun () -> Lwt.return_true) ; - (cancelation () >>= fun () -> Lwt.return_false) ] - >>= fun continue -> - if continue then maintain () else Lwt.return_unit - | false -> (* not enough contacts, ask the pals of our pals, - discover the local network and then wait *) - LC.broadcast restart_discovery () ; - (PeerMap.iter - (fun _ _ peer -> Lwt.async (fun () -> peer.send Bootstrap)) - !connected ; - Lwt.pick - [ (LC.wait new_peer >>= fun _ -> Lwt.return_true) ; - (LC.wait new_contact >>= fun _ -> Lwt.return_true) ; - (LU.sleep 1.0 >>= fun () -> Lwt.return_true) ; - (cancelation () >>= fun () -> Lwt.return_false) ] - >>= fun continue -> - if continue then maintain () else Lwt.return_unit) - else - (* too many peers, start the russian roulette *) - let to_kill = n_connected - limits.max_connections in - debug "(%a) too many connections, will kill %d" pp_gid my_gid to_kill ; - snd (PeerMap.fold - (fun _ _ peer (i, t) -> - if i = 0 then (0, t) - else (i - 1, t >>= fun () -> peer.disconnect ())) - !connected (to_kill, Lwt.return_unit)) >>= fun () -> - (* and directly skip to the next maintenance request *) - LC.broadcast just_maintained () ; - debug "(%a) maintenance step ended" pp_gid my_gid ; - maintenance () - in - if continue then maintain () else Lwt.return_unit - in - (* select the peers to send on a bootstrap request *) - let bootstrap_peers () = - (* we sort peers by desirability *) - PeerMap.bindings !known_peers |> - List.filter (fun ((ip,_),_,_) -> not (Ipaddr.is_private ip)) |> - List.sort (fun (_, _, s1) (_, _, s2) -> compare_sources s1 s2) |> - (* we simply send the first 50 (or less) known peers *) - List.fold_left - (fun (n, l) (point, _, _) -> if n = 0 then (n, l) else (n - 1, point :: l)) - (50, []) |> snd - in - let next_peer_event () = - let rec peer_events () = - let peers = PeerMap.bindings !connected in - let current_peers_evts = - filter_map begin function - | _, Some gid, p -> Some (Lwt_pipe.values_available p.reader >|= fun () -> gid, p.reader) - | _ -> None - end peers - in - Lwt.choose [ - (LC.wait new_peer >>= fun _p -> peer_events ()); - Lwt.nchoose current_peers_evts; - ] - in - peer_events () >>= fun evts -> - let nb_evts = List.length evts in - let gid, evtqueue = List.nth evts (Random.int nb_evts) in - lwt_debug "(%a) Processing event from %a" pp_gid my_gid pp_gid gid >|= fun () -> - Lwt_pipe.pop_now_exn evtqueue - in - let rec peers () = - (* user event handling worker *) - Lwt.pick [ - next_peer_event () ; - cancelation () >>= fun () -> Lwt.return Shutdown ; - ] >>= fun event -> match event with - | Recv (peer, msg) -> Lwt_pipe.push messages (peer, msg) >>= peers - | msg -> Lwt_pipe.push events msg >>= peers - in - (* internal event handling worker *) - let rec admin () = - Lwt.pick - [ Lwt_pipe.pop events ; - cancelation () >>= fun () -> Lwt.return Shutdown ] >>= fun event -> - match event with - | Recv _ -> - (* Invariant broken *) - Lwt.fail_with "admin: got a Recv message (broken invariant)" - | Disconnected peer -> - debug "(%a) disconnected peer %a" pp_gid my_gid pp_gid peer.gid ; - (* remove it from the tables *) - connected := PeerMap.remove_by_point peer.point !connected ; - if PeerMap.cardinal !connected < limits.min_connections then - LC.broadcast too_few_peers () ; - incoming := PointMap.remove peer.point !incoming ; - admin () - | Connected peer -> - incoming := PointMap.remove peer.point !incoming ; - let update_infos () = - (* we update our knowledge table according to the - reachable address given by the peer *) - match peer.listening_port with - | None -> () - | Some port -> - let point = (fst peer.point, port) in - let update source = - (* delete previous infos about this address / gid *) - known_peers := PeerMap.remove_by_point point !known_peers ; - known_peers := PeerMap.remove_by_gid peer.gid !known_peers ; - (* then assign *) - known_peers := - PeerMap.update point ~gid:peer.gid source !known_peers - in update @@ - try match PeerMap.by_gid peer.gid !known_peers with - | { connections = None ; white_listed } -> - { connections = - Some (1, Unix.gettimeofday (), peer.public_key) ; - unreachable_since = None ; - white_listed ; - meta = P.initial_metadata } - | { connections = Some (n, _, _) ; white_listed } -> - { connections = - Some (n + 1, Unix.gettimeofday (), peer.public_key) ; - unreachable_since = None ; - white_listed ; - meta = P.initial_metadata } - with Not_found -> - { connections = - Some (1, Unix.gettimeofday (), peer.public_key) ; - unreachable_since = None ; - white_listed = white_listed point ; - meta = P.initial_metadata } - in - (* if it's me, it's probably not me *) - if my_gid = peer.gid then begin - debug "(%a) rejected myself from %a:%d" - pp_gid my_gid Ipaddr.pp_hum (fst peer.point) (snd peer.point) ; - (* now that I know my address, I can save this info to - prevent future reconnections to myself *) - update_infos () ; - Lwt.async peer.disconnect - end - (* keep only one connection to each node by checking its gid *) - else if PeerMap.mem_by_gid peer.gid !connected then begin - debug "(%a) rejected already connected peer %a @@ %a:%d" - pp_gid my_gid pp_gid peer.gid - Ipaddr.pp_hum (fst peer.point) (snd peer.point) ; - update_infos () ; - Lwt.async peer.disconnect - end else begin - debug "(%a) connected peer %a @@ %a:%d" - pp_gid my_gid pp_gid peer.gid - Ipaddr.pp_hum (fst peer.point) (snd peer.point) ; - update_infos () ; - connected := - PeerMap.update peer.point ~gid:peer.gid peer !connected ; - if PeerMap.cardinal !connected > limits.max_connections then - LC.broadcast too_many_peers () ; - LC.broadcast new_peer peer - end ; - admin () - | Contact ((addr, port), socket) -> - (* we do not check the credentials at this stage, since they - could change from one connection to the next *) - if PointMap.mem (addr, port) !incoming - || PeerMap.mem_by_point (addr, port) !connected - || BlackList.mem addr !black_list then - LU.close socket >>= fun () -> - admin () - else - let canceler = - connect_to_peer - config limits my_gid my_public_key my_secret_key my_proof_of_work - socket (addr, port) events white_listed in - debug "(%a) incoming peer @@ %a:%d" - pp_gid my_gid Ipaddr.pp_hum addr port ; - incoming := PointMap.add (addr, port) canceler !incoming ; - admin () - | Bootstrap peer -> - let sample = bootstrap_peers () in - Lwt.async (fun () -> peer.send (Advertise sample)) ; - admin () - | Peers peers -> - List.iter - (fun point -> - if not (PeerMap.mem_by_point point !known_peers) then - let source = - { unreachable_since = None ; - connections = None ; - white_listed = false ; - meta = P.initial_metadata } in - known_peers := PeerMap.update point source !known_peers ; - LC.broadcast new_contact point) - peers ; - admin () - | Shutdown -> - Lwt.return_unit - in - (* blacklist filter *) - let rec unblock () = - Lwt.pick - [ (Lwt_unix.sleep 20. >>= fun _ -> Lwt.return_true) ; - (cancelation () >>= fun () -> Lwt.return_false) ] >>= fun continue -> - if continue then - let now = Unix.gettimeofday () in - black_list := BlackList.fold - (fun addr d map -> if d < now then map else BlackList.add addr d map) - !black_list BlackList.empty ; - known_peers := - PeerMap.fold (fun point gid source map -> - let source = - match source.unreachable_since with - | Some t when now -. t < 20. -> source - | _ -> { source with unreachable_since = None } in - PeerMap.update point ?gid source map) - !known_peers PeerMap.empty ; - unblock () - else Lwt.return_unit - in - (* launch all workers *) - let welcome = - Lwt_utils.worker - (Format.asprintf "(%a) welcome" pp_gid my_gid) - welcome cancel in - let maintenance = - Lwt_utils.worker - (Format.asprintf "(%a) maintenance" pp_gid my_gid) - maintenance cancel in - let peers_worker = - Lwt_utils.worker - (Format.asprintf "(%a) peers" pp_gid my_gid) - peers cancel in - let admin = - Lwt_utils.worker - (Format.asprintf "(%a) admin" pp_gid my_gid) - admin cancel in - let unblock = - Lwt_utils.worker - (Format.asprintf "(%a) unblacklister" pp_gid my_gid) - unblock cancel in - let discovery_answerer = - let callback inet_addr port = - let addr = Ipaddr_unix.of_inet_addr inet_addr in - (* do not reply to ourselves or connected peers *) - if not (PeerMap.mem_by_point (addr, port) !connected) - && (try match PeerMap.gid_by_point (addr, port) !known_peers with - | Some gid -> not (PeerMap.mem_by_gid gid !connected) && not (my_gid = gid) - | None -> true - with Not_found -> true) - then - (* connect if we need peers *) - if PeerMap.cardinal !connected >= limits.expected_connections then - Lwt_pipe.push events (Peers [ addr, port ]) - else - let socket = LU.(socket PF_INET6 SOCK_STREAM 0) in - LU.connect socket LU.(ADDR_INET (inet_addr, port)) >>= fun () -> - Lwt_pipe.push events (Contact ((addr, port), socket)) - else Lwt.return_unit - in - match config.discovery_port with - | None -> Lwt.return_unit - | Some disco_port -> - Lwt_utils.worker - (Format.asprintf "(%a) discovery answerer" pp_gid my_gid) - (fun () -> discovery_answerer my_gid disco_port cancelation callback) - cancel - in - let discovery_sender = - match config.incoming_port, config.discovery_port with - | Some inco_port, Some disco_port -> - let sender () = - discovery_sender - my_gid disco_port inco_port cancelation restart_discovery in - Lwt_utils.worker - (Format.asprintf "(%a) discovery sender" pp_gid my_gid) - sender cancel - | _ -> Lwt.return_unit in - (* net manipulation callbacks *) - let rec shutdown () = - debug "(%a) starting network shutdown" pp_gid my_gid ; - (* stop accepting clients *) - cancel () >>= fun () -> - (* wait for both workers to end *) - Lwt.join [ welcome ; peers_worker ; admin ; maintenance ; unblock ; - discovery_answerer ; discovery_sender ] >>= fun () -> - (* properly shutdown all peers *) - let cancelers = - PeerMap.fold - (fun point _ peer res -> - (peer.disconnect () >>= fun () -> - connected := PeerMap.remove_by_point point !connected ; - Lwt.return_unit) :: res) - !connected @@ - PointMap.fold - (fun point canceler res -> - (canceler () >>= fun () -> - incoming := PointMap.remove point !incoming ; - Lwt.return_unit) :: res) - !incoming @@ [] - in - Lwt.join cancelers >>= fun () -> - debug "(%a) network shutdown complete" pp_gid my_gid ; - Lwt.return_unit - and peers () = - PeerMap.fold (fun _ _ peer r -> peer :: r) !connected [] - and find_peer gid = - try Some (PeerMap.by_gid gid !connected) with Not_found -> None - and peer_info (peer : peer) = { - gid = peer.gid ; - addr = fst peer.point ; - port = snd peer.point ; - version = peer.version ; - total_sent = peer.total_sent () ; - total_recv = peer.total_recv () ; - current_outflow = peer.current_outflow () ; - current_inflow = peer.current_inflow () ; + let create ~config ~limits meta_cfg msg_cfg = + let io_sched = create_scheduler limits in + create_connection_pool + config limits meta_cfg msg_cfg io_sched >>= fun pool -> + let discoverer = may_create_discovery_worker config pool in + let maintenance = create_maintenance_worker limits pool discoverer in + may_create_welcome_worker config limits pool >>= fun welcome -> + Lwt.return { + config ; + limits ; + io_sched ; + pool ; + discoverer ; + maintenance ; + welcome ; } - and recv_from () = - Lwt_pipe.pop messages - and send_to peer msg = - peer.send (Message msg) - and try_send_to peer msg = - peer.try_send (Message msg) - and broadcast msg = - PeerMap.iter - (fun _ _ peer -> - Lwt.async (fun () -> peer.send (Message msg))) - !connected - and blacklist ?(duration = limits.blacklist_time) addr = - let t = Unix.gettimeofday () +. duration in - black_list := BlackList.add addr t !black_list ; - debug "(%a) address %a blacklisted" pp_gid my_gid Ipaddr.pp_hum addr ; - (* we ban this peer, but also all the ones at this address, even - when whitelisted (the blacklist operation wins) *) - known_peers := - PeerMap.fold - (fun ((a, _) as point) gid p map -> - if a = addr then map else PeerMap.update point ?gid p map) - !known_peers PeerMap.empty ; - (* we disconnect all peers at this address sur-le-champ *) - PeerMap.iter - (fun (a, _) _ p -> if addr = a then - Lwt.async (fun () -> p.disconnect ())) - !connected ; - (* and prevent incoming connections *) - PointMap.iter - (fun (a, _) cancel -> if a = addr then Lwt.async cancel) - !incoming - and whitelist_point point = - let source, gid = try - { (PeerMap.by_point point !known_peers) - with white_listed = true }, - PeerMap.gid_by_point point !known_peers - with Not_found -> - { unreachable_since = None ; - connections = None ; - white_listed = true ; - meta = P.initial_metadata }, - None in - known_peers := PeerMap.update point ?gid source !known_peers - and whitelist peer = - (* we promote this peer to the white list, if reachable *) - match peer.listening_port with - | Some port -> - let point = fst peer.point, port in - whitelist_point point - | None -> () + let gid { config } = config.identity.gid - and maintain () = - let waiter = LC.wait just_maintained in - LC.broadcast please_maintain () ; - waiter - and roll () = Pervasives.failwith "roll" - and get_metadata _gid = None (* TODO: implement *) - and set_metadata _gid _meta = () (* TODO: implement *) - in - let net = - { gid = my_gid ; shutdown ; peers ; find_peer ; - recv_from ; send_to ; try_send_to ; broadcast ; - blacklist ; whitelist ; maintain ; roll ; - peer_info ; get_metadata ; set_metadata } in - (* main thread, returns after first successful maintenance *) - maintain () >>= fun () -> - debug "(%a) network succesfully bootstrapped" pp_gid my_gid ; - Lwt.return net + let maintain { maintenance } () = + P2p_maintenance.maintain maintenance - let faked_network = - let gid = String.make 16 '\000' in - let infinity, wakeup = Lwt.wait () in - let shutdown () = - Lwt.wakeup_exn wakeup Queue.Empty; - Lwt.return_unit in - let peers () = [] in - let find_peer _ = None in - let recv_from () = infinity in - let send_to _ _ = Lwt.return_unit in - let try_send_to _ _ = true in - let broadcast _ = () in - let blacklist ?duration _ = ignore duration ; () in - let whitelist _ = () in - let maintain () = Lwt.return_unit in - let roll () = Lwt.return_unit in - let peer_info _ = assert false in - let get_metadata _ = None in - let set_metadata _ _ = () in - { gid ; shutdown ; peers ; find_peer ; - recv_from ; send_to ; try_send_to ; broadcast ; - blacklist ; whitelist ; maintain ; roll ; - peer_info ; get_metadata ; set_metadata } + let roll _net () = Lwt.return_unit (* TODO implement *) + (* returns when all workers have shutted down in the opposite + creation order. *) + let shutdown net () = + Lwt_utils.may ~f:P2p_welcome.shutdown net.welcome >>= fun () -> + P2p_maintenance.shutdown net.maintenance >>= fun () -> + Lwt_utils.may ~f:P2p_discovery.shutdown net.discoverer >>= fun () -> + P2p_connection_pool.destroy net.pool >>= fun () -> + P2p_io_scheduler.shutdown net.io_sched + + let connections { pool } () = + P2p_connection_pool.fold_connections pool + ~init:[] ~f:(fun _gid c acc -> c :: acc) + let find_connection { pool } gid = + P2p_connection_pool.Gids.find_connection pool gid + let connection_info _net conn = + P2p_connection_pool.connection_info conn + let connection_stat _net conn = + P2p_connection_pool.connection_stat conn + let global_stat { pool } () = + P2p_connection_pool.pool_stat pool + let set_metadata { pool } conn meta = + P2p_connection_pool.Gids.set_metadata pool conn meta + let get_metadata { pool } conn = + P2p_connection_pool.Gids.get_metadata pool conn + + let rec recv _net conn = + P2p_connection_pool.read conn + + let rec recv_any net () = + let pipes = + P2p_connection_pool.fold_connections + net.pool ~init:[] ~f:begin fun _gid conn acc -> + (P2p_connection_pool.is_readable conn >>= function + | Ok () -> Lwt.return conn + | Error _ -> Lwt_utils.never_ending) :: acc + end in + Lwt.pick pipes >>= fun conn -> + P2p_connection_pool.read conn >>= function + | Ok msg -> + Lwt.return (conn, msg) + | Error _ -> + Lwt_unix.yield () >>= fun () -> + recv_any net () + + let send _net c m = + P2p_connection_pool.write c m >>= function + | Ok () -> Lwt.return_unit + | Error _ -> Lwt.fail End_of_file (* temporary *) + + let try_send _net c v = + match P2p_connection_pool.write_now c v with + | Ok v -> v + | Error _ -> false + + let broadcast { pool } msg = P2p_connection_pool.write_all pool msg - (* Plug toplevel functions to callback calls. *) - let gid net = net.gid - let shutdown net = net.shutdown () - let peers net = net.peers () - let find_peer net gid = net.find_peer gid - let peer_info net peer = net.peer_info peer - let recv net = net.recv_from () - let send net peer msg = net.send_to peer msg - let try_send net peer msg = net.try_send_to peer msg - let broadcast net msg = net.broadcast msg - let maintain net = net.maintain () - let roll net = net.roll () - let blacklist _net _gid = () - let whitelist _net _gid = () - let get_metadata net gid = net.get_metadata gid - let set_metadata net gid meta = net.set_metadata gid meta +end + +module Fake = struct + + let id = Identity.generate Crypto_box.default_target + let empty_stat = { + Stat.total_sent = 0 ; + total_recv = 0 ; + current_inflow = 0 ; + current_outflow = 0 ; + } + let connection_info = { + Connection_info.incoming = false ; + gid = id.gid ; + id_point = (Ipaddr.V6.unspecified, None) ; + remote_socket_port = 0 ; + versions = [] ; + } + +end + +type ('msg, 'meta) t = { + gid : Gid.t ; + maintain : unit -> unit Lwt.t ; + roll : unit -> unit Lwt.t ; + shutdown : unit -> unit Lwt.t ; + connections : unit -> ('msg, 'meta) connection list ; + find_connection : Gid.t -> ('msg, 'meta) connection option ; + connection_info : ('msg, 'meta) connection -> Connection_info.t ; + connection_stat : ('msg, 'meta) connection -> Stat.t ; + global_stat : unit -> Stat.t ; + get_metadata : Gid.t -> 'meta option ; + set_metadata : Gid.t -> 'meta -> unit ; + recv : ('msg, 'meta) connection -> 'msg tzresult Lwt.t ; + recv_any : unit -> (('msg, 'meta) connection * 'msg) Lwt.t ; + send : ('msg, 'meta) connection -> 'msg -> unit Lwt.t ; + try_send : ('msg, 'meta) connection -> 'msg -> bool ; + broadcast : 'msg -> unit ; +} +type ('msg, 'meta) net = ('msg, 'meta) t + +let bootstrap ~config ~limits meta_cfg msg_cfg = + Real.create ~config ~limits meta_cfg msg_cfg >>= fun net -> + Real.maintain net () >>= fun () -> + Lwt.return { + gid = Real.gid net ; + maintain = Real.maintain net ; + roll = Real.roll net ; + shutdown = Real.shutdown net ; + connections = Real.connections net ; + find_connection = Real.find_connection net ; + connection_info = Real.connection_info net ; + connection_stat = Real.connection_stat net ; + global_stat = Real.global_stat net ; + get_metadata = Real.get_metadata net ; + set_metadata = Real.set_metadata net ; + recv = Real.recv net ; + recv_any = Real.recv_any net ; + send = Real.send net ; + try_send = Real.try_send net ; + broadcast = Real.broadcast net ; + } + +let faked_network = { + gid = Fake.id.gid ; + maintain = Lwt.return ; + roll = Lwt.return ; + shutdown = Lwt.return ; + connections = (fun () -> []) ; + find_connection = (fun _ -> None) ; + connection_info = (fun _ -> Fake.connection_info) ; + connection_stat = (fun _ -> Fake.empty_stat) ; + global_stat = (fun () -> Fake.empty_stat) ; + get_metadata = (fun _ -> None) ; + set_metadata = (fun _ _ -> ()) ; + recv = (fun _ -> Lwt_utils.never_ending) ; + recv_any = (fun () -> Lwt_utils.never_ending) ; + send = (fun _ _ -> Lwt_utils.never_ending) ; + try_send = (fun _ _ -> false) ; + broadcast = ignore ; +} + +let gid net = net.gid +let maintain net = net.maintain () +let roll net = net.roll () +let shutdown net = net.shutdown () +let connections net = net.connections () +let find_connection net = net.find_connection +let connection_info net = net.connection_info +let connection_stat net = net.connection_stat +let global_stat net = net.global_stat () +let get_metadata net = net.get_metadata +let set_metadata net = net.set_metadata +let recv net = net.recv +let recv_any net = net.recv_any () +let send net = net.send +let try_send net = net.try_send +let broadcast net = net.broadcast + +module Raw = struct + type 'a t = 'a P2p_connection_pool.Message.t = + | Bootstrap + | Advertise of P2p_types.Point.t list + | Message of 'a + | Disconnect + let encoding = P2p_connection_pool.Message.encoding end diff --git a/src/node/net/p2p.mli b/src/node/net/p2p.mli index a5ad8767a..06b3dc93e 100644 --- a/src/node/net/p2p.mli +++ b/src/node/net/p2p.mli @@ -8,154 +8,186 @@ (**************************************************************************) (** A peer connection address *) -type addr = Ipaddr.t +type addr = Ipaddr.V6.t (** A peer connection port *) type port = int (** A p2p protocol version *) -type version = { - name : string ; - major : int ; - minor : int ; -} - -(** Network configuration *) -type config = { - (** Tells if incoming connections accepted, precising the TCP port - on which the peer can be reached *) - incoming_port : port option ; - (** Tells if peers should be discovered automatically on the local - network, precising the UDP port to use *) - discovery_port : port option ; - (** List of hard-coded known peers to bootstrap the network from *) - known_peers : (addr * port) list ; - (** The path to the JSON file where the peer cache is loaded / stored *) - peers_file : string ; - (** If [true], the only accepted connections are from peers whose - addresses are in [known_peers] *) - closed_network : bool ; -} - -(** Network capacities *) -type limits = { - (** Maximum length in bytes of network messages *) - max_message_size : int ; - (** Delay after which a non responding peer is considered dead *) - peer_answer_timeout : float ; - (** Minimum number of connections to reach when staring / maitening *) - expected_connections : int ; - (** Strict minimum number of connections (triggers an urgent maintenance) *) - min_connections : int ; - (** Maximum number of connections (exceeding peers are disconnected) *) - max_connections : int ; - (** How long peers can be blacklisted for maintenance *) - blacklist_time : float ; -} +module Version = P2p_types.Version (** A global identifier for a peer, a.k.a. an identity *) -type gid -val pp_gid : Format.formatter -> gid -> unit +module Gid = P2p_types.Gid -type 'msg encoding = Encoding : { +module Identity = P2p_types.Identity + +module Point = P2p_types.Point + +module Id_point = P2p_types.Id_point + +module Connection_info = P2p_types.Connection_info + +module Stat = P2p_types.Stat + +type 'meta meta_config = { + encoding : 'meta Data_encoding.t; + initial : 'meta; +} + +type 'msg app_message_encoding = Encoding : { tag: int ; encoding: 'a Data_encoding.t ; wrap: 'a -> 'msg ; unwrap: 'msg -> 'a option ; max_length: int option ; - } -> 'msg encoding + } -> 'msg app_message_encoding -module type PARAMS = sig +type 'msg message_config = { + encoding : 'msg app_message_encoding list ; + versions : Version.t list; +} - (** Type of message used by higher layers *) - type msg +(** Network configuration *) +type config = { - val encodings : msg encoding list + listening_port : port option; + (** Tells if incoming connections accepted, precising the TCP port + on which the peer can be reached *) - (** Type of metadata associated to an identity *) - type metadata + listening_addr : addr option; + (** When incoming connections are accepted, precising on which + IP adddress the node listen (default: [[::]]). *) - val initial_metadata : metadata - val metadata_encoding : metadata Data_encoding.t - val score : metadata -> float + trusted_points : Point.t list ; + (** List of hard-coded known peers to bootstrap the network from. *) - (** High level protocol(s) talked by the peer. When two peers - initiate a connection, they exchange their list of supported - versions. The chosen one, if any, is the maximum common one (in - lexicographic order) *) - val supported_versions : version list + peers_file : string ; + (** The path to the JSON file where the metadata associated to + gids are loaded / stored. *) + closed_network : bool ; + (** If [true], the only accepted connections are from peers whose + addresses are in [trusted_peers]. *) + + identity : Identity.t ; + (** Cryptographic identity of the peer. *) + + proof_of_work_target : Crypto_box.target ; + (** Expected level of proof of work of peers' identity. *) + +} + +(** Network capacities *) +type limits = { + + authentification_timeout : float ; + (** Delay granted to a peer to perform authentication, in seconds. *) + + min_connections : int ; + (** Strict minimum number of connections (triggers an urgent maintenance) *) + + expected_connections : int ; + (** Targeted number of connections to reach when bootstraping / maitening *) + + max_connections : int ; + (** Maximum number of connections (exceeding peers are disconnected) *) + + backlog : int ; + (** Argument of [Lwt_unix.accept].*) + + max_incoming_connections : int ; + (** Maximum not-yet-authentified incoming connections. *) + + max_download_speed : int option ; + (** Hard-limit in the number of bytes received per second. *) + + max_upload_speed : int option ; + (** Hard-limit in the number of bytes sent per second. *) + + read_buffer_size : int ; + (** Size in bytes of the buffer passed to [Lwt_unix.read]. *) + + read_queue_size : int option ; + write_queue_size : int option ; + incoming_app_message_queue_size : int option ; + incoming_message_queue_size : int option ; + outgoing_message_queue_size : int option ; + (** Various bounds for internal queues. *) + +} + +type ('msg, 'meta) t +type ('msg, 'meta) net = ('msg, 'meta) t + +(** A faked p2p layer, which do not initiate any connection + nor open any listening socket *) +val faked_network : ('msg, 'meta) net + +(** Main network initialisation function *) +val bootstrap : + config:config -> limits:limits -> + 'meta meta_config -> 'msg message_config -> ('msg, 'meta) net Lwt.t + +(** Return one's gid *) +val gid : ('msg, 'meta) net -> Gid.t + +(** A maintenance operation : try and reach the ideal number of peers *) +val maintain : ('msg, 'meta) net -> unit Lwt.t + +(** Voluntarily drop some peers and replace them by new buddies *) +val roll : ('msg, 'meta) net -> unit Lwt.t + +(** Close all connections properly *) +val shutdown : ('msg, 'meta) net -> unit Lwt.t + +(** A connection to a peer *) +type ('msg, 'meta) connection + +(** Access the domain of active peers *) +val connections : ('msg, 'meta) net -> ('msg, 'meta) connection list + +(** Return the active peer with identity [gid] *) +val find_connection : ('msg, 'meta) net -> Gid.t -> ('msg, 'meta) connection option + +(** Access the info of an active peer, if available *) +val connection_info : + ('msg, 'meta) net -> ('msg, 'meta) connection -> Connection_info.t +val connection_stat : + ('msg, 'meta) net -> ('msg, 'meta) connection -> Stat.t +val global_stat : ('msg, 'meta) net -> Stat.t + +(** Accessors for meta information about a global identifier *) +val get_metadata : ('msg, 'meta) net -> Gid.t -> 'meta option +val set_metadata : ('msg, 'meta) net -> Gid.t -> 'meta -> unit + +(** Wait for a message from a given connection. *) +val recv : + ('msg, 'meta) net -> ('msg, 'meta) connection -> 'msg tzresult Lwt.t + +(** Wait for a message from any active connections. *) +val recv_any : + ('msg, 'meta) net -> (('msg, 'meta) connection * 'msg) Lwt.t + +(** [send net peer msg] is a thread that returns when [msg] has been + successfully enqueued in the send queue. *) +val send : + ('msg, 'meta) net -> ('msg, 'meta) connection -> 'msg -> unit Lwt.t + +(** [try_send net peer msg] is [true] if [msg] has been added to the + send queue for [peer], [false] otherwise *) +val try_send : + ('msg, 'meta) net -> ('msg, 'meta) connection -> 'msg -> bool + +(** Send a message to all peers *) +val broadcast : ('msg, 'meta) net -> 'msg -> unit + +(**/**) +module Raw : sig + type 'a t = + | Bootstrap + | Advertise of P2p_types.Point.t list + | Message of 'a + | Disconnect + val encoding: 'msg app_message_encoding list -> 'msg t Data_encoding.t end -module Make (P : PARAMS) : sig - - type net - - (** A faked p2p layer, which do not initiate any connection - nor open any listening socket *) - val faked_network : net - - (** Main network initialisation function *) - val bootstrap : config:config -> limits:limits -> net Lwt.t - - (** Return one's gid *) - val gid : net -> gid - - (** A maintenance operation : try and reach the ideal number of peers *) - val maintain : net -> unit Lwt.t - - (** Voluntarily drop some peers and replace them by new buddies *) - val roll : net -> unit Lwt.t - - (** Close all connections properly *) - val shutdown : net -> unit Lwt.t - - (** A connection to a peer *) - type peer - - (** Access the domain of active peers *) - val peers : net -> peer list - - (** Return the active peer with identity [gid] *) - val find_peer : net -> gid -> peer option - - type peer_info = { - gid : gid ; - addr : addr ; - port : port ; - version : version ; - total_sent : int ; - total_recv : int ; - current_inflow : float ; - current_outflow : float ; - } - - (** Access the info of an active peer, if available *) - val peer_info : net -> peer -> peer_info - - (** Accessors for meta information about a global identifier *) - val get_metadata : net -> gid -> P.metadata option - val set_metadata : net -> gid -> P.metadata -> unit - - (** Wait for a message from any peer in the network *) - val recv : net -> (peer * P.msg) Lwt.t - - (** [send net peer msg] is a thread that returns when [msg] has been - successfully enqueued in the send queue. *) - val send : net -> peer -> P.msg -> unit Lwt.t - - (** [try_send net peer msg] is [true] if [msg] has been added to the - send queue for [peer], [false] otherwise *) - val try_send : net -> peer -> P.msg -> bool - - (** Send a message to all peers *) - val broadcast : net -> P.msg -> unit - - (** Shutdown the connection to all peers at this address and stop the - communications with this machine for [duration] seconds *) - val blacklist : net -> gid -> unit - - (** Keep a connection to this pair as often as possible *) - val whitelist : net -> gid -> unit - -end diff --git a/src/node/net/p2p_connection.ml b/src/node/net/p2p_connection.ml new file mode 100644 index 000000000..07fbc762a --- /dev/null +++ b/src/node/net/p2p_connection.ml @@ -0,0 +1,410 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(* TODO encode/encrypt before to push into the writer pipe. *) +(* TODO patch Sodium.Box to avoid allocation of the encrypted buffer.*) +(* TODO patch Data_encoding for continuation-based binary writer/reader. *) +(* TODO use queue bound by memory size of its elements, not by the + number of elements. *) +(* TODO test `close ~wait:true`. *) +(* TODO nothing in welcoming message proves that the incoming peer is + the owner of the public key... only the first message will + really proves it. Should this to be changed? Not really + important, but... an attacker might forge a random public key + with enough proof of work (hard task), open a connection, wait + infinitly. This would avoid the real peer to talk with us. And + this might also have an influence on its "score". *) + +open P2p_types + +include Logging.Make(struct let name = "p2p.connection" end) + +type error += Decipher_error +type error += Invalid_message_size +type error += Encoding_error +type error += Rejected +type error += Decoding_error +type error += Myself of Id_point.t +type error += Not_enough_proof_of_work of Gid.t + +type cryptobox_data = { + channel_key : Crypto_box.channel_key ; + mutable local_nonce : Crypto_box.nonce ; + mutable remote_nonce : Crypto_box.nonce ; +} + +let header_length = 2 +let crypto_overhead = 18 (* FIXME import from Sodium.Box. *) +let max_content_length = + 1 lsl (header_length * 8) - crypto_overhead + +module Connection_message = struct + + type t = { + port : int option ; + versions : Version.t list ; + public_key : Crypto_box.public_key ; + proof_of_work_stamp : Crypto_box.nonce ; + message_nonce : Crypto_box.nonce ; + } + + let encoding = + let open Data_encoding in + conv + (fun { port ; public_key ; proof_of_work_stamp ; + message_nonce ; versions } -> + let port = match port with None -> 0 | Some port -> port in + (port, public_key, proof_of_work_stamp, + message_nonce, versions)) + (fun (port, public_key, proof_of_work_stamp, + message_nonce, versions) -> + let port = if port = 0 then None else Some port in + { port ; public_key ; proof_of_work_stamp ; + message_nonce ; versions }) + (obj5 + (req "port" uint16) + (req "pubkey" Crypto_box.public_key_encoding) + (req "proof_of_work_stamp" Crypto_box.nonce_encoding) + (req "message_nonce" Crypto_box.nonce_encoding) + (req "versions" (Variable.list Version.encoding))) + + let write fd message = + let encoded_message_len = + Data_encoding.Binary.length encoding message in + fail_unless + (encoded_message_len < max_content_length) + Encoding_error >>=? fun () -> + let len = header_length + encoded_message_len in + let buf = MBytes.create len in + match Data_encoding.Binary.write encoding message buf header_length with + | None -> + fail Encoding_error + | Some last -> + fail_unless (last = len) Encoding_error >>=? fun () -> + MBytes.set_int16 buf 0 encoded_message_len ; + P2p_io_scheduler.write fd buf + + let read fd = + let header_buf = MBytes.create header_length in + P2p_io_scheduler.read_full ~len:header_length fd header_buf >>=? fun () -> + let len = MBytes.get_uint16 header_buf 0 in + let buf = MBytes.create len in + P2p_io_scheduler.read_full ~len fd buf >>=? fun () -> + match Data_encoding.Binary.read encoding buf 0 len with + | None -> + fail Decoding_error + | Some (read_len, message) -> + if read_len <> len then + fail Decoding_error + else + return message + +end + +module Ack = struct + + type t = bool + let ack = MBytes.of_string "\255" + let nack = MBytes.of_string "\000" + + let write fd b = + match b with + | true -> + P2p_io_scheduler.write fd ack + | false -> + P2p_io_scheduler.write fd nack + + let read fd = + let buf = MBytes.create 1 in + P2p_io_scheduler.read_full fd buf >>=? fun () -> + return (buf <> nack) + +end + +type authenticated_fd = + P2p_io_scheduler.connection * Connection_info.t * cryptobox_data + +let kick (fd, _ , _) = + Ack.write fd false >>= fun _ -> + P2p_io_scheduler.close fd >>= fun _ -> + Lwt.return_unit + +(* First step: write and read credentials, makes no difference + whether we're trying to connect to a peer or checking an incoming + connection, both parties must first introduce themselves. *) +let authenticate + ~proof_of_work_target + ~incoming fd (remote_addr, remote_socket_port as point) + ?listening_port identity supported_versions = + let local_nonce = Crypto_box.random_nonce () in + lwt_debug "Sending authenfication to %a" Point.pp point >>= fun () -> + Connection_message.write fd + { public_key = identity.Identity.public_key ; + proof_of_work_stamp = identity.proof_of_work_stamp ; + message_nonce = local_nonce ; + port = listening_port ; + versions = supported_versions } >>=? fun () -> + Connection_message.read fd >>=? fun msg -> + let remote_listening_port = + if incoming then msg.port else Some remote_socket_port in + let id_point = remote_addr, remote_listening_port in + let remote_gid = Crypto_box.hash msg.public_key in + fail_unless + (remote_gid <> identity.Identity.gid) + (Myself id_point) >>=? fun () -> + fail_unless + (Crypto_box.check_proof_of_work + msg.public_key msg.proof_of_work_stamp proof_of_work_target) + (Not_enough_proof_of_work remote_gid) >>=? fun () -> + let channel_key = + Crypto_box.precompute identity.Identity.secret_key msg.public_key in + let info = + { Connection_info.gid = remote_gid ; versions = msg.versions ; incoming ; + id_point ; remote_socket_port ;} in + let cryptobox_data = + { channel_key ; local_nonce ; + remote_nonce = msg.message_nonce } in + return (info, (fd, info, cryptobox_data)) + +type connection = { + info : Connection_info.t ; + fd : P2p_io_scheduler.connection ; + cryptobox_data : cryptobox_data ; +} + +module Reader = struct + + type 'msg t = { + canceler: Canceler.t ; + conn: connection ; + encoding: 'msg Data_encoding.t ; + messages: 'msg tzresult Lwt_pipe.t ; + mutable worker: unit Lwt.t ; + } + + let read_chunk { fd ; cryptobox_data } = + let header_buf = MBytes.create header_length in + P2p_io_scheduler.read_full ~len:header_length fd header_buf >>=? fun () -> + let len = MBytes.get_uint16 header_buf 0 in + let buf = MBytes.create len in + P2p_io_scheduler.read_full ~len fd buf >>=? fun () -> + let remote_nonce = cryptobox_data.remote_nonce in + cryptobox_data.remote_nonce <- Crypto_box.increment_nonce remote_nonce ; + match + Crypto_box.fast_box_open cryptobox_data.channel_key buf remote_nonce + with + | None -> + fail Decipher_error + | Some buf -> + return buf + + let rec read_message st buf = + return (Data_encoding.Binary.of_bytes st.encoding buf) + + let rec worker_loop st = + Lwt_unix.yield () >>= fun () -> + Lwt_utils.protect ~canceler:st.canceler begin fun () -> + read_chunk st.conn >>=? fun buf -> + read_message st buf + end >>= function + | Ok None -> + Lwt_pipe.push st.messages (Error [Decoding_error]) >>= fun () -> + worker_loop st + | Ok (Some msg) -> + Lwt_pipe.push st.messages (Ok msg) >>= fun () -> + worker_loop st + | Error [Lwt_utils.Canceled | Exn Lwt_pipe.Closed] -> + Lwt.return_unit + | Error _ as err -> + Lwt_pipe.push st.messages err >>= fun () -> + Canceler.cancel st.canceler >>= fun () -> + Lwt.return_unit + + let run ?size conn encoding canceler = + let st = + { canceler ; conn ; encoding ; + messages = Lwt_pipe.create ?size () ; + worker = Lwt.return_unit ; + } in + Canceler.on_cancel st.canceler begin fun () -> + Lwt_pipe.close st.messages ; + Lwt.return_unit + end ; + st.worker <- + Lwt_utils.worker "reader" + (fun () -> worker_loop st) + (fun () -> Canceler.cancel st.canceler) ; + st + + let shutdown st = + Canceler.cancel st.canceler >>= fun () -> + st.worker + +end + +module Writer = struct + + type 'msg t = { + canceler: Canceler.t ; + conn: connection ; + encoding: 'msg Data_encoding.t ; + messages: ('msg * unit tzresult Lwt.u option) Lwt_pipe.t ; + mutable worker: unit Lwt.t ; + } + + let write_chunk { cryptobox_data ; fd } buf = + let header_buf = MBytes.create header_length in + let local_nonce = cryptobox_data.local_nonce in + cryptobox_data.local_nonce <- Crypto_box.increment_nonce local_nonce ; + let encrypted_message = + Crypto_box.fast_box cryptobox_data.channel_key buf local_nonce in + let encrypted_len = MBytes.length encrypted_message in + fail_unless + (encrypted_len < max_content_length) + Invalid_message_size >>=? fun () -> + MBytes.set_int16 header_buf 0 encrypted_len ; + P2p_io_scheduler.write fd header_buf >>=? fun () -> + P2p_io_scheduler.write fd encrypted_message >>=? fun () -> + return () + + let encode_message st msg = + try return (Data_encoding.Binary.to_bytes st.encoding msg) + with _ -> fail Encoding_error + + let rec worker_loop st = + Lwt_unix.yield () >>= fun () -> + Lwt_utils.protect ~canceler:st.canceler begin fun () -> + Lwt_pipe.pop st.messages >>= fun (msg, wakener) -> + encode_message st msg >>=? fun buf -> + write_chunk st.conn buf >>= fun res -> + iter_option wakener ~f:(fun u -> Lwt.wakeup_later u res) ; + Lwt.return res + end >>= function + | Ok () -> + worker_loop st + | Error [Lwt_utils.Canceled | Exn Lwt_pipe.Closed] -> + Lwt.return_unit + | Error err -> + lwt_log_error + "@[Error while writing to %a@ %a@]" + Connection_info.pp st.conn.info pp_print_error err >>= fun () -> + Canceler.cancel st.canceler >>= fun () -> + Lwt.return_unit + + let run ?size conn encoding canceler = + let st = + { canceler ; conn ; encoding ; + messages = Lwt_pipe.create ?size () ; + worker = Lwt.return_unit ; + } in + Canceler.on_cancel st.canceler begin fun () -> + Lwt_pipe.close st.messages ; + Lwt.return_unit + end ; + st.worker <- + Lwt_utils.worker "writer" + (fun () -> worker_loop st) + (fun () -> Canceler.cancel st.canceler) ; + st + + let shutdown st = + Canceler.cancel st.canceler >>= fun () -> + st.worker + +end + +type 'msg t = { + conn : connection ; + reader : 'msg Reader.t ; + writer : 'msg Writer.t ; +} + +let pp ppf { conn } = Connection_info.pp ppf conn.info +let info { conn } = conn.info + +let accept + ?incoming_message_queue_size ?outgoing_message_queue_size + (fd, info, cryptobox_data) encoding = + Lwt_utils.protect begin fun () -> + Ack.write fd true >>=? fun () -> + Ack.read fd + end ~on_error:begin fun err -> + P2p_io_scheduler.close fd >>= fun _ -> + Lwt.return (Error err) + end >>=? fun accepted -> + fail_unless accepted Rejected >>=? fun () -> + let canceler = Canceler.create () in + let conn = { fd ; info ; cryptobox_data } in + let reader = + Reader.run ?size:incoming_message_queue_size conn encoding canceler + and writer = + Writer.run ?size:outgoing_message_queue_size conn encoding canceler in + let conn = { conn ; reader ; writer } in + Canceler.on_cancel canceler begin fun () -> + P2p_io_scheduler.close fd >>= fun _ -> + Lwt.return_unit + end ; + return conn + +exception Not_available +exception Connection_closed + +let catch_closed_pipe f = + Lwt.catch f begin function + | Lwt_pipe.Closed -> fail P2p_io_scheduler.Connection_closed + | exn -> fail (Exn exn) + end + +let is_writable { writer } = + not (Lwt_pipe.is_full writer.messages) +let wait_writable { writer } = + Lwt_pipe.not_full writer.messages +let write { writer } msg = + catch_closed_pipe begin fun () -> + Lwt_pipe.push writer.messages (msg, None) >>= return + end +let write_sync { writer } msg = + catch_closed_pipe begin fun () -> + let waiter, wakener = Lwt.wait () in + Lwt_pipe.push writer.messages (msg, Some wakener) >>= fun () -> + waiter + end +let write_now { writer } msg = + try Ok (Lwt_pipe.push_now writer.messages (msg, None)) + with Lwt_pipe.Closed -> Error [P2p_io_scheduler.Connection_closed] + +let is_readable { reader } = + not (Lwt_pipe.is_empty reader.messages) +let wait_readable { reader } = + catch_closed_pipe begin fun () -> + Lwt_pipe.values_available reader.messages >>= return + end +let read { reader } = + catch_closed_pipe begin fun () -> + Lwt_pipe.pop reader.messages + end +let read_now { reader } = + try Lwt_pipe.pop_now reader.messages + with Lwt_pipe.Closed -> Some (Error [P2p_io_scheduler.Connection_closed]) + +let stat { conn = { fd } } = P2p_io_scheduler.stat fd + +let close ?(wait = false) st = + begin + if not wait then Lwt.return_unit + else begin + Lwt_pipe.close st.reader.messages ; + Lwt_pipe.close st.writer.messages ; + st.writer.worker + end + end >>= fun () -> + Reader.shutdown st.reader >>= fun () -> + Writer.shutdown st.writer >>= fun () -> + P2p_io_scheduler.close st.conn.fd >>= fun _ -> + Lwt.return_unit diff --git a/src/node/net/p2p_connection.mli b/src/node/net/p2p_connection.mli new file mode 100644 index 000000000..8d335a68c --- /dev/null +++ b/src/node/net/p2p_connection.mli @@ -0,0 +1,119 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(** This modules adds message encoding and encryption to + [P2p_io_scheduler]'s generic throttled connections. + + Each connection have an associated internal read (resp. write) + queue containing messages (of type ['msg]), whose size can be + limited by providing corresponding arguments to [accept]. +*) + +open P2p_types + +(** {1 Types} *) + +type error += Decipher_error +type error += Invalid_message_size +type error += Encoding_error +type error += Decoding_error +type error += Rejected +type error += Myself of Id_point.t +type error += Not_enough_proof_of_work of Gid.t + +type authenticated_fd +(** Type of a connection that successfully passed the authentication + phase, but has not been accepted yet. *) + +type 'msg t +(** Type of an accepted connection, parametrized by the type of + messages exchanged between peers. *) + +val pp : Format.formatter -> 'msg t -> unit +val info: 'msg t -> Connection_info.t + +(** {1 Low-level functions (do not use directly)} *) + +val authenticate: + proof_of_work_target:Crypto_box.target -> + incoming:bool -> + P2p_io_scheduler.connection -> Point.t -> + ?listening_port: int -> + Identity.t -> Version.t list -> + (Connection_info.t * authenticated_fd) tzresult Lwt.t +(** (Low-level) (Cancelable) Authentication function of a remote + peer. Used in [P2p_connection_pool], to promote a + [P2P_io_scheduler.connection] into an [authenticated_fd] (auth + correct, acceptation undecided). *) + +val kick: authenticated_fd -> unit Lwt.t +(** (Low-level) (Cancelable) [kick afd] notifies the remote peer that + we refuse this connection and then closes [afd]. Used in + [P2p_connection_pool] to reject an [aunthenticated_fd] which we do + not want to connect to for some reason. *) + +val accept: + ?incoming_message_queue_size:int -> + ?outgoing_message_queue_size:int -> + authenticated_fd -> 'msg Data_encoding.t -> 'msg t tzresult Lwt.t +(** (Low-level) (Cancelable) Accepts a remote peer given an + authenticated_fd. Used in [P2p_connection_pool], to promote an + [authenticated_fd] to the status of an active peer. *) + +(** {1 IO functions on connections} *) + +(** {2 Output functions} *) + +val is_writable: 'msg t -> bool +(** [is_writable conn] is [true] iff [conn] internal write queue is + not full. *) + +val wait_writable: 'msg t -> unit Lwt.t +(** (Cancelable) [wait_writable conn] returns when [conn]'s internal + write queue becomes writable (i.e. not full). *) + +val write: 'msg t -> 'msg -> unit tzresult Lwt.t +(** [write conn msg] returns when [msg] has successfully been added to + [conn]'s internal write queue or fails with a corresponding + error. *) + +val write_now: 'msg t -> 'msg -> bool tzresult +(** [write_now conn msg] is [Ok true] if [msg] has been added to + [conn]'s internal write queue, [Ok false] if [msg] has been + dropped, or fails with a correponding error otherwise. *) + +val write_sync: 'msg t -> 'msg -> unit tzresult Lwt.t +(** [write_sync conn msg] returns when [msg] has been successfully + sent to the remote end of [conn], or fails accordingly. *) + +(** {2 Input functions} *) + +val is_readable: 'msg t -> bool +(** [is_readable conn] is [true] iff [conn] internal read queue is not + empty. *) + +val wait_readable: 'msg t -> unit tzresult Lwt.t +(** (Cancelable) [wait_readable conn] returns when [conn]'s internal + read queue becomes readable (i.e. not empty). *) + +val read: 'msg t -> 'msg tzresult Lwt.t +(** [read conn msg] returns when [msg] has successfully been popped + from [conn]'s internal read queue or fails with a corresponding + error. *) + +val read_now: 'msg t -> 'msg tzresult option +(** [read_now conn msg] is [Some msg] if [conn]'s internal read queue + is not empty, [None] if it is empty, or fails with a correponding + error otherwise. *) + +val stat: 'msg t -> Stat.t +(** [stat conn] is a snapshot of current bandwidth usage for + [conn]. *) + +val close: ?wait:bool -> 'msg t -> unit Lwt.t diff --git a/src/node/net/p2p_connection_pool.ml b/src/node/net/p2p_connection_pool.ml new file mode 100644 index 000000000..dc437985a --- /dev/null +++ b/src/node/net/p2p_connection_pool.ml @@ -0,0 +1,667 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(* TODO check version negotiation *) + +(* TODO Test cancelation of a (pending) connection *) + +(* TODO do not recompute list_known_points at each requests... but + only once in a while, e.g. every minutes or when a point + or the associated gid is blacklisted. *) + +(* TODO allow to track "requested gids" when we reconnect to a point. *) + +open P2p_types +open P2p_connection_pool_types + +include Logging.Make (struct let name = "p2p.connection-pool" end) + +type 'msg encoding = Encoding : { + tag: int ; + encoding: 'a Data_encoding.t ; + wrap: 'a -> 'msg ; + unwrap: 'msg -> 'a option ; + max_length: int option ; + } -> 'msg encoding + +module Message = struct + + type 'msg t = + | Bootstrap + | Advertise of Point.t list + | Message of 'msg + | Disconnect + + let encoding msg_encoding = + let open Data_encoding in + union ~tag_size:`Uint16 + ([ case ~tag:0x01 null + (function Disconnect -> Some () | _ -> None) + (fun () -> Disconnect); + case ~tag:0x02 null + (function Bootstrap -> Some () | _ -> None) + (fun () -> Bootstrap); + case ~tag:0x03 (Variable.list Point.encoding) + (function Advertise points -> Some points | _ -> None) + (fun points -> Advertise points); + ] @ + ListLabels.map msg_encoding + ~f:(function Encoding { tag ; encoding ; wrap ; unwrap } -> + case ~tag encoding + (function Message msg -> unwrap msg | _ -> None) + (fun msg -> Message (wrap msg)))) + +end + + +module Answerer = struct + + type 'msg callback = { + bootstrap: unit -> Point.t list Lwt.t ; + advertise: Point.t list -> unit Lwt.t ; + message: 'msg -> unit Lwt.t ; + } + + type 'msg t = { + canceler: Canceler.t ; + conn: 'msg Message.t P2p_connection.t ; + callback: 'msg callback ; + mutable worker: unit Lwt.t ; + } + + let rec worker_loop st = + Lwt_unix.yield () >>= fun () -> + Lwt_utils.protect ~canceler:st.canceler begin fun () -> + P2p_connection.read st.conn + end >>= function + | Ok Bootstrap -> begin + st.callback.bootstrap () >>= function + | [] -> + worker_loop st + | points -> + match P2p_connection.write_now st.conn (Advertise points) with + | Ok _sent -> + (* if not sent then ?? TODO count dropped message ?? *) + worker_loop st + | Error _ -> + Canceler.cancel st.canceler >>= fun () -> + Lwt.return_unit + end + | Ok (Advertise points) -> + st.callback.advertise points >>= fun () -> + worker_loop st + | Ok (Message msg) -> + st.callback.message msg >>= fun () -> + worker_loop st + | Ok Disconnect | Error [P2p_io_scheduler.Connection_closed] -> + Canceler.cancel st.canceler >>= fun () -> + Lwt.return_unit + | Error [Lwt_utils.Canceled] -> + Lwt.return_unit + | Error err -> + lwt_log_error "@[Answerer unexpected error:@ %a@]" + Error_monad.pp_print_error err >>= fun () -> + Canceler.cancel st.canceler >>= fun () -> + Lwt.return_unit + + let run conn canceler callback = + let st = { + canceler ; conn ; callback ; + worker = Lwt.return_unit ; + } in + st.worker <- + Lwt_utils.worker "answerer" + (fun () -> worker_loop st) + (fun () -> Canceler.cancel canceler) ; + st + + let shutdown st = + Canceler.cancel st.canceler >>= fun () -> + st.worker + +end + +type config = { + + identity : Identity.t ; + proof_of_work_target : Crypto_box.target ; + + trusted_points : Point.t list ; + peers_file : string ; + closed_network : bool ; + + listening_port : port option ; + min_connections : int ; + max_connections : int ; + max_incoming_connections : int ; + authentification_timeout : float ; + + incoming_app_message_queue_size : int option ; + incoming_message_queue_size : int option ; + outgoing_message_queue_size : int option ; + +} + +type 'meta meta_config = { + encoding : 'meta Data_encoding.t; + initial : 'meta; +} + +type 'msg message_config = { + encoding : 'msg encoding list ; + versions : P2p_types.Version.t list; +} + +type ('msg, 'meta) t = { + config : config ; + meta_config : 'meta meta_config ; + message_config : 'msg message_config ; + my_id_points : unit Point.Table.t ; + known_gids : (('msg, 'meta) connection, 'meta) Gid_info.t Gid.Table.t ; + connected_gids : (('msg, 'meta) connection, 'meta) Gid_info.t Gid.Table.t ; + known_points : ('msg, 'meta) connection Point_info.t Point.Table.t ; + connected_points : ('msg, 'meta) connection Point_info.t Point.Table.t ; + incoming : Canceler.t Point.Table.t ; + io_sched : P2p_io_scheduler.t ; + encoding : 'msg Message.t Data_encoding.t ; + events : events ; +} + +and events = { + too_few_connections : unit Lwt_condition.t ; + too_many_connections : unit Lwt_condition.t ; + new_point : unit Lwt_condition.t ; +} + +and ('msg, 'meta) connection = { + canceler : Canceler.t ; + messages : 'msg Lwt_pipe.t ; + conn : 'msg Message.t P2p_connection.t ; + gid_info : (('msg, 'meta) connection, 'meta) Gid_info.t ; + point_info : ('msg, 'meta) connection Point_info.t option ; + answerer : 'msg Answerer.t ; + mutable wait_close : bool ; +} + +type ('msg, 'meta) pool = ('msg, 'meta) t + +let register_point pool ?trusted (addr, port as point) = + match Point.Table.find pool.known_points point with + | exception Not_found -> + let pi = Point_info.create ?trusted addr port in + Point.Table.add pool.known_points point pi ; + pi + | pi -> pi + +let register_peer pool gid = + match Gid.Table.find pool.known_gids gid with + | exception Not_found -> + Lwt_condition.broadcast pool.events.new_point () ; + let peer = Gid_info.create gid ~metadata:pool.meta_config.initial in + Gid.Table.add pool.known_gids gid peer ; + peer + | peer -> peer + +let register_new_point pool _gid point = + if not (Point.Table.mem pool.my_id_points point) then + ignore (register_point pool point) + +let register_new_points pool gid points = + List.iter (register_new_point pool gid) points ; + Lwt.return_unit + +let compare_known_point_info p1 p2 = + (* The most-recently disconnected peers are greater. *) + (* Then come long-standing connected peers. *) + let disconnected1 = Point_info.State.is_disconnected p1 + and disconnected2 = Point_info.State.is_disconnected p2 in + let compare_last_seen p1 p2 = + match Point_info.last_seen p1, Point_info.last_seen p2 with + | None, None -> Random.int 2 * 2 - 1 (* HACK... *) + | Some _, None -> 1 + | None, Some _ -> -1 + | Some (_, time1), Some (_, time2) -> + match compare time1 time2 with + | 0 -> Random.int 2 * 2 - 1 (* HACK... *) + | x -> x in + match disconnected1, disconnected2 with + | false, false -> compare_last_seen p1 p2 + | false, true -> -1 + | true, false -> 1 + | true, true -> compare_last_seen p2 p1 + +let list_known_points pool _gid () = + let knowns = + Point.Table.fold (fun _ pi acc -> pi :: acc) pool.known_points [] in + let best_knowns = + Utils.take_n ~compare:compare_known_point_info 50 knowns in + Lwt.return (List.map Point_info.point best_knowns) + +let active_connections pool = Gid.Table.length pool.connected_gids + +let create_connection pool conn id_point pi gi = + let gid = Gid_info.gid gi in + let canceler = Canceler.create () in + let messages = + Lwt_pipe.create ?size:pool.config.incoming_app_message_queue_size () in + let callback = + { Answerer.message = Lwt_pipe.push messages ; + advertise = register_new_points pool gid ; + bootstrap = list_known_points pool gid ; + } in + let answerer = Answerer.run conn canceler callback in + let conn = + { conn ; point_info = pi ; gid_info = gi ; + messages ; canceler ; answerer ; wait_close = false } in + iter_option pi ~f:begin fun pi -> + Point_info.State.set_running pi gid conn ; + Point.Table.add pool.connected_points (Point_info.point pi) pi ; + end ; + Gid_info.State.set_running gi id_point conn ; + Gid.Table.add pool.connected_gids gid gi ; + Canceler.on_cancel canceler begin fun () -> + lwt_debug "Disconnect: %a (%a)" + Gid.pp gid Id_point.pp id_point >>= fun () -> + iter_option ~f:Point_info.State.set_disconnected pi; + Gid_info.State.set_disconnected gi ; + iter_option pi ~f:begin fun pi -> + Point.Table.remove pool.connected_points (Point_info.point pi) ; + end ; + Gid.Table.remove pool.connected_gids gid ; + if pool.config.max_connections <= active_connections pool then + Lwt_condition.broadcast pool.events.too_many_connections () ; + P2p_connection.close ~wait:conn.wait_close conn.conn + end ; + if active_connections pool < pool.config.min_connections then + Lwt_condition.broadcast pool.events.too_few_connections () ; + conn + +let disconnect ?(wait = false) conn = + conn.wait_close <- wait ; + Canceler.cancel conn.canceler >>= fun () -> + conn.answerer.worker + +type error += Rejected of Gid.t +type error += Unexpected_point_state +type error += Unexpected_gid_state + +let may_register_my_id_point pool = function + | [P2p_connection.Myself (addr, Some port)] -> + Point.Table.add pool.my_id_points (addr, port) () ; + Point.Table.remove pool.known_points (addr, port) + | _ -> () + +let authenticate pool ?pi canceler fd point = + let incoming = pi = None in + lwt_debug "authenticate: %a%s" + Point.pp point + (if incoming then " incoming" else "") >>= fun () -> + Lwt_utils.protect ~canceler begin fun () -> + P2p_connection.authenticate + ~proof_of_work_target:pool.config.proof_of_work_target + ~incoming (P2p_io_scheduler.register pool.io_sched fd) point + ?listening_port:pool.config.listening_port + pool.config.identity pool.message_config.versions + end ~on_error: begin fun err -> + (* TODO do something when the error is Not_enough_proof_of_work ?? *) + lwt_debug "authenticate: %a%s -> failed %a" + Point.pp point + (if incoming then " incoming" else "") + pp_print_error err >>= fun () -> + may_register_my_id_point pool err ; + if incoming then + Point.Table.remove pool.incoming point + else + iter_option Point_info.State.set_disconnected pi ; + Lwt.return (Error err) + end >>=? fun (info, auth_fd) -> + lwt_debug "authenticate: %a -> auth %a" + Point.pp point + Connection_info.pp info >>= fun () -> + let remote_pi = + match info.id_point with + | addr, Some port + when not (Point.Table.mem pool.my_id_points (addr, port)) -> + Some (register_point pool (addr, port)) + | _ -> None in + let connection_pi = + match pi, remote_pi with + | None, None -> None + | Some _ as pi, _ | _, (Some _ as pi) -> pi in + let gi = register_peer pool info.gid in + let acceptable_point = + unopt_map connection_pi + ~default:(not pool.config.closed_network) + ~f:begin fun connection_pi -> + match Point_info.State.get connection_pi with + | Requested _ -> not incoming + | Disconnected -> + not pool.config.closed_network + || Point_info.trusted connection_pi + | Accepted _ | Running _ -> false + end + in + let acceptable_gid = + match Gid_info.State.get gi with + | Accepted _ -> + (* TODO: in some circumstances cancel and accept... *) + false + | Running _ -> false + | Disconnected -> true + in + if incoming then Point.Table.remove pool.incoming point ; + if not acceptable_gid || not acceptable_point then begin + lwt_debug "authenticate: %a -> kick %a point: %B gid: %B" + Point.pp point + Connection_info.pp info + acceptable_point acceptable_gid >>= fun () -> + P2p_connection.kick auth_fd >>= fun () -> + if not incoming then begin + iter_option ~f:Point_info.State.set_disconnected pi ; + (* FIXME Gid_info.State.set_disconnected ~requested:true gi ; *) + end ; + fail (Rejected info.gid) + end else begin + iter_option connection_pi + ~f:(fun pi -> Point_info.State.set_accepted pi info.gid canceler) ; + Gid_info.State.set_accepted gi info.id_point canceler ; + lwt_debug "authenticate: %a -> accept %a" + Point.pp point + Connection_info.pp info >>= fun () -> + Lwt_utils.protect ~canceler begin fun () -> + P2p_connection.accept + ?incoming_message_queue_size:pool.config.incoming_message_queue_size + ?outgoing_message_queue_size:pool.config.outgoing_message_queue_size + auth_fd pool.encoding >>= fun conn -> + lwt_debug "authenticate: %a -> Connected %a" + Point.pp point + Connection_info.pp info >>= fun () -> + Lwt.return conn + end ~on_error: begin fun err -> + lwt_debug "authenticate: %a -> rejected %a" + Point.pp point + Connection_info.pp info >>= fun () -> + iter_option connection_pi ~f:Point_info.State.set_disconnected; + Gid_info.State.set_disconnected gi ; + Lwt.return (Error err) + end >>=? fun conn -> + let id_point = + match info.id_point, map_option Point_info.point pi with + | (addr, _), Some (_, port) -> addr, Some port + | id_point, None -> id_point in + return (create_connection pool conn id_point connection_pi gi) + end + +type error += Pending_connection +type error += Connected +type error += Connection_closed = P2p_io_scheduler.Connection_closed +type error += Connection_refused +type error += Closed_network + +let fail_unless_disconnected_point pi = + match Point_info.State.get pi with + | Disconnected -> return () + | Requested _ | Accepted _ -> fail Pending_connection + | Running _ -> fail Connected + +let fail_unless_disconnected_gid gi = + match Gid_info.State.get gi with + | Disconnected -> return () + | Accepted _ -> fail Pending_connection + | Running _ -> fail Connected + +let raw_connect canceler pool point = + let pi = register_point pool point in + let addr, port as point = Point_info.point pi in + fail_unless + (not pool.config.closed_network || Point_info.trusted pi) + Closed_network >>=? fun () -> + fail_unless_disconnected_point pi >>=? fun () -> + Point_info.State.set_requested pi canceler ; + let fd = Lwt_unix.socket PF_INET6 SOCK_STREAM 0 in + let uaddr = + Lwt_unix.ADDR_INET (Ipaddr_unix.V6.to_inet_addr addr, port) in + lwt_debug "connect: %a" Point.pp point >>= fun () -> + Lwt_utils.protect ~canceler begin fun () -> + Lwt_unix.connect fd uaddr >>= fun () -> + return () + end ~on_error: begin fun err -> + lwt_debug "connect: %a -> disconnect" Point.pp point >>= fun () -> + Point_info.State.set_disconnected pi ; + match err with + | [Exn (Unix.Unix_error (Unix.ECONNREFUSED, _, _))] -> + fail Connection_refused + | err -> Lwt.return (Error err) + end >>=? fun () -> + lwt_debug "connect: %a -> authenticate" Point.pp point >>= fun () -> + authenticate pool ~pi canceler fd point + +type error += Too_many_connections + +let connect ~timeout pool point = + fail_unless + (active_connections pool <= pool.config.max_connections) + Too_many_connections >>=? fun () -> + let canceler = Canceler.create () in + Lwt_utils.with_timeout ~canceler timeout begin fun canceler -> + raw_connect canceler pool point + end + +let accept pool fd point = + if pool.config.max_incoming_connections <= Point.Table.length pool.incoming + || pool.config.max_connections <= active_connections pool then + Lwt.async (fun () -> Lwt_utils.safe_close fd) + else + let canceler = Canceler.create () in + Point.Table.add pool.incoming point canceler ; + Lwt.async begin fun () -> + Lwt_utils.with_timeout + ~canceler pool.config.authentification_timeout + (fun canceler -> authenticate pool canceler fd point) + end + + +(***************************************************************************) + +let read { messages } = + Lwt.catch + (fun () -> Lwt_pipe.pop messages >>= return) + (fun _ (* Closed *) -> fail P2p_io_scheduler.Connection_closed) + +let is_readable { messages } = + Lwt.catch + (fun () -> Lwt_pipe.values_available messages >>= return) + (fun _ (* Closed *) -> fail P2p_io_scheduler.Connection_closed) + +let write { conn } msg = + P2p_connection.write conn (Message msg) + +let write_sync { conn } msg = + P2p_connection.write_sync conn (Message msg) + +let write_now { conn } msg = + P2p_connection.write_now conn (Message msg) + +let write_all pool msg = + Gid.Table.iter + (fun _gid gi -> + match Gid_info.State.get gi with + | Running { data = conn } -> + ignore (write_now conn msg : bool tzresult ) + | _ -> ()) + pool.connected_gids + +let broadcast_bootstrap_msg pool = + Gid.Table.iter + (fun _gid gi -> + match Gid_info.State.get gi with + | Running { data = { conn } } -> + ignore (P2p_connection.write_now conn Bootstrap : bool tzresult ) + | _ -> ()) + pool.connected_gids + + +(***************************************************************************) + +module Gids = struct + + type ('msg, 'meta) info = (('msg, 'meta) connection, 'meta) Gid_info.t + + let info { known_gids } point = + try Some (Gid.Table.find known_gids point) + with Not_found -> None + + let get_metadata pool gid = + try Some (Gid_info.metadata (Gid.Table.find pool.known_gids gid)) + with Not_found -> None + + let set_metadata pool gid data = + Gid_info.set_metadata (register_peer pool gid) data + + let get_trusted pool gid = + try Gid_info.trusted (Gid.Table.find pool.known_gids gid) + with Not_found -> false + + let set_trusted pool gid = + try Gid_info.set_trusted (register_peer pool gid) + with Not_found -> () + + let unset_trusted pool gid = + try Gid_info.unset_trusted (Gid.Table.find pool.known_gids gid) + with Not_found -> () + + let find_connection pool gid = + apply_option + (info pool gid) + ~f:(fun p -> + match Gid_info.State.get p with + | Running { data } -> Some data + | _ -> None) + + let fold_known pool ~init ~f = + Gid.Table.fold f pool.known_gids init + let fold_connected pool ~init ~f = + Gid.Table.fold f pool.connected_gids init + +end + +let fold_connections pool ~init ~f = + Gids.fold_connected pool ~init ~f:begin fun gid gi acc -> + match Gid_info.State.get gi with + | Running { data } -> f gid data acc + | _ -> acc + end + +module Points = struct + + type ('msg, 'meta) info = ('msg, 'meta) connection Point_info.t + + let info { known_points } point = + try Some (Point.Table.find known_points point) + with Not_found -> None + + let get_trusted pool gid = + try Point_info.trusted (Point.Table.find pool.known_points gid) + with Not_found -> false + + let set_trusted pool gid = + try Point_info.set_trusted (register_point pool gid) + with Not_found -> () + + let unset_trusted pool gid = + try Point_info.unset_trusted (Point.Table.find pool.known_points gid) + with Not_found -> () + + let find_connection pool point = + apply_option + (info pool point) + ~f:(fun p -> + match Point_info.State.get p with + | Running { data } -> Some data + | _ -> None) + + let fold_known pool ~init ~f = + Point.Table.fold f pool.known_points init + + let fold_connected pool ~init ~f = + Point.Table.fold f pool.connected_points init + +end + +module Events = struct + let too_few_connections pool = + Lwt_condition.wait pool.events.too_few_connections + let too_many_connections pool = + Lwt_condition.wait pool.events.too_many_connections + let new_point pool = + Lwt_condition.wait pool.events.new_point +end + + +let connection_stat { conn } = + P2p_connection.stat conn + +let pool_stat { io_sched } = + P2p_io_scheduler.global_stat io_sched + +let connection_info { conn } = + P2p_connection.info conn + +(***************************************************************************) + +let create config meta_config message_config io_sched = + let events = { + too_few_connections = Lwt_condition.create () ; + too_many_connections = Lwt_condition.create () ; + new_point = Lwt_condition.create () ; + } in + let pool = { + config ; meta_config ; message_config ; + my_id_points = Point.Table.create 7 ; + known_gids = Gid.Table.create 53 ; + connected_gids = Gid.Table.create 53 ; + known_points = Point.Table.create 53 ; + connected_points = Point.Table.create 53 ; + incoming = Point.Table.create 53 ; + io_sched ; + encoding = Message.encoding message_config.encoding ; + events ; + } in + List.iter (Points.set_trusted pool) config.trusted_points ; + Lwt.catch + (fun () -> + Gid_info.File.load config.peers_file meta_config.encoding) + (fun _ -> + (* TODO log error *) + Lwt.return_nil) >>= fun gids -> + List.iter + (fun gi -> Gid.Table.add pool.known_gids (Gid_info.gid gi) gi) + gids ; + Lwt.return pool + +let destroy pool = + Point.Table.fold (fun _point pi acc -> + match Point_info.State.get pi with + | Requested { cancel } | Accepted { cancel } -> + Canceler.cancel cancel >>= fun () -> acc + | Running { data = conn } -> + disconnect conn >>= fun () -> acc + | Disconnected -> acc) + pool.known_points @@ + Gid.Table.fold (fun _gid gi acc -> + match Gid_info.State.get gi with + | Accepted { cancel } -> + Canceler.cancel cancel >>= fun () -> acc + | Running { data = conn } -> + disconnect conn >>= fun () -> acc + | Disconnected -> acc) + pool.known_gids @@ + Point.Table.fold (fun _point canceler acc -> + Canceler.cancel canceler >>= fun () -> acc) + pool.incoming Lwt.return_unit diff --git a/src/node/net/p2p_connection_pool.mli b/src/node/net/p2p_connection_pool.mli new file mode 100644 index 000000000..27ef938c0 --- /dev/null +++ b/src/node/net/p2p_connection_pool.mli @@ -0,0 +1,290 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(** Pool of connections. This module manages the connection pool that + the shell needs to maintain in order to function correctly. + + A pool and its connections are parametrized by the type of + messages exchanged over the connection and the type of + meta-information associated with a peer. The type [('msg, 'meta) + connection] is a wrapper on top of [P2p_connection.t] that adds + meta-information, a data-structure describing a fine-grained state + of the connection, as well as a new message queue (referred to + "app message queue") that will only contain the messages from the + internal [P2p_connection.t] that needs to be examined by the + higher layers. Some messages are directly processed by an internal + worker and thus never propagated above. +*) + +open P2p_types +open P2p_connection_pool_types + +type 'msg encoding = Encoding : { + tag: int ; + encoding: 'a Data_encoding.t ; + wrap: 'a -> 'msg ; + unwrap: 'msg -> 'a option ; + max_length: int option ; + } -> 'msg encoding + +(** {1 Pool management} *) + +type ('msg, 'meta) t + +type ('msg, 'meta) pool = ('msg, 'meta) t +(** The type of a pool of connections, parametrized by resp. the type + of messages and the meta-information associated to an identity. *) + +type config = { + + identity : Identity.t ; + (** Our identity. *) + + proof_of_work_target : Crypto_box.target ; + (** The proof of work target we require from peers. *) + + trusted_points : Point.t list ; + (** List of hard-coded known peers to bootstrap the network from. *) + + peers_file : string ; + (** The path to the JSON file where the metadata associated to + gids are loaded / stored. *) + + closed_network : bool ; + (** If [true], the only accepted connections are from peers whose + addresses are in [trusted_peers]. *) + + listening_port : port option ; + (** If provided, it will be passed to [P2p_connection.authenticate] + when we authenticate against a new peer. *) + + min_connections : int ; + (** Strict minimum number of connections + (triggers [Event.too_few_connections]). *) + + max_connections : int ; + (** Max number of connections. If it's reached, [connect] and + [accept] will fail, i.e. not add more connections + (also triggers [Event.too_many_connections]). *) + + max_incoming_connections : int ; + (** Max not-yet-authentified incoming connections. + Above this number, [accept] will start dropping incoming + connections. *) + + authentification_timeout : float ; + (** Delay granted to a peer to perform authentication, in seconds. *) + + incoming_app_message_queue_size : int option ; + (** Size of the message queue for user messages (messages returned + by this module's [read] function. *) + + incoming_message_queue_size : int option ; + (** Size of the incoming message queue internal of a peer's Reader + (See [P2p_connection.accept]). *) + + outgoing_message_queue_size : int option ; + (** Size of the outgoing message queue internal to a peer's Writer + (See [P2p_connection.accept]). *) +} + +type 'meta meta_config = { + encoding : 'meta Data_encoding.t; + initial : 'meta; +} + +type 'msg message_config = { + encoding : 'msg encoding list ; + versions : P2p_types.Version.t list; +} + +val create: + config -> + 'meta meta_config -> + 'msg message_config -> + P2p_io_scheduler.t -> + ('msg, 'meta) pool Lwt.t +(** [create config meta_cfg msg_cfg io_sched] is a freshly minted + pool. *) + +val destroy: ('msg, 'meta) pool -> unit Lwt.t +(** [destroy pool] returns when member connections are either + disconnected or canceled. *) + +val active_connections: ('msg, 'meta) pool -> int +(** [active_connections pool] is the number of connections inside + [pool]. *) + +val pool_stat: ('msg, 'meta) pool -> Stat.t +(** [pool_stat pool] is a snapshot of current bandwidth usage for the + entire [pool]. *) + +(** {2 Pool events} *) + +module Events : sig + val too_few_connections: ('msg, 'meta) pool -> unit Lwt.t + val too_many_connections: ('msg, 'meta) pool -> unit Lwt.t + val new_point: ('msg, 'meta) pool -> unit Lwt.t +end + +(** {1 Connections management} *) + +type ('msg, 'meta) connection +(** Type of a connection to a peer, parametrized by the type of + messages exchanged as well as meta-information associated to a + peer. It mostly wraps [P2p_connection.connection], adding + meta-information and data-structures describing a more + fine-grained logical state of the connection. *) + +type error += Pending_connection +type error += Connected +type error += Connection_refused +type error += Rejected of Gid.t +type error += Too_many_connections +type error += Closed_network + +val connect: + timeout:float -> + ('msg, 'meta) pool -> Point.t -> + ('msg, 'meta) connection tzresult Lwt.t +(** [connect ~timeout pool point] tries to add a + connection to [point] in [pool] in less than [timeout] seconds. *) + +val accept: + ('msg, 'meta) pool -> Lwt_unix.file_descr -> Point.t -> unit +(** [accept pool fd point] instructs [pool] to start the process of + accepting a connection from [fd]. Used by [P2p]. *) + +val disconnect: + ?wait:bool -> ('msg, 'meta) connection -> unit Lwt.t +(** [disconnect conn] cleanly closes [conn] and returns after [conn]'s + internal worker has returned. *) + +val connection_info: ('msg, 'meta) connection -> Connection_info.t + +val connection_stat: ('msg, 'meta) connection -> Stat.t +(** [stat conn] is a snapshot of current bandwidth usage for + [conn]. *) + +val fold_connections: + ('msg, 'meta) pool -> + init:'a -> + f:(Gid.t -> ('msg, 'meta) connection -> 'a -> 'a) -> + 'a + +(** {1 I/O on connections} *) + +type error += Connection_closed + +val read: ('msg, 'meta) connection -> 'msg tzresult Lwt.t +(** [read conn] returns a message popped from [conn]'s app message + queue, or fails with [Connection_closed]. *) + +val is_readable: ('msg, 'meta) connection -> unit tzresult Lwt.t +(** [is_readable conn] returns when there is at least one message + ready to be read. *) + +val write: ('msg, 'meta) connection -> 'msg -> unit tzresult Lwt.t +(** [write conn msg] is [P2p_connection.write conn' msg] where [conn'] + is the internal [P2p_connection.t] inside [conn]. *) + +val write_sync: ('msg, 'meta) connection -> 'msg -> unit tzresult Lwt.t +(** [write_sync conn msg] is [P2p_connection.write_sync conn' msg] + where [conn'] is the internal [P2p_connection.t] inside [conn]. *) + +val write_now: ('msg, 'meta) connection -> 'msg -> bool tzresult +(** [write_now conn msg] is [P2p_connection.write_now conn' msg] where + [conn'] is the internal [P2p_connection.t] inside [conn]. *) + +(** {2 Broadcast functions} *) + +val write_all: ('msg, 'meta) pool -> 'msg -> unit +(** [write_all pool msg] is [write_now conn msg] for all member + connections to [pool] in [Running] state. *) + +val broadcast_bootstrap_msg: ('msg, 'meta) pool -> unit +(** [write_all pool msg] is [P2P_connection.write_now conn Bootstrap] + for all member connections to [pool] in [Running] state. *) + +(** {1 Functions on [Gid]} *) + +module Gids : sig + + type ('msg, 'meta) info = (('msg, 'meta) connection, 'meta) Gid_info.t + + val info: + ('msg, 'meta) pool -> Gid.t -> ('msg, 'meta) info option + + val get_metadata: ('msg, 'meta) pool -> Gid.t -> 'meta option + val set_metadata: ('msg, 'meta) pool -> Gid.t -> 'meta -> unit + + val get_trusted: ('msg, 'meta) pool -> Gid.t -> bool + val set_trusted: ('msg, 'meta) pool -> Gid.t -> unit + val unset_trusted: ('msg, 'meta) pool -> Gid.t -> unit + + val find_connection: + ('msg, 'meta) pool -> Gid.t -> ('msg, 'meta) connection option + + val fold_known: + ('msg, 'meta) pool -> + init:'a -> + f:(Gid.t -> ('msg, 'meta) info -> 'a -> 'a) -> + 'a + + val fold_connected: + ('msg, 'meta) pool -> + init:'a -> + f:(Gid.t -> ('msg, 'meta) info -> 'a -> 'a) -> + 'a + +end + +(** {1 Functions on [Points]} *) + +module Points : sig + + type ('msg, 'meta) info = ('msg, 'meta) connection Point_info.t + + val info: + ('msg, 'meta) pool -> Point.t -> ('msg, 'meta) info option + + val get_trusted: ('msg, 'meta) pool -> Point.t -> bool + val set_trusted: ('msg, 'meta) pool -> Point.t -> unit + val unset_trusted: ('msg, 'meta) pool -> Point.t -> unit + + val find_connection: + ('msg, 'meta) pool -> Point.t -> ('msg, 'meta) connection option + + val fold_known: + ('msg, 'meta) pool -> + init:'a -> + f:(Point.t -> ('msg, 'meta) info -> 'a -> 'a) -> + 'a + + val fold_connected: + ('msg, 'meta) pool -> + init:'a -> + f:(Point.t -> ('msg, 'meta) info -> 'a -> 'a) -> + 'a + +end + +(**/**) + +module Message : sig + + type 'msg t = + | Bootstrap + | Advertise of Point.t list + | Message of 'msg + | Disconnect + + val encoding: 'msg encoding list -> 'msg t Data_encoding.t + +end diff --git a/src/node/net/p2p_connection_pool_types.ml b/src/node/net/p2p_connection_pool_types.ml new file mode 100644 index 000000000..2e2bcd5f9 --- /dev/null +++ b/src/node/net/p2p_connection_pool_types.ml @@ -0,0 +1,463 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open P2p_types + +module Point_info = struct + + type 'data state = + | Requested of { cancel: Canceler.t } + | Accepted of { current_gid: Gid.t ; + cancel: Canceler.t } + | Running of { data: 'data ; + current_gid: Gid.t } + | Disconnected + + module Event = struct + + type kind = + | Outgoing_request + | Accepting_request of Gid.t + | Rejecting_request of Gid.t + | Request_rejected of Gid.t option + | Connection_established of Gid.t + | Disconnection of Gid.t + | External_disconnection of Gid.t + + type t = { + kind : kind ; + timestamp : Time.t ; + } + + end + + type greylisting_config = { + factor: float ; + initial_delay: int ; + disconnection_delay: int ; + } + + type 'data t = { + point : Point.t ; + mutable trusted : bool ; + mutable state : 'data state ; + mutable last_failed_connection : Time.t option ; + mutable last_rejected_connection : (Gid.t * Time.t) option ; + mutable last_established_connection : (Gid.t * Time.t) option ; + mutable last_disconnection : (Gid.t * Time.t) option ; + greylisting : greylisting_config ; + mutable greylisting_delay : float ; + mutable greylisting_end : Time.t ; + events : Event.t Ring.t ; + } + type 'data point_info = 'data t + + let compare pi1 pi2 = Point.compare pi1.point pi2.point + + let log_size = 100 + + let default_greylisting_config = { + factor = 1.2 ; + initial_delay = 1 ; + disconnection_delay = 60 ; + } + + let create + ?(trusted = false) + ?(greylisting_config = default_greylisting_config) addr port = { + point = (addr, port) ; + trusted ; + state = Disconnected ; + last_failed_connection = None ; + last_rejected_connection = None ; + last_established_connection = None ; + last_disconnection = None ; + events = Ring.create log_size ; + greylisting = greylisting_config ; + greylisting_delay = 1. ; + greylisting_end = Time.now () ; + } + + let point s = s.point + let trusted s = s.trusted + let set_trusted gi = gi.trusted <- true + let unset_trusted gi = gi.trusted <- false + let last_established_connection s = s.last_established_connection + let last_disconnection s = s.last_disconnection + let last_failed_connection s = s.last_failed_connection + let last_rejected_connection s = s.last_rejected_connection + let greylisted ?(now = Time.now ()) s = + Time.compare now s.greylisting_end <= 0 + + let recent a1 a2 = + match a1, a2 with + | (None, None) -> None + | (None, (Some _ as a)) + | (Some _ as a, None) -> a + | (Some (_, t1), Some (_, t2)) -> + if Time.compare t1 t2 < 0 then a2 else a1 + let last_seen s = + recent s.last_rejected_connection + (recent s.last_established_connection s.last_disconnection) + let last_miss s = + match + s.last_failed_connection, + (map_option ~f:(fun (_, time) -> time) @@ + recent s.last_rejected_connection s.last_disconnection) with + | (None, None) -> None + | (None, (Some _ as a)) + | (Some _ as a, None) -> a + | (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 log { events } ?(timestamp = Time.now ()) kind = + Ring.add events { kind ; timestamp } + + let log_incoming_rejection ?timestamp point_info gid = + log point_info ?timestamp (Rejecting_request gid) + + module State = struct + + type 'data t = 'data state = + | Requested of { cancel: Canceler.t } + | Accepted of { current_gid: Gid.t ; + cancel: Canceler.t } + | Running of { data: 'data ; + current_gid: Gid.t } + | Disconnected + type 'data state = 'data t + + let pp ppf = function + | Requested _ -> + Format.fprintf ppf "requested" + | Accepted { current_gid } -> + Format.fprintf ppf "accepted %a" Gid.pp current_gid + | Running { current_gid } -> + Format.fprintf ppf "running %a" Gid.pp current_gid + | Disconnected -> + Format.fprintf ppf "disconnected" + + let get { state } = state + + let is_disconnected { state } = + match state with + | Disconnected -> true + | Requested _ | Accepted _ | Running _ -> false + + let set_requested ?timestamp point_info cancel = + assert begin + match point_info.state with + | Requested _ -> true + | Accepted _ | Running _ -> false + | Disconnected -> true + end ; + point_info.state <- Requested { cancel } ; + log point_info ?timestamp Outgoing_request + + let set_accepted + ?(timestamp = Time.now ()) + point_info current_gid cancel = + (* log_notice "SET_ACCEPTED %a@." Point.pp point_info.point ; *) + assert begin + match point_info.state with + | Accepted _ | Running _ -> false + | Requested _ | Disconnected -> true + end ; + point_info.state <- Accepted { current_gid ; cancel } ; + log point_info ~timestamp (Accepting_request current_gid) + + let set_running + ?(timestamp = Time.now ()) + point_info gid data = + assert begin + match point_info.state with + | Disconnected -> true (* request to unknown gid. *) + | Running _ -> false + | Accepted { current_gid } -> Gid.equal gid current_gid + | Requested _ -> true + end ; + point_info.state <- Running { data ; current_gid = gid } ; + point_info.last_established_connection <- Some (gid, timestamp) ; + log point_info ~timestamp (Connection_established gid) + + let set_greylisted timestamp point_info = + point_info.greylisting_end <- + Time.add + timestamp + (Int64.of_float point_info.greylisting_delay) ; + point_info.greylisting_delay <- + point_info.greylisting_delay *. point_info.greylisting.factor + + let set_disconnected + ?(timestamp = Time.now ()) ?(requested = false) point_info = + let event : Event.kind = + match point_info.state with + | Requested _ -> + set_greylisted timestamp point_info ; + point_info.last_failed_connection <- Some timestamp ; + Request_rejected None + | Accepted { current_gid } -> + set_greylisted timestamp point_info ; + point_info.last_rejected_connection <- + Some (current_gid, timestamp) ; + Request_rejected (Some current_gid) + | Running { current_gid } -> + point_info.greylisting_delay <- + float_of_int point_info.greylisting.initial_delay ; + point_info.greylisting_end <- + Time.add timestamp + (Int64.of_int point_info.greylisting.disconnection_delay) ; + point_info.last_disconnection <- Some (current_gid, timestamp) ; + if requested + then Disconnection current_gid + else External_disconnection current_gid + | Disconnected -> + assert false + in + point_info.state <- Disconnected ; + log point_info ~timestamp event + + end + +end + +module Gid_info = struct + + type 'data state = + | Accepted of { current_point: Id_point.t ; + cancel: Canceler.t } + | Running of { data: 'data ; + current_point: Id_point.t } + | Disconnected + + module Event = struct + + type kind = + | Accepting_request + | Rejecting_request + | Request_rejected + | Connection_established + | Disconnection + | External_disconnection + + let kind_encoding = + let open Data_encoding in + Data_encoding.string_enum [ + "incoming_request", Accepting_request ; + "rejecting_request", Rejecting_request ; + "request_rejected", Request_rejected ; + "connection_established", Connection_established ; + "disconnection", Disconnection ; + "external_disconnection", External_disconnection ; + ] + + type t = { + kind : kind ; + timestamp : Time.t ; + point : Id_point.t ; + } + + let encoding = + let open Data_encoding in + conv + (fun { kind ; timestamp ; point = (addr, port) } -> + (kind, timestamp, Ipaddr.V6.to_string addr, port)) + (fun (kind, timestamp, addr, port) -> + let addr = Ipaddr.V6.of_string_exn addr in + { kind ; timestamp ; point = (addr, port) }) + (obj4 + (req "kind" kind_encoding) + (req "timestamp" Time.encoding) + (req "addr" string) + (opt "port" int16)) + + end + + type ('conn, 'meta) t = { + gid : Gid.t ; + mutable state : 'conn state ; + mutable metadata : 'meta ; + mutable trusted : bool ; + mutable last_failed_connection : (Id_point.t * Time.t) option ; + mutable last_rejected_connection : (Id_point.t * Time.t) option ; + mutable last_established_connection : (Id_point.t * Time.t) option ; + mutable last_disconnection : (Id_point.t * Time.t) option ; + events : Event.t Ring.t ; + } + type ('conn, 'meta) gid_info = ('conn, 'meta) t + + let compare gi1 gi2 = Gid.compare gi1.gid gi2.gid + + let log_size = 100 + + let create ?(trusted = false) ~metadata gid = + { gid ; + state = Disconnected ; + metadata ; + trusted ; + events = Ring.create log_size ; + last_failed_connection = None ; + last_rejected_connection = None ; + last_established_connection = None ; + last_disconnection = None ; + } + + let encoding metadata_encoding = + let open Data_encoding in + conv + (fun { gid ; trusted ; metadata ; events ; + last_failed_connection ; last_rejected_connection ; + last_established_connection ; last_disconnection } -> + (gid, trusted, metadata, Ring.elements events, + last_failed_connection, last_rejected_connection, + last_established_connection, last_disconnection)) + (fun (gid, trusted, metadata, event_list, + last_failed_connection, last_rejected_connection, + last_established_connection, last_disconnection) -> + let info = create ~trusted ~metadata gid in + let events = Ring.create log_size in + Ring.add_list info.events event_list ; + { state = Disconnected ; + trusted ; gid ; metadata ; events ; + last_failed_connection ; + last_rejected_connection ; + last_established_connection ; + last_disconnection ; + }) + (obj8 + (req "gid" Gid.encoding) + (dft "trusted" bool false) + (req "metadata" metadata_encoding) + (dft "events" (list Event.encoding) []) + (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))) + + let gid { gid } = gid + let metadata { metadata } = metadata + let set_metadata gi metadata = gi.metadata <- metadata + 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 last_established_connection s = s.last_established_connection + let last_disconnection s = s.last_disconnection + let last_failed_connection s = s.last_failed_connection + let last_rejected_connection s = s.last_rejected_connection + + let recent = Point_info.recent + let last_seen s = + recent + s.last_established_connection + (recent s.last_rejected_connection s.last_disconnection) + let last_miss s = + recent + s.last_failed_connection + (recent s.last_rejected_connection s.last_disconnection) + + let log { events } ?(timestamp = Time.now ()) point kind = + Ring.add events { kind ; timestamp ; point } + + let log_incoming_rejection ?timestamp gid_info point = + log gid_info ?timestamp point Rejecting_request + + module State = struct + + type 'data t = 'data state = + | Accepted of { current_point: Id_point.t ; + cancel: Canceler.t } + | Running of { data: 'data ; + current_point: Id_point.t } + | Disconnected + type 'data state = 'data t + + let pp ppf = function + | Accepted { current_point } -> + Format.fprintf ppf "accepted %a" Id_point.pp 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 is_disconnected { state } = + match state with + | Disconnected -> true + | Accepted _ | Running _ -> false + + let set_accepted + ?(timestamp = Time.now ()) + gid_info current_point cancel = + assert begin + match gid_info.state with + | Accepted _ | Running _ -> false + | Disconnected -> true + end ; + gid_info.state <- Accepted { current_point ; cancel } ; + log gid_info ~timestamp current_point Accepting_request + + let set_running + ?(timestamp = Time.now ()) + gid_info point data = + assert begin + match gid_info.state with + | Disconnected -> true (* request to unknown gid. *) + | Running _ -> false + | Accepted { current_point } -> + Id_point.equal point current_point + end ; + gid_info.state <- Running { data ; current_point = point } ; + gid_info.last_established_connection <- Some (point, timestamp) ; + log gid_info ~timestamp point Connection_established + + let set_disconnected + ?(timestamp = Time.now ()) ?(requested = false) gid_info = + let current_point, (event : Event.kind) = + match gid_info.state with + | Accepted { current_point } -> + gid_info.last_rejected_connection <- + Some (current_point, timestamp) ; + current_point, Request_rejected + | Running { current_point } -> + gid_info.last_disconnection <- + Some (current_point, timestamp) ; + current_point, + if requested then Disconnection else External_disconnection + | Disconnected -> assert false + in + gid_info.state <- Disconnected ; + log gid_info ~timestamp current_point event + + end + + module File = struct + + let load path metadata_encoding = + let enc = Data_encoding.list (encoding metadata_encoding) in + Data_encoding_ezjsonm.read_file path >|= + map_option ~f:(Data_encoding.Json.destruct enc) >|= + unopt [] + + let save path metadata_encoding peers = + let open Data_encoding in + Data_encoding_ezjsonm.write_file path @@ + Json.construct (list (encoding metadata_encoding)) peers + + end + +end diff --git a/src/node/net/p2p_connection_pool_types.mli b/src/node/net/p2p_connection_pool_types.mli new file mode 100644 index 000000000..8c2c3a584 --- /dev/null +++ b/src/node/net/p2p_connection_pool_types.mli @@ -0,0 +1,265 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open P2p_types + +module Point_info : sig + + type 'conn t + type 'conn point_info = 'conn t + (** Type of info associated to a point. *) + + val compare : 'conn point_info -> 'conn point_info -> int + + type greylisting_config = { + factor: float ; + initial_delay: int ; + disconnection_delay: int ; + } + + val create : + ?trusted:bool -> + ?greylisting_config:greylisting_config -> + addr -> port -> 'conn point_info + (** [create ~trusted addr port] is a freshly minted point_info. If + [trusted] is true, this point is considered trusted and will + be treated as such. *) + + val trusted : 'conn point_info -> bool + (** [trusted pi] is [true] iff [pi] has is trusted, + i.e. "whitelisted". *) + + val set_trusted : 'conn point_info -> unit + val unset_trusted : 'conn point_info -> unit + + val last_failed_connection : + 'conn point_info -> Time.t option + val last_rejected_connection : + 'conn point_info -> (Gid.t * Time.t) option + val last_established_connection : + 'conn point_info -> (Gid.t * Time.t) option + val last_disconnection : + 'conn point_info -> (Gid.t * Time.t) option + + val last_seen : + 'conn point_info -> (Gid.t * Time.t) option + (** [last_seen pi] is the most recent of: + + * last established connection + * last rejected connection + * last disconnection + *) + + val last_miss : + 'conn point_info -> Time.t option + + val greylisted : + ?now:Time.t -> 'conn point_info -> bool + + val point : 'conn point_info -> Point.t + + module State : sig + + type 'conn t = + | Requested of { cancel: Canceler.t } + (** We initiated a connection. *) + | Accepted of { current_gid: Gid.t ; + cancel: Canceler.t } + (** We accepted a incoming connection. *) + | Running of { data: 'conn ; + current_gid: Gid.t } + (** Successfully authentificated connection, normal business. *) + | Disconnected + (** No connection established currently. *) + type 'conn state = 'conn t + + val pp : Format.formatter -> 'conn t -> unit + + val get : 'conn point_info -> 'conn state + + val is_disconnected : 'conn point_info -> bool + + val set_requested : + ?timestamp:Time.t -> + 'conn point_info -> Canceler.t -> unit + + val set_accepted : + ?timestamp:Time.t -> + 'conn point_info -> Gid.t -> Canceler.t -> unit + + val set_running : + ?timestamp:Time.t -> 'conn point_info -> Gid.t -> 'conn -> unit + + val set_disconnected : + ?timestamp:Time.t -> ?requested:bool -> 'conn point_info -> unit + + end + + module Event : sig + + type kind = + | Outgoing_request + (** We initiated a connection. *) + | Accepting_request of Gid.t + (** We accepted a connection after authentifying the remote peer. *) + | Rejecting_request of Gid.t + (** We rejected a connection after authentifying the remote peer. *) + | Request_rejected of Gid.t option + (** The remote peer rejected our connection. *) + | Connection_established of Gid.t + (** We succesfully established a authentified connection. *) + | Disconnection of Gid.t + (** We decided to close the connection. *) + | External_disconnection of Gid.t + (** The connection was closed for external reason. *) + + type t = { + kind : kind ; + timestamp : Time.t ; + } + + end + + val fold_events : + 'conn point_info -> init:'a -> f:('a -> Event.t -> 'a) -> 'a + + val log_incoming_rejection : + ?timestamp:Time.t -> 'conn point_info -> Gid.t -> unit + +end + + +(** Gid info: current and historical information about a gid *) + +module Gid_info : sig + + type ('conn, 'meta) t + type ('conn, 'meta) gid_info = ('conn, 'meta) t + + val compare : ('conn, 'meta) t -> ('conn, 'meta) t -> int + + val create : + ?trusted:bool -> + metadata:'meta -> + Gid.t -> ('conn, 'meta) gid_info + (** [create ~trusted ~meta gid] is a freshly minted gid info for + [gid]. *) + + val gid : ('conn, 'meta) gid_info -> Gid.t + + val metadata : ('conn, 'meta) gid_info -> 'meta + val set_metadata : ('conn, 'meta) gid_info -> 'meta -> unit + + val trusted : ('conn, 'meta) gid_info -> bool + val set_trusted : ('conn, 'meta) gid_info -> unit + val unset_trusted : ('conn, 'meta) gid_info -> unit + + val last_failed_connection : + ('conn, 'meta) gid_info -> (Id_point.t * Time.t) option + val last_rejected_connection : + ('conn, 'meta) gid_info -> (Id_point.t * Time.t) option + val last_established_connection : + ('conn, 'meta) gid_info -> (Id_point.t * Time.t) option + val last_disconnection : + ('conn, 'meta) gid_info -> (Id_point.t * Time.t) option + + val last_seen : + ('conn, 'meta) gid_info -> (Id_point.t * Time.t) option + (** [last_seen gi] is the most recent of: + + * last established connection + * last rejected connection + * last disconnection + *) + + val last_miss : + ('conn, 'meta) gid_info -> (Id_point.t * Time.t) option + (** [last_miss gi] is the most recent of: + + * last failed connection + * last rejected connection + * last disconnection + *) + + module State : sig + + type 'conn t = + | Accepted of { current_point: Id_point.t ; + cancel: Canceler.t } + (** We accepted a incoming connection, we greeted back and + we are waiting for an acknowledgement. *) + | Running of { data: 'conn ; + current_point: Id_point.t } + (** Successfully authentificated connection, normal business. *) + | Disconnected + (** No connection established currently. *) + type 'conn state = 'conn t + + val pp : Format.formatter -> 'conn t -> unit + + val get : ('conn, 'meta) gid_info -> 'conn state + + val is_disconnected : ('conn, 'meta) gid_info -> bool + + val set_accepted : + ?timestamp:Time.t -> + ('conn, 'meta) gid_info -> Id_point.t -> Canceler.t -> unit + + val set_running : + ?timestamp:Time.t -> + ('conn, 'meta) gid_info -> Id_point.t -> 'conn -> unit + + val set_disconnected : + ?timestamp:Time.t -> + ?requested:bool -> + ('conn, 'meta) gid_info -> unit + + end + + module Event : sig + + type kind = + | Accepting_request + (** We accepted a connection after authentifying the remote peer. *) + | Rejecting_request + (** We rejected a connection after authentifying the remote peer. *) + | Request_rejected + (** The remote peer rejected our connection. *) + | Connection_established + (** We succesfully established a authentified connection. *) + | Disconnection + (** We decided to close the connection. *) + | External_disconnection + (** The connection was closed for external reason. *) + + type t = { + kind : kind ; + timestamp : Time.t ; + point : Id_point.t ; + } + + end + + val fold_events : + ('conn, 'meta) gid_info -> init:'a -> f:('a -> Event.t -> 'a) -> 'a + + val log_incoming_rejection : + ?timestamp:Time.t -> + ('conn, 'meta) gid_info -> Id_point.t -> unit + + module File : sig + val load : + string -> 'meta Data_encoding.t -> + ('conn, 'meta) gid_info list Lwt.t + val save : + string -> 'meta Data_encoding.t -> + ('conn, 'meta) gid_info list -> bool Lwt.t + end + +end diff --git a/src/node/net/p2p_discovery.ml b/src/node/net/p2p_discovery.ml new file mode 100644 index 000000000..2f61b286c --- /dev/null +++ b/src/node/net/p2p_discovery.ml @@ -0,0 +1,138 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open P2p_types +include Logging.Make (struct let name = "p2p.discovery" end) + +type t = () +let create _pool = () +let restart () = (() : unit) +let shutdown () = Lwt.return_unit + +let inet_addr = Unix.inet_addr_of_string "ff0e::54:455a:3053" + +module Message = struct + + let encoding = + Data_encoding.(tup3 (Fixed.string 10) Gid.encoding int16) + + let length = Data_encoding.Binary.fixed_length_exn encoding + + let make gid port = + Data_encoding.Binary.to_bytes encoding ("DISCOMAGIC", gid, port) + +end + +(* Sends discover messages into space in an exponentially delayed loop, + restartable using a condition *) +let sender sock saddr my_gid inco_port cancelation restart = + let buf = Message.make my_gid inco_port in + let rec loop delay n = + Lwt.catch + (fun () -> + Lwt_bytes.sendto sock buf 0 Message.length [] saddr >>= fun _nb_sent -> + Lwt.return_unit) + (fun exn -> + lwt_debug "(%a) error broadcasting a discovery request: %a" + Gid.pp my_gid Error_monad.pp (Exn exn)) >>= fun () -> + Lwt.pick + [ (Lwt_unix.sleep delay >>= fun () -> Lwt.return (Some (delay, n + 1))) ; + (cancelation () >>= fun () -> Lwt.return_none) ; + (Lwt_condition.wait restart >>= fun () -> Lwt.return (Some (0.1, 0))) ] + >>= function + | Some (delay, n) when n = 10 -> loop delay 9 + | Some (delay, n) -> loop (delay *. 2.) n + | None -> Lwt.return_unit + in + loop 0.2 1 + +let create_socket (iface, disco_addr, disco_port) = + let usock = Unix.socket PF_INET6 SOCK_DGRAM 0 in + let sock = Lwt_unix.of_unix_file_descr ~blocking:false usock in + let saddr = Unix.ADDR_INET (disco_addr, disco_port) in + Unix.setsockopt usock SO_REUSEADDR true ; + Ipv6_multicast.Unix.bind ?iface usock saddr ; + Ipv6_multicast.Unix.membership ?iface usock disco_addr `Join ; + iface, sock, saddr + +(* +module Answerer = struct + + (* Launch an answer machine for the discovery mechanism, takes a + callback to fill the answers and returns a canceler function *) + let answerer sock my_gid cancelation callback = + (* the answering function *) + let buf = MBytes.create Message.length in + let rec step () = + Lwt.pick + [ (cancelation () >>= fun () -> Lwt.return_none) ; + (Lwt_bytes.recvfrom sock buf 0 Message.length [] >>= fun r -> + Lwt.return (Some r)) ] >>= function + | None -> Lwt.return_unit + | Some (len', Lwt_unix.ADDR_INET (remote_addr, _mcast_port)) + when len' = Message.length -> begin + match (Data_encoding.Binary.of_bytes Message.encoding buf) with + | Some ("DISCOMAGIC", remote_gid, remote_inco_port) + when remote_gid <> my_gid -> + Lwt.catch + (fun () -> callback ~remote_addr ~remote_inco_port) + (fun exn -> + lwt_debug "Error processing a discovery request: %a" + pp_exn exn) >>= + step + | _ -> + step () + end + | Some _ -> step () + in + step () + + let worker_loop st = + let callback ~remote_addr ~remote_inco_port = + let remote_uaddr = Ipaddr_unix.V6.of_inet_addr_exn remote_addr in + P2p_connection_loop.notify_new_peer + in + Lwt.catch + (fun () -> + Lwt_utils.worker + (Format.asprintf "(%a) discovery answerer" Gid.pp my_gid) + (fun () -> answerer fd my_gid cancelation callback) + cancel) + (fun exn -> + lwt_log_error "Discovery answerer not started: %a" + Error_monad.pp (Exn exn)) + +end +let discovery_sender = + match config.pending_authentification_port with + | None -> Lwt.return_unit + | Some inco_port -> + Lwt.catch + (fun () -> + let sender () = + Discovery.sender fd + saddr my_gid inco_port cancelation restart_discovery in + Lwt_utils.worker + (Format.asprintf "(%a) discovery sender" Gid.pp my_gid) + sender cancel) + (fun exn -> + lwt_log_error "Discovery sender not started: %a" + Error_monad.pp (Exn exn)) + + +let discovery_answerer, discovery_sender = + match map_option ~f:create_socket st.config.local_discovery with + | exception exn -> + log_error "Error creating discovery socket: %a" Error_monad.pp (Exn exn) ; + (Lwt.return_unit, Lwt.return_unit) + | None -> Lwt.return_unit, Lwt.return_unit + | Some (iface, fd, saddr) -> + discovery_answerer, discovery_sender + +*) diff --git a/src/node/net/p2p_discovery.mli b/src/node/net/p2p_discovery.mli new file mode 100644 index 000000000..d9c639ab8 --- /dev/null +++ b/src/node/net/p2p_discovery.mli @@ -0,0 +1,13 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type t +val create : ('msg, 'meta) P2p_connection_pool.pool -> t +val restart : t -> unit +val shutdown : t -> unit Lwt.t diff --git a/src/node/net/p2p_io_scheduler.ml b/src/node/net/p2p_io_scheduler.ml new file mode 100644 index 000000000..0a0acb087 --- /dev/null +++ b/src/node/net/p2p_io_scheduler.ml @@ -0,0 +1,449 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(* TODO decide whether we need to preallocate buffers or not. *) + +open P2p_types +include Logging.Make (struct let name = "p2p.io-scheduler" end) + +module Inttbl = Hashtbl.Make(struct + type t = int + let equal (x: int) (y: int) = x = y + let hash = Hashtbl.hash + end) + +let alpha = 0.2 + +module type IO = sig + val name: string + type in_param + val pop: in_param -> MBytes.t tzresult Lwt.t + type out_param + val push: out_param -> MBytes.t -> unit tzresult Lwt.t + val close: out_param -> error list -> unit Lwt.t +end + +module Scheduler(IO : IO) = struct + + type t = { + canceler: Canceler.t ; + mutable worker: unit Lwt.t ; + counter: Moving_average.t ; + max_speed: int option ; + mutable quota: int ; + quota_updated: unit Lwt_condition.t ; + readys: unit Lwt_condition.t ; + readys_high: (connection * MBytes.t tzresult) Queue.t ; + readys_low: (connection * MBytes.t tzresult) Queue.t ; + } + + and connection = { + id: int ; + mutable closed: bool ; + canceler: Canceler.t ; + in_param: IO.in_param ; + out_param: IO.out_param ; + mutable current_pop: MBytes.t tzresult Lwt.t ; + mutable current_push: unit tzresult Lwt.t ; + counter: Moving_average.t ; + mutable quota: int ; + mutable last_quota: int ; + } + + let cancel (conn : connection) err = + if not conn.closed then begin + conn.closed <- true ; + Lwt.catch + (fun () -> IO.close conn.out_param err) + (fun _ -> Lwt.return_unit) >>= fun () -> + Canceler.cancel conn.canceler + end else + Lwt.return_unit + + let waiter st conn = + assert (Lwt.state conn.current_pop <> Sleep) ; + conn.current_pop <- IO.pop conn.in_param ; + Lwt.async begin fun () -> + conn.current_pop >>= fun res -> + conn.current_push >>= fun _ -> + let was_empty = + Queue.is_empty st.readys_high && Queue.is_empty st.readys_low in + if conn.quota > 0 then + Queue.push (conn, res) st.readys_high + else + Queue.push (conn, res) st.readys_low ; + if was_empty then Lwt_condition.broadcast st.readys () ; + Lwt.return_unit + end + + let wait_data st = + let is_empty = + Queue.is_empty st.readys_high && Queue.is_empty st.readys_low in + if is_empty then Lwt_condition.wait st.readys else Lwt.return_unit + + let check_quota st = + if st.max_speed <> None && st.quota < 0 then + Lwt_condition.wait st.quota_updated + else + Lwt_unix.yield () + + let rec worker_loop st = + check_quota st >>= fun () -> + Lwt.pick [ + Canceler.cancelation st.canceler ; + wait_data st + ] >>= fun () -> + if Canceler.canceled st.canceler then + Lwt.return_unit + else + let prio, (conn, msg) = + if not (Queue.is_empty st.readys_high) then + true, (Queue.pop st.readys_high) + else + false, (Queue.pop st.readys_low) + in + match msg with + | Error [Lwt_utils.Canceled] -> + worker_loop st + | Error ([Exn (Lwt_pipe.Closed | + Unix.Unix_error (EBADF, _, _))] as err) -> + cancel conn err >>= fun () -> + worker_loop st + | Error err -> + lwt_debug "Error %a" pp_print_error err >>= fun () -> + cancel conn err >>= fun () -> + worker_loop st + | Ok msg -> + conn.current_push <- begin + IO.push conn.out_param msg >>= function + | Ok () + | Error [Lwt_utils.Canceled] -> + return () + | Error ([Exn (Unix.Unix_error (EBADF, _, _) | + Lwt_pipe.Closed)] as err) -> + cancel conn err >>= fun () -> + return () + | Error err -> + lwt_debug "Error %a" pp_print_error err >>= fun () -> + cancel conn err >>= fun () -> + Lwt.return (Error err) + end ; + let len = MBytes.length msg in + Moving_average.add st.counter len ; + st.quota <- st.quota - len ; + Moving_average.add conn.counter len ; + if prio then conn.quota <- conn.quota - len ; + waiter st conn ; + worker_loop st + + let create max_speed = + let st = { + canceler = Canceler.create () ; + worker = Lwt.return_unit ; + counter = Moving_average.create ~init:0 ~alpha ; + max_speed ; quota = unopt 0 max_speed ; + quota_updated = Lwt_condition.create () ; + readys = Lwt_condition.create () ; + readys_high = Queue.create () ; + readys_low = Queue.create () ; + } in + st.worker <- + Lwt_utils.worker IO.name + (fun () -> worker_loop st) + (fun () -> Canceler.cancel st.canceler) ; + st + + let create_connection st in_param out_param canceler id = + let conn = + { id ; closed = false ; + canceler ; + in_param ; out_param ; + current_pop = Lwt.fail Not_found (* dummy *) ; + current_push = return () ; + counter = Moving_average.create ~init:0 ~alpha ; + quota = 0 ; last_quota = 0 ; + } in + waiter st conn ; + conn + + let update_quota st = + iter_option st.max_speed ~f:begin fun quota -> + st.quota <- (min st.quota 0) + quota ; + Lwt_condition.broadcast st.quota_updated () + end ; + if not (Queue.is_empty st.readys_low) then begin + let tmp = Queue.create () in + Queue.iter + (fun ((conn : connection), _ as msg) -> + if conn.quota > 0 then + Queue.push msg st.readys_high + else + Queue.push msg tmp) + st.readys_low ; + Queue.clear st.readys_low ; + Queue.transfer tmp st.readys_low ; + end + + let shutdown st = + Canceler.cancel st.canceler >>= fun () -> + st.worker + +end + +type error += Connection_closed + +module ReadScheduler = Scheduler(struct + let name = "io_scheduler(read)" + type in_param = Lwt_unix.file_descr * int + let pop (fd, maxlen) = + Lwt.catch + (fun () -> + let buf = MBytes.create maxlen in + Lwt_bytes.read fd buf 0 maxlen >>= fun len -> + if len = 0 then + fail Connection_closed + else + return (MBytes.sub buf 0 len) ) + (function + | Unix.Unix_error(Unix.ECONNRESET, _, _) -> + fail Connection_closed + | exn -> + Lwt.return (error_exn exn)) + type out_param = MBytes.t tzresult Lwt_pipe.t + let push p msg = + Lwt.catch + (fun () -> Lwt_pipe.push p (Ok msg) >>= return) + (fun exn -> fail (Exn exn)) + let close p err = + Lwt.catch + (fun () -> Lwt_pipe.push p (Error err)) + (fun _ -> Lwt.return_unit) + end) + +module WriteScheduler = Scheduler(struct + let name = "io_scheduler(write)" + type in_param = MBytes.t Lwt_pipe.t + let pop p = + Lwt.catch + (fun () -> Lwt_pipe.pop p >>= return) + (fun _ -> fail (Exn Lwt_pipe.Closed)) + type out_param = Lwt_unix.file_descr + let push fd buf = + Lwt.catch + (fun () -> + Lwt_utils.write_mbytes fd buf >>= return) + (function + | Unix.Unix_error(Unix.EPIPE, _, _) + | Lwt.Canceled + | End_of_file -> + fail Connection_closed + | exn -> + Lwt.return (error_exn exn)) + let close _p _err = Lwt.return_unit + end) + +type connection = { + id: int ; + sched: t ; + conn: Lwt_unix.file_descr ; + canceler: Canceler.t ; + read_conn: ReadScheduler.connection ; + read_queue: MBytes.t tzresult Lwt_pipe.t ; + write_conn: WriteScheduler.connection ; + write_queue: MBytes.t Lwt_pipe.t ; + mutable partial_read: MBytes.t option ; +} + +and t = { + mutable closed: bool ; + connected: connection Inttbl.t ; + read_scheduler: ReadScheduler.t ; + write_scheduler: WriteScheduler.t ; + max_upload_speed: int option ; (* bytes per second. *) + max_download_speed: int option ; + read_buffer_size: int ; + read_queue_size: int option ; + write_queue_size: int option ; +} + +let reset_quota st = + let { Moving_average.average = current_inflow } = + Moving_average.stat st.read_scheduler.counter + and { Moving_average.average = current_outflow } = + Moving_average.stat st.write_scheduler.counter in + let nb_conn = Inttbl.length st.connected in + if nb_conn > 0 then begin + let fair_read_quota = current_inflow / nb_conn + and fair_write_quota = current_outflow / nb_conn in + Inttbl.iter + (fun _id conn -> + conn.read_conn.last_quota <- fair_read_quota ; + conn.read_conn.quota <- + (min conn.read_conn.quota 0) + fair_read_quota ; + conn.write_conn.last_quota <- fair_write_quota ; + conn.write_conn.quota <- + (min conn.write_conn.quota 0) + fair_write_quota ; ) + st.connected + end ; + ReadScheduler.update_quota st.read_scheduler ; + WriteScheduler.update_quota st.write_scheduler + +let create + ?max_upload_speed ?max_download_speed + ?read_queue_size ?write_queue_size + ~read_buffer_size + () = + let st = { + closed = false ; + connected = Inttbl.create 53 ; + read_scheduler = ReadScheduler.create max_download_speed ; + write_scheduler = WriteScheduler.create max_upload_speed ; + max_upload_speed ; + max_download_speed ; + read_buffer_size ; + read_queue_size ; + write_queue_size ; + } in + Moving_average.on_update (fun () -> reset_quota st) ; + st + +exception Closed + +let register = + let cpt = ref 0 in + fun st conn -> + if st.closed then begin + Lwt.async (fun () -> Lwt_utils.safe_close conn) ; + raise Closed + end else begin + let id = incr cpt; !cpt in + let canceler = Canceler.create () in + let read_queue = Lwt_pipe.create ?size:st.read_queue_size () + and write_queue = Lwt_pipe.create ?size:st.write_queue_size () in + let read_conn = + ReadScheduler.create_connection + st.read_scheduler (conn, st.read_buffer_size) read_queue canceler id + and write_conn = + WriteScheduler.create_connection + st.write_scheduler write_queue conn canceler id in + Canceler.on_cancel canceler begin fun () -> + Inttbl.remove st.connected id ; + Moving_average.destroy read_conn.counter ; + Moving_average.destroy write_conn.counter ; + Lwt_pipe.close write_queue ; + Lwt_pipe.close read_queue ; + Lwt_utils.safe_close conn + end ; + let conn = { + sched = st ; id ; conn ; canceler ; + read_queue ; read_conn ; + write_queue ; write_conn ; + partial_read = None ; + } in + Inttbl.add st.connected id conn ; + conn + end + +let write { write_queue } msg = + Lwt.catch + (fun () -> Lwt_pipe.push write_queue msg >>= return) + (fun _ -> fail Connection_closed) +let write_now { write_queue } msg = Lwt_pipe.push_now write_queue msg + +let read_from conn ?pos ?len buf msg = + let maxlen = MBytes.length buf in + let pos = unopt 0 pos in + assert (0 <= pos && pos < maxlen) ; + let len = unopt (maxlen - pos) len in + assert (len <= maxlen - pos) ; + match msg with + | Ok msg -> + let msg_len = MBytes.length msg in + let read_len = min len msg_len in + MBytes.blit msg 0 buf pos read_len ; + if read_len < msg_len then + conn.partial_read <- + Some (MBytes.sub msg read_len (msg_len - read_len)) ; + Ok read_len + | Error _ -> + Error [Connection_closed] + +let read_now conn ?pos ?len buf = + match conn.partial_read with + | Some msg -> + conn.partial_read <- None ; + Some (read_from conn ?pos ?len buf (Ok msg)) + | None -> + try + map_option + (read_from conn ?pos ?len buf) + (Lwt_pipe.pop_now conn.read_queue) + with Lwt_pipe.Closed -> Some (Error [Connection_closed]) + +let read conn ?pos ?len buf = + match conn.partial_read with + | Some msg -> + conn.partial_read <- None ; + Lwt.return (read_from conn ?pos ?len buf (Ok msg)) + | None -> + Lwt.catch + (fun () -> + Lwt_pipe.pop conn.read_queue >|= fun msg -> + read_from conn ?pos ?len buf msg) + (fun _ -> fail Connection_closed) + +let read_full conn ?pos ?len buf = + let maxlen = MBytes.length buf in + let pos = unopt 0 pos in + let len = unopt (maxlen - pos) len in + assert (0 <= pos && pos < maxlen) ; + assert (len <= maxlen - pos) ; + let rec loop pos len = + if len = 0 then + return () + else + read conn ~pos ~len buf >>=? fun read_len -> + loop (pos + read_len) (len - read_len) in + loop pos len + +let convert ~ws ~rs = + { Stat.total_sent = ws.Moving_average.total ; + total_recv = rs.Moving_average.total ; + current_outflow = ws.average ; + current_inflow = rs.average ; + } + +let global_stat { read_scheduler ; write_scheduler } = + let rs = Moving_average.stat read_scheduler.counter + and ws = Moving_average.stat write_scheduler.counter in + convert ~rs ~ws + +let stat { read_conn ; write_conn} = + let rs = Moving_average.stat read_conn.counter + and ws = Moving_average.stat write_conn.counter in + convert ~rs ~ws + +let close conn = + Inttbl.remove conn.sched.connected conn.id ; + Lwt_pipe.close conn.write_queue ; + Canceler.cancelation conn.canceler >>= fun () -> + conn.write_conn.current_push >>= fun res -> + Lwt.return res + +let iter_connection { connected } f = + Inttbl.iter f connected + +let shutdown st = + st.closed <- true ; + ReadScheduler.shutdown st.read_scheduler >>= fun () -> + WriteScheduler.shutdown st.write_scheduler >>= fun () -> + Inttbl.fold + (fun _gid conn acc -> close conn >>= fun _ -> acc) + st.connected + Lwt.return_unit diff --git a/src/node/net/p2p_io_scheduler.mli b/src/node/net/p2p_io_scheduler.mli new file mode 100644 index 000000000..9e5d20139 --- /dev/null +++ b/src/node/net/p2p_io_scheduler.mli @@ -0,0 +1,93 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(** IO Scheduling. This module implements generic IO scheduling + between file descriptors. In order to use IO scheduling, the + [register] function must be used to make a file descriptor managed + by a [scheduler].. It will return a value of type [connection] + that must be used to perform IO on the managed file descriptor + using this module's dedicated IO functions (read, write, etc.). + + Each connection is allowed a read (resp. write) quota, which is + for now fairly distributed among connections. + + To each connection is associated a read (resp. write) queue where + data is copied to (resp. read from), at a rate of + max_download_speed / num_connections (resp. max_upload_speed / + num_connections). +*) + +open P2p_types + +type connection +(** Type of a connection. *) + +type t +(** Type of an IO scheduler. *) + +val create: + ?max_upload_speed:int -> + ?max_download_speed:int -> + ?read_queue_size:int -> + ?write_queue_size:int -> + read_buffer_size:int -> + unit -> t +(** [create ~max_upload_speed ~max_download_speed ~read_queue_size + ~write_queue_size ()] is an IO scheduler with specified (global) + max upload (resp. download) speed, and specified read + (resp. write) queue sizes for connections. *) + +val register: t -> Lwt_unix.file_descr -> connection +(** [register sched fd] is a [connection] managed by [sched]. *) + +type error += Connection_closed + +val write: connection -> MBytes.t -> unit tzresult Lwt.t +(** [write conn msg] returns [Ok ()] when [msg] has been added to + [conn]'s write queue, or fail with an error. *) + +val write_now: connection -> MBytes.t -> bool +(** [write_now conn msg] is [true] iff [msg] has been (immediately) + added to [conn]'s write queue, [false] if it has been dropped. *) + +val read_now: + connection -> ?pos:int -> ?len:int -> MBytes.t -> int tzresult option +(** [read_now conn ~pos ~len buf] blits at most [len] bytes from + [conn]'s read queue and returns the number of bytes written in + [buf] starting at [pos]. *) + +val read: + connection -> ?pos:int -> ?len:int -> MBytes.t -> int tzresult Lwt.t +(** Like [read_now], but waits till [conn] read queue has at least one + element instead of failing. *) + +val read_full: + connection -> ?pos:int -> ?len:int -> MBytes.t -> unit tzresult Lwt.t +(** Like [read], but blits exactly [len] bytes in [buf]. *) + +val stat: connection -> Stat.t +(** [stat conn] is a snapshot of current bandwidth usage for + [conn]. *) + +val global_stat: t -> Stat.t +(** [global_stat sched] is a snapshot of [sched]'s bandwidth usage + (sum of [stat conn] for each [conn] in [sched]). *) + +val iter_connection: t -> (int -> connection -> unit) -> unit +(** [iter_connection sched f] applies [f] on each connection managed + by [sched]. *) + +val close: connection -> unit tzresult Lwt.t +(** [close conn] cancels [conn] and returns after any pending data has + been sent. *) + +val shutdown: t -> unit Lwt.t +(** [shutdown sched] returns after all connections managed by [sched] + have been closed and [sched]'s inner worker has successfully + canceled. *) diff --git a/src/node/net/p2p_maintenance.ml b/src/node/net/p2p_maintenance.ml new file mode 100644 index 000000000..2cae195dc --- /dev/null +++ b/src/node/net/p2p_maintenance.ml @@ -0,0 +1,191 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open P2p_types +open P2p_connection_pool_types + +include Logging.Make (struct let name = "p2p.maintenance" end) + +type bounds = { + min_threshold: int ; + min_target: int ; + max_target: int ; + max_threshold: int ; +} + +type 'meta pool = Pool : ('msg, 'meta) P2p_connection_pool.t -> 'meta pool + +type 'meta t = { + canceler: Canceler.t ; + connection_timeout: float ; + bounds: bounds ; + pool: 'meta pool ; + disco: P2p_discovery.t option ; + just_maintained: unit Lwt_condition.t ; + please_maintain: unit Lwt_condition.t ; + mutable worker : unit Lwt.t ; +} + +(** Select [expected] points amongst the disconnected known points. + It ignores points which are greylisted, or for which a connection + failed after [start_time]. It first selects points with the oldest + last tentative. *) +let connectable st start_time expected = + let now = Time.now () in + let module Bounded_point_info = + Utils.Bounded(struct + type t = (Time.t option * Point.t) + let compare (t1, _) (t2, _) = + match t1, t2 with + | None, None -> 0 + | None, Some _ -> 1 + | Some _, None -> -1 + | Some t1, Some t2 -> Time.compare t2 t1 + end) in + let acc = Bounded_point_info.create expected in + let Pool pool = st.pool in + P2p_connection_pool.Points.fold_known + pool ~init:() + ~f:begin fun point pi () -> + match Point_info.State.get pi with + | Disconnected -> begin + match Point_info.last_miss pi with + | Some last when Time.(start_time < last) + && not (Point_info.greylisted ~now pi) -> () + | last -> + Bounded_point_info.insert (last, point) acc + end + | _ -> () + end ; + List.map snd (Bounded_point_info.get acc) + +(** Try to create connections to new peers. It tries to create at + least [min_to_contact] connections, and will never creates more + than [max_to_contact]. But, if after trying once all disconnected + peers, it returns [false]. *) +let rec try_to_contact + st ?(start_time = Time.now ()) + min_to_contact max_to_contact = + let Pool pool = st.pool in + if min_to_contact <= 0 then + Lwt.return_true + else + let contactable = + connectable st start_time max_to_contact in + if contactable = [] then + Lwt.return_false + else + List.fold_left + (fun acc point -> + P2p_connection_pool.connect + ~timeout:st.connection_timeout pool point >>= function + | Ok _ -> acc >|= succ + | Error _ -> acc) + (Lwt.return 0) + contactable >>= fun established -> + try_to_contact st ~start_time + (min_to_contact - established) (max_to_contact - established) + +(** Do a maintenance step. It will terminate only when the number + of connections is between `min_threshold` and `max_threshold`. *) +let rec maintain st = + let Pool pool = st.pool in + let n_connected = P2p_connection_pool.active_connections pool in + if n_connected < st.bounds.min_threshold then + too_few_connections st n_connected + else if st.bounds.max_threshold < n_connected then + too_many_connections st n_connected + else begin + (* end of maintenance when enough users have been reached *) + Lwt_condition.broadcast st.just_maintained () ; + lwt_debug "Maintenance step ended" >>= fun () -> + return () + end + +and too_few_connections st n_connected = + let Pool pool = st.pool in + (* too few connections, try and contact many peers *) + lwt_debug "Too few connections (%d)" n_connected >>= fun () -> + let min_to_contact = st.bounds.min_target - n_connected in + let max_to_contact = st.bounds.max_target - n_connected in + try_to_contact st min_to_contact max_to_contact >>= fun continue -> + if not continue then begin + maintain st + end else begin + (* not enough contacts, ask the pals of our pals, + discover the local network and then wait *) + iter_option ~f:P2p_discovery.restart st.disco ; + P2p_connection_pool.broadcast_bootstrap_msg pool ; + Lwt_utils.protect ~canceler:st.canceler begin fun () -> + Lwt.pick [ + P2p_connection_pool.Events.new_point pool ; + Lwt_unix.sleep 5.0 (* TODO exponential back-off ?? + or wait for the existence of a + non grey-listed peer ?? *) + ] >>= return + end >>=? fun () -> + maintain st + end + +and too_many_connections st n_connected = + let Pool pool = st.pool in + (* too many connections, start the russian roulette *) + let to_kill = n_connected - st.bounds.max_target in + lwt_debug "Too many connections, will kill %d" to_kill >>= fun () -> + snd @@ P2p_connection_pool.fold_connections pool + ~init:(to_kill, Lwt.return_unit) + ~f:(fun _ conn (i, t) -> + if i = 0 then (0, t) + else (i - 1, t >>= fun () -> P2p_connection_pool.disconnect conn)) + >>= fun () -> + maintain st + +let rec worker_loop st = + begin + let Pool pool = st.pool in + Lwt_utils.protect ~canceler:st.canceler begin fun () -> + Lwt.pick [ + Lwt_unix.sleep 120. ; (* every two minutes *) + Lwt_condition.wait st.please_maintain ; (* when asked *) + P2p_connection_pool.Events.too_few_connections pool ; (* limits *) + P2p_connection_pool.Events.too_many_connections pool + ] >>= fun () -> + return () + end >>=? fun () -> + maintain st + end >>= function + | Ok () -> worker_loop st + | Error [Lwt_utils.Canceled] -> Lwt.return_unit + | Error _ -> Lwt.return_unit + +let run ?(connection_timeout = 5.) bounds pool disco = + let canceler = Canceler.create () in + let st = { + canceler ; connection_timeout ; + bounds ; pool = Pool pool ; disco ; + just_maintained = Lwt_condition.create () ; + please_maintain = Lwt_condition.create () ; + worker = Lwt.return_unit ; + } in + st.worker <- + Lwt_utils.worker "maintenance" + (fun () -> worker_loop st) + (fun () -> Canceler.cancel canceler); + st + +let maintain { just_maintained ; please_maintain } = + let wait = Lwt_condition.wait just_maintained in + Lwt_condition.broadcast please_maintain () ; + wait + +let shutdown { canceler ; worker ; just_maintained } = + Canceler.cancel canceler >>= fun () -> + worker >>= fun () -> + Lwt_condition.broadcast just_maintained () ; + Lwt.return_unit diff --git a/src/node/net/p2p_maintenance.mli b/src/node/net/p2p_maintenance.mli new file mode 100644 index 000000000..1398d2527 --- /dev/null +++ b/src/node/net/p2p_maintenance.mli @@ -0,0 +1,45 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(* min <= min_threshold <= min_target <= max_target <= max_threshold <= max *) + +(* The 'pool' urges the maintainer to work when the number of + connections reaches `max` or is below `min`. Otherwise, the + maintener is lazy and only lookup for connection every two + minutes. The [maintain] function is another way to signal the + maintainer that a maintenance step is desired. + + When the maintener detects that the number of connections is over + `max_threshold`, it randomly kills connections to reach `max_target`. + + When the maintener detects that the number of connections is below + `min_threshold`, it creates enough connection to reach at least + `min_target` (and never more than `max_target`). In the process, it + might ask its actual peers for new peers. *) + +type bounds = { + min_threshold: int ; + min_target: int ; + max_target: int ; + max_threshold: int ; +} + +type 'meta t +(** Type of a maintenance worker. *) + +val run: + ?connection_timeout:float -> + bounds -> + ('msg, 'meta) P2p_connection_pool.t -> + P2p_discovery.t option -> + 'meta t + +val maintain: 'meta t -> unit Lwt.t + +val shutdown: 'meta t -> unit Lwt.t diff --git a/src/node/net/p2p_types.ml b/src/node/net/p2p_types.ml new file mode 100644 index 000000000..5ed7ded49 --- /dev/null +++ b/src/node/net/p2p_types.ml @@ -0,0 +1,225 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Logging.Net + +module Canceler = Lwt_utils.Canceler + +module Version = struct + type t = { + name : string ; + major : int ; + minor : int ; + } + + 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 : int ; + total_recv : int ; + current_inflow : int ; + current_outflow : int ; + } + + 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 pp ppf stat = + Format.fprintf ppf + "sent: %a (%a/s) recv: %a (%a/s)" + print_size stat.total_sent print_size stat.current_outflow + print_size stat.total_recv print_size stat.current_inflow + +end + +module Gid = struct + include Crypto_box.Public_key_hash + let pp = pp_short + module Map = Map.Make (Crypto_box.Public_key_hash) + module Set = Set.Make (Crypto_box.Public_key_hash) + module Table = Hash.Hash_table (Crypto_box.Public_key_hash) +end + +(* public types *) +type addr = Ipaddr.V6.t +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) = + 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 to_sockaddr (addr, port) = Unix.(ADDR_INET (Ipaddr_unix.V6.to_inet_addr addr, port)) + + let encoding = + let open Data_encoding in + conv + (fun (addr, port) -> Ipaddr.V6.to_string addr, port) + (fun (addr, port) -> Ipaddr.V6.of_string_exn addr, port) + (obj2 + (req "addr" string) + (req "port" int16)) + end + + include T + + (* Run-time point-or-gid indexed storage, one point is bound to at + most one gid, which is the invariant we want to keep both for the + connected peers table and the known peers one *) + + 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 is_local (addr, _) = Ipaddr.V6.is_private addr + let is_global (addr, _) = not @@ Ipaddr.V6.is_private addr + + let encoding = + let open Data_encoding in + conv + (fun (addr, port) -> Ipaddr.V6.to_bytes addr, port) + (fun (addr, port) -> Ipaddr.V6.of_bytes_exn addr, port) + (obj2 + (req "addr" string) + (opt "port" int16)) + end + + include T + + (* Run-time point-or-gid indexed storage, one point is bound to at + most one gid, which is the invariant we want to keep both for the + connected peers table and the known peers one *) + + module Map = Map.Make (T) + module Set = Set.Make (T) + module Table = Hashtbl.Make (T) + +end + +module Identity = struct + + type t = { + gid : Gid.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 gid = Crypto_box.hash public_key in + { gid ; 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 target = + let secret_key, public_key, gid = Crypto_box.random_keypair () in + let proof_of_work_stamp = + Crypto_box.generate_proof_of_work public_key target in + { gid ; public_key ; secret_key ; proof_of_work_stamp } + +end + +module Connection_info = struct + + type t = { + incoming : bool; + gid : Gid.t; + id_point : Id_point.t; + remote_socket_port : port; + versions : Version.t list ; + } + + let pp ppf + { incoming ; id_point = (remote_addr, remote_port) ; gid } = + Format.fprintf ppf "%a:%a {%a}%s" + Ipaddr.V6.pp_hum remote_addr + (fun ppf port -> + match port with + | None -> Format.pp_print_string ppf "??" + | Some port -> Format.pp_print_int ppf port) remote_port + Gid.pp gid + (if incoming then " (incoming)" else "") + +end diff --git a/src/node/net/p2p_types.mli b/src/node/net/p2p_types.mli new file mode 100644 index 000000000..f85ed323a --- /dev/null +++ b/src/node/net/p2p_types.mli @@ -0,0 +1,129 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +module Canceler = Lwt_utils.Canceler + +(** Protocol version *) + +module Version : sig + type t = { + name : string ; + major : int ; + minor : int ; + } + (** Type of a protocol version. *) + + val encoding : t Data_encoding.t + val common: t list -> t list -> t option +end + + +(** Gid, i.e. persistent peer identifier *) + +module Gid : sig + type t = Crypto_box.Public_key_hash.t + (** Type of a gid, a public key hash. *) + + val compare : t -> t -> int + val equal : t -> t -> bool + val pp : Format.formatter -> t -> unit + val encoding : t Data_encoding.t + 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 + +type addr = Ipaddr.V6.t +type port = int + + +(** 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 encoding : t Data_encoding.t + val is_local : t -> bool + val is_global : t -> bool + val to_sockaddr : t -> Unix.sockaddr + 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 *) + +module Id_point : sig + type t = addr * port option + val compare : t -> t -> int + val equal : t -> t -> bool + val pp : Format.formatter -> t -> unit + val pp_opt : Format.formatter -> t option -> unit + val encoding : t Data_encoding.t + val is_local : t -> bool + val is_global : t -> bool + 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 + + +(** Identity *) + +module Identity : sig + type t = { + gid : Gid.t ; + public_key : Crypto_box.public_key ; + secret_key : Crypto_box.secret_key ; + proof_of_work_stamp : Crypto_box.nonce ; + } + (** Type of an identity, comprising a gid, a crypto keypair, and a + proof of work stamp with enough difficulty so that the network + accept this identity as genuine. *) + + val encoding : t Data_encoding.t + + val generate : Crypto_box.target -> t + (** [generate target] is a freshly minted identity whose proof of + work stamp difficulty is at least equal to [target]. *) +end + + +(** Bandwidth usage statistics *) + +module Stat : sig + + type t = { + total_sent : int ; + total_recv : int ; + current_inflow : int ; + current_outflow : int ; + } + + val pp: Format.formatter -> t -> unit + +end + +(** Information about a connection *) + +module Connection_info : sig + + type t = { + incoming : bool; + gid : Gid.t; + id_point : Id_point.t; + remote_socket_port : port; + versions : Version.t list ; + } + + val pp: Format.formatter -> t -> unit + +end diff --git a/src/node/net/p2p_welcome.ml b/src/node/net/p2p_welcome.ml new file mode 100644 index 000000000..a30dadd29 --- /dev/null +++ b/src/node/net/p2p_welcome.ml @@ -0,0 +1,77 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +include Logging.Make (struct let name = "p2p.welcome" end) +open P2p_types + +type pool = Pool : ('msg, 'meta) P2p_connection_pool.t -> pool + +type t = { + socket: Lwt_unix.file_descr ; + canceler: Canceler.t ; + pool: pool ; + mutable worker: unit Lwt.t ; +} + +let rec worker_loop st = + let Pool pool = st.pool in + Lwt_unix.yield () >>= fun () -> + Lwt_utils.protect ~canceler:st.canceler begin fun () -> + Lwt_unix.accept st.socket >>= return + end >>= function + | Ok (fd, addr) -> + let point = + match addr with + | Lwt_unix.ADDR_UNIX _ -> assert false + | Lwt_unix.ADDR_INET (addr, port) -> + (Ipaddr_unix.V6.of_inet_addr_exn addr, port) in + P2p_connection_pool.accept pool fd point ; + worker_loop st + | Error [Lwt_utils.Canceled] -> + Lwt.return_unit + | Error err -> + lwt_log_error "@[Unexpected error in the Welcome worker@ %a@]" + pp_print_error err >>= fun () -> + Lwt.return_unit + +let create_listening_socket ~backlog ?(addr = Ipaddr.V6.unspecified) port = + let main_socket = Lwt_unix.(socket PF_INET6 SOCK_STREAM 0) in + Lwt_unix.(setsockopt main_socket SO_REUSEADDR true) ; + Lwt_unix.Versioned.bind_2 + main_socket (Point.to_sockaddr (addr, port)) >>= fun () -> + Lwt_unix.listen main_socket backlog ; + Lwt.return main_socket + +let run ~backlog pool ?addr port = + Lwt.catch begin fun () -> + create_listening_socket + ~backlog ?addr port >>= fun socket -> + let canceler = Canceler.create () in + Canceler.on_cancel canceler begin fun () -> + Lwt_utils.safe_close socket + end ; + let st = { + socket ; canceler ; pool = Pool pool ; + worker = Lwt.return_unit ; + } in + st.worker <- + Lwt_utils.worker "welcome" + (fun () -> worker_loop st) + (fun () -> Canceler.cancel st.canceler) ; + Lwt.return st + end begin fun exn -> + lwt_log_error + "@[Cannot accept incoming connections@ %a@]" + pp_exn exn >>= fun () -> + Lwt.fail exn + end + +let shutdown st = + Canceler.cancel st.canceler >>= fun () -> + st.worker diff --git a/src/node/net/p2p_welcome.mli b/src/node/net/p2p_welcome.mli new file mode 100644 index 000000000..9fd3853bb --- /dev/null +++ b/src/node/net/p2p_welcome.mli @@ -0,0 +1,27 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open P2p_types + +(** Welcome worker. Accept incoming connections and add them to its + connection pool. *) + +type t +(** Type of a welcome worker, parametrized like a + [P2p_connection_pool.pool]. *) + +val run: + backlog:int -> + ('msg, 'meta) P2p_connection_pool.t -> + ?addr:addr -> port -> t Lwt.t +(** [run ~backlog ~addr pool port] returns a running welcome worker + feeding [pool] listening at [(addr, port)]. [backlog] is the + argument passed to [Lwt_unix.accept]. *) + +val shutdown: t -> unit Lwt.t diff --git a/src/node/shell/tezos_p2p.ml b/src/node/shell/tezos_p2p.ml index a013c3281..0b4ef48d2 100644 --- a/src/node/shell/tezos_p2p.ml +++ b/src/node/shell/tezos_p2p.ml @@ -1,26 +1,29 @@ -module Param = struct +open P2p - type net_id = Store.net_id +type net_id = Store.net_id - type msg = +type msg = + | Discover_blocks of net_id * Block_hash.t list (* Block locator *) + | Block_inventory of net_id * Block_hash.t list - | Discover_blocks of net_id * Block_hash.t list (* Block locator *) - | Block_inventory of net_id * Block_hash.t list + | Get_blocks of Block_hash.t list + | Block of MBytes.t - | Get_blocks of Block_hash.t list - | Block of MBytes.t + | Current_operations of net_id + | Operation_inventory of net_id * Operation_hash.t list - | Current_operations of net_id - | Operation_inventory of net_id * Operation_hash.t list + | Get_operations of Operation_hash.t list + | Operation of MBytes.t - | Get_operations of Operation_hash.t list - | Operation of MBytes.t + | Get_protocols of Protocol_hash.t list + | Protocol of MBytes.t - | Get_protocols of Protocol_hash.t list - | Protocol of MBytes.t +module Message = struct - let encodings = + type t = msg + + let encoding = let open Data_encoding in let case ?max_length ~tag encoding unwrap wrap = P2p.Encoding { tag; encoding; wrap; unwrap; max_length } in @@ -71,13 +74,8 @@ module Param = struct (fun proto -> Protocol proto); ] - type metadata = unit - let initial_metadata = () - let metadata_encoding = Data_encoding.empty - let score () = 0. - let supported_versions = - let open P2p in + let open P2p.Version in [ { name = "TEZOS" ; major = 0 ; minor = 0 ; @@ -86,5 +84,53 @@ module Param = struct end -include Param -include P2p.Make(Param) +type metadata = unit + +module Metadata = struct + type t = metadata + let initial = () + let encoding = Data_encoding.empty + let score () = 0. +end + + +let meta_cfg : _ P2p.meta_config = { + P2p.encoding = Metadata.encoding ; + initial = Metadata.initial ; +} + +and msg_cfg : _ P2p.message_config = { + encoding = Message.encoding ; + versions = Message.supported_versions ; +} + +type net = (Message.t, Metadata.t) P2p.net + +let bootstrap ~config ~limits = + P2p.bootstrap ~config ~limits meta_cfg msg_cfg + +let broadcast = P2p.broadcast +let try_send = P2p.try_send +let recv = P2p.recv_any +let send = P2p.send +let set_metadata = P2p.set_metadata +let get_metadata = P2p.get_metadata +let connection_info = P2p.connection_info +let find_connection = P2p.find_connection +let connections = P2p.connections +type connection = (Message.t, Metadata.t) P2p.connection +let shutdown = P2p.shutdown +let roll = P2p.roll +let maintain = P2p.maintain +let faked_network = P2p.faked_network + +module Raw = struct + type 'a t = 'a P2p.Raw.t = + | Bootstrap + | Advertise of Point.t list + | Message of 'a + | Disconnect + type message = Message.t t + let encoding = P2p.Raw.encoding msg_cfg.encoding + let supported_versions = msg_cfg.versions +end diff --git a/src/node/shell/tezos_p2p.mli b/src/node/shell/tezos_p2p.mli index 9f27f5a32..db1344baa 100644 --- a/src/node/shell/tezos_p2p.mli +++ b/src/node/shell/tezos_p2p.mli @@ -13,41 +13,30 @@ val bootstrap : config:config -> limits:limits -> net Lwt.t (** A maintenance operation : try and reach the ideal number of peers *) val maintain : net -> unit Lwt.t -(** Voluntarily drop some peers and replace them by new buddies *) +(** Voluntarily drop some connections and replace them by new buddies *) val roll : net -> unit Lwt.t (** Close all connections properly *) val shutdown : net -> unit Lwt.t (** A connection to a peer *) -type peer +type connection -(** Access the domain of active peers *) -val peers : net -> peer list +(** Access the domain of active connections *) +val connections : net -> connection list -(** Return the active peer with identity [gid] *) -val find_peer : net -> gid -> peer option +(** Return the active connection with identity [gid] *) +val find_connection : net -> Gid.t -> connection option -type peer_info = { - gid : gid ; - addr : addr ; - port : port ; - version : version ; - total_sent : int ; - total_recv : int ; - current_inflow : float ; - current_outflow : float ; -} - -(** Access the info of an active peer, if available *) -val peer_info : net -> peer -> peer_info +(** Access the info of an active connection. *) +val connection_info : net -> connection -> Connection_info.t (** Accessors for meta information about a global identifier *) type metadata = unit -val get_metadata : net -> gid -> metadata option -val set_metadata : net -> gid -> metadata -> unit +val get_metadata : net -> Gid.t -> metadata option +val set_metadata : net -> Gid.t -> metadata -> unit type net_id = Store.net_id @@ -68,23 +57,28 @@ type msg = | Get_protocols of Protocol_hash.t list | Protocol of MBytes.t -(** Wait for a payload from any peer in the network *) -val recv : net -> (peer * msg) Lwt.t +(** Wait for a payload from any connection in the network *) +val recv : net -> (connection * msg) Lwt.t -(** [send net peer msg] is a thread that returns when [msg] has been +(** [send net conn msg] is a thread that returns when [msg] has been successfully enqueued in the send queue. *) -val send : net -> peer -> msg -> unit Lwt.t +val send : net -> connection -> msg -> unit Lwt.t -(** [try_send net peer msg] is [true] if [msg] has been added to the +(** [try_send net conn msg] is [true] if [msg] has been added to the send queue for [peer], [false] otherwise *) -val try_send : net -> peer -> msg -> bool +val try_send : net -> connection -> msg -> bool (** Send a payload to all peers *) val broadcast : net -> msg -> unit -(** Shutdown the connection to all peers at this address and stop the - communications with this machine for [duration] seconds *) -val blacklist : net -> gid -> unit - -(** Keep a connection to this pair as often as possible *) -val whitelist : net -> gid -> unit +(**/**) +module Raw : sig + type 'a t = + | Bootstrap + | Advertise of Point.t list + | Message of 'a + | Disconnect + type message = msg t + val encoding: message Data_encoding.t + val supported_versions: Version.t list +end diff --git a/src/node_main.ml b/src/node_main.ml index 8980f40d6..84cfdb75e 100644 --- a/src/node_main.ml +++ b/src/node_main.ml @@ -7,6 +7,8 @@ (* *) (**************************************************************************) +module V6 = Ipaddr.V6 + open Error_monad open Logging.Node.Main @@ -54,15 +56,15 @@ type cfg = { min_connections : int ; max_connections : int ; expected_connections : int ; - net_addr : Ipaddr.t ; + net_addr : V6.t ; net_port : int ; - local_discovery : int option ; - peers : (Ipaddr.t * int) list ; + (* local_discovery : (string * int) option ; *) + peers : (V6.t * int) list ; peers_cache : string ; closed : bool ; (* rpc *) - rpc_addr : (Ipaddr.t * int) option ; + rpc_addr : (V6.t * int) option ; cors_origins : string list ; cors_headers : string list ; rpc_crt : string option ; @@ -88,9 +90,9 @@ let default_cfg_of_base_dir base_dir = { min_connections = 4 ; max_connections = 400 ; expected_connections = 20 ; - net_addr = Ipaddr.(V6 V6.unspecified) ; + net_addr = V6.unspecified ; net_port = 9732 ; - local_discovery = None ; + (* local_discovery = None ; *) peers = [] ; closed = false ; peers_cache = base_dir // "peers_cache" ; @@ -130,16 +132,21 @@ let sockaddr_of_string str = let addr, port = String.sub str 0 pos, String.sub str (pos+1) (len - pos - 1) in match Ipaddr.of_string_exn addr, int_of_string port with | exception Failure _ -> `Error "not a sockaddr" - | ip, port -> `Ok (ip, port) + | V4 ipv4, port -> `Ok (Ipaddr.v6_of_v4 ipv4, port) + | V6 ipv6, port -> `Ok (ipv6, port) let sockaddr_of_string_exn str = match sockaddr_of_string str with | `Ok saddr -> saddr | `Error msg -> invalid_arg msg -let pp_sockaddr fmt (ip, port) = Format.fprintf fmt "%a:%d" Ipaddr.pp_hum ip port +let pp_sockaddr fmt (ip, port) = Format.fprintf fmt "%a:%d" V6.pp_hum ip port let string_of_sockaddr saddr = Format.asprintf "%a" pp_sockaddr saddr +let mcast_params_of_string s = match Utils.split ':' s with + | [iface; port] -> iface, int_of_string port + | _ -> invalid_arg "mcast_params_of_string" + module Cfg_file = struct open Data_encoding @@ -150,12 +157,12 @@ module Cfg_file = struct (opt "protocol" string) let net = - obj8 + obj7 (opt "min-connections" uint16) (opt "max-connections" uint16) (opt "expected-connections" uint16) (opt "addr" string) - (opt "local-discovery" uint16) + (* (opt "local-discovery" string) *) (opt "peers" (list string)) (dft "closed" bool false) (opt "peers-cache" string) @@ -174,21 +181,29 @@ module Cfg_file = struct conv (fun { store ; context ; protocol ; min_connections ; max_connections ; expected_connections ; - net_addr ; net_port ; local_discovery ; peers ; + net_addr ; net_port ; + (* local_discovery ; *) + peers ; closed ; peers_cache ; rpc_addr ; cors_origins ; cors_headers ; log_output } -> let net_addr = string_of_sockaddr (net_addr, net_port) in + (* let local_discovery = Utils.map_option local_discovery *) + (* ~f:(fun (iface, port) -> iface ^ ":" ^ string_of_int port) *) + (* in *) let rpc_addr = Utils.map_option string_of_sockaddr rpc_addr in let peers = ListLabels.map peers ~f:string_of_sockaddr in let log_output = string_of_log log_output in ((Some store, Some context, Some protocol), (Some min_connections, Some max_connections, Some expected_connections, - Some net_addr, local_discovery, Some peers, closed, Some peers_cache), + Some net_addr, + (* local_discovery, *) + Some peers, closed, Some peers_cache), (rpc_addr, cors_origins, cors_headers), Some log_output)) (fun ( (store, context, protocol), (min_connections, max_connections, expected_connections, net_addr, - local_discovery, peers, closed, peers_cache), + (* local_discovery, *) + peers, closed, peers_cache), (rpc_addr, cors_origins, cors_headers), log_output) -> let open Utils in @@ -205,11 +220,14 @@ module Cfg_file = struct let min_connections = unopt default_cfg.min_connections min_connections in let max_connections = unopt default_cfg.max_connections max_connections in let expected_connections = unopt default_cfg.expected_connections expected_connections in + (* let local_discovery = map_option local_discovery ~f:mcast_params_of_string in *) { default_cfg with store ; context ; protocol ; - min_connections; max_connections; expected_connections; - net_addr; net_port ; local_discovery; peers; closed; peers_cache; - rpc_addr; cors_origins ; cors_headers ; log_output + min_connections ; max_connections ; expected_connections ; + net_addr ; net_port ; + (* local_discovery ; *) + peers ; closed ; peers_cache ; + rpc_addr ; cors_origins ; cors_headers ; log_output ; } ) (obj4 @@ -266,9 +284,9 @@ module Cmdline = struct let net_addr = let doc = "The TCP address and port at which this instance can be reached." in Arg.(value & opt (some sockaddr_converter) None & info ~docs:"NETWORK" ~doc ~docv:"ADDR:PORT" ["net-addr"]) - let local_discovery = - let doc = "Automatic discovery of peers on the local network." in - Arg.(value & opt (some int) None & info ~docs:"NETWORK" ~doc ~docv:"ADDR:PORT" ["local-discovery"]) + (* let local_discovery = *) + (* let doc = "Automatic discovery of peers on the local network." in *) + (* Arg.(value & opt (some @@ pair string int) None & info ~docs:"NETWORK" ~doc ~docv:"IFACE:PORT" ["local-discovery"]) *) let peers = let doc = "A peer to bootstrap the network from. Can be used several times to add several peers." in Arg.(value & opt_all sockaddr_converter [] & info ~docs:"NETWORK" ~doc ~docv:"ADDR:PORT" ["peer"]) @@ -298,7 +316,9 @@ module Cmdline = struct let parse base_dir config_file sandbox sandbox_param log_level min_connections max_connections expected_connections - net_saddr local_discovery peers closed rpc_addr tls cors_origins cors_headers reset_cfg update_cfg = + net_saddr + (* local_discovery *) + peers closed rpc_addr tls cors_origins cors_headers reset_cfg update_cfg = let base_dir = Utils.(unopt (unopt default_cfg.base_dir base_dir) sandbox) in let config_file = Utils.(unopt ((unopt base_dir sandbox) // "config")) config_file in @@ -340,7 +360,7 @@ module Cmdline = struct expected_connections = Utils.unopt cfg.expected_connections expected_connections ; net_addr = (match net_saddr with None -> cfg.net_addr | Some (addr, _) -> addr) ; net_port = (match net_saddr with None -> cfg.net_port | Some (_, port) -> port) ; - local_discovery = Utils.first_some local_discovery cfg.local_discovery ; + (* local_discovery = Utils.first_some local_discovery cfg.local_discovery ; *) peers = (match peers with [] -> cfg.peers | _ -> peers) ; closed = closed || cfg.closed ; rpc_addr = Utils.first_some rpc_addr cfg.rpc_addr ; @@ -359,7 +379,9 @@ module Cmdline = struct ret (const parse $ base_dir $ config_file $ sandbox $ sandbox_param $ v $ min_connections $ max_connections $ expected_connections - $ net_addr $ local_discovery $ peers $ closed + $ net_addr + (* $ local_discovery *) + $ peers $ closed $ rpc_addr $ rpc_tls $ cors_origins $ cors_headers $ reset_config $ update_config ), @@ -391,10 +413,11 @@ let init_logger { log_output ; log_level } = | `Null -> Logging.init Null | `Syslog -> Logging.init Syslog -let init_node { sandbox ; sandbox_param ; - store ; context ; - min_connections ; max_connections ; expected_connections ; - net_port ; peers ; peers_cache ; local_discovery ; closed } = +let init_node + { sandbox ; sandbox_param ; + store ; context ; + min_connections ; max_connections ; expected_connections ; + net_port ; peers ; peers_cache ; closed } = let patch_context json ctxt = let module Proto = (val Updater.get_exn genesis_protocol) in Lwt.catch @@ -428,20 +451,48 @@ let init_node { sandbox ; sandbox_param ; match sandbox with | Some _ -> None | None -> + (* TODO add parameters... *) + let authentification_timeout = 5. + and backlog = 20 + and max_incoming_connections = 20 + and max_download_speed = None + and max_upload_speed = None + and read_buffer_size = 1 lsl 14 + and read_queue_size = None + and write_queue_size = None + and incoming_app_message_queue_size = None + and incoming_message_queue_size = None + and outgoing_message_queue_size = None in let limits = - { max_message_size = 10_000 ; - peer_answer_timeout = 5. ; - expected_connections ; + { authentification_timeout ; min_connections ; + expected_connections ; max_connections ; - blacklist_time = 30. } + backlog ; + max_incoming_connections ; + max_download_speed ; + max_upload_speed ; + read_buffer_size ; + read_queue_size ; + write_queue_size ; + incoming_app_message_queue_size ; + incoming_message_queue_size ; + outgoing_message_queue_size ; + } in + (* TODO add parameters... *) + let identity = P2p.Identity.generate Crypto_box.default_target + and listening_addr = None + and proof_of_work_target = Crypto_box.default_target in let config = - { incoming_port = Some net_port ; - discovery_port = local_discovery ; - known_peers = peers ; + { listening_port = Some net_port ; + listening_addr ; + identity ; + trusted_points = peers ; peers_file = peers_cache ; - closed_network = closed } + closed_network = closed ; + proof_of_work_target ; + } in Some (config, limits) in Node.create @@ -458,7 +509,7 @@ let init_rpc { rpc_addr ; rpc_crt; rpc_key ; cors_origins ; cors_headers } node lwt_log_notice "Starting the RPC server listening on port %d (TLS enabled)." port >>= fun () -> let dir = Node_rpc.build_rpc_directory node in let mode = `TLS (`Crt_file_path crt, `Key_file_path key, `No_password, `Port port) in - let host = Ipaddr.to_string addr in + let host = Ipaddr.V6.to_string addr in let () = let old_hook = !Lwt.async_exception_hook in Lwt.async_exception_hook := function diff --git a/src/tezos-deps.opam b/src/tezos-deps.opam index f864c5279..f078080d9 100644 --- a/src/tezos-deps.opam +++ b/src/tezos-deps.opam @@ -18,21 +18,24 @@ depends: [ "calendar" "cohttp" {>= "0.21" } "config-file" - "conduit" {= "0.14.0" } # Version 0.14.1 doas not compile with `ssl` (17/01/02) + "conduit" "git" "git-unix" + "ipv6-multicast" "irmin-watcher" (* for `irmin.unix` *) - "irmin" {>= "0.12"} + "irmin" {>= "0.12" } + "lwt" {>= "2.7.0" } + "lwt_ssl" "menhir" - "ocp-ocamlres" {>= "dev"} + "mtime" + "ocp-ocamlres" {>= "dev" } "ocplib-endian" "ocplib-json-typed" - "ocplib-resto" {>= "dev"} + "ocplib-resto" {>= "dev" } "reactiveData" "tyxml" "js_of_ocaml" - "sodium" {>= "0.3.0"} - "ssl" + "sodium" {>= "0.3.0" } "kaputt" # { test } "bisect_ppx" # { test } ] diff --git a/src/utils/base48.ml b/src/utils/base48.ml index f21f50682..b9b1345b8 100644 --- a/src/utils/base48.ml +++ b/src/utils/base48.ml @@ -230,6 +230,7 @@ module Prefix = struct let operation_hash = "\001" let protocol_hash = "\002" let ed25519_public_key_hash = "\003" + let cryptobox_public_key_hash = "\004" let ed25519_public_key = "\012" let ed25519_secret_key = "\013" let ed25519_signature = "\014" diff --git a/src/utils/base48.mli b/src/utils/base48.mli index 26a1f7922..802781391 100644 --- a/src/utils/base48.mli +++ b/src/utils/base48.mli @@ -37,6 +37,9 @@ module Prefix : sig val ed25519_public_key_hash: string (** Prefix for Ed25519 public key hashes: "\003". *) + val cryptobox_public_key_hash: string + (** Prefix for Ed25519 public key hashes: "\004". *) + val ed25519_public_key: string (** Prefix for Ed25519 public key: "\012". *) diff --git a/src/utils/crypto_box.ml b/src/utils/crypto_box.ml index 237d068a5..e8d58a80d 100644 --- a/src/utils/crypto_box.ml +++ b/src/utils/crypto_box.ml @@ -18,7 +18,19 @@ type nonce = Sodium.Box.nonce type target = int64 list (* used as unsigned intergers... *) exception TargetNot256Bit -let random_keypair = Sodium.Box.random_keypair +module Public_key_hash = Hash.Make_Blake2B (Base48) (struct + let name = "Crypto_box.Public_key_hash" + let title = "A Cryptobox public key ID" + let b48check_prefix = Base48.Prefix.cryptobox_public_key_hash + let size = Some 16 + end) + +let hash pk = + Public_key_hash.hash_bytes [Sodium.Box.Bigbytes.of_public_key pk] + +let random_keypair () = + let sk, pk = Sodium.Box.random_keypair () in + sk, pk, hash pk let random_nonce = Sodium.Box.random_nonce let increment_nonce = Sodium.Box.increment_nonce let box = Sodium.Box.Bigbytes.box @@ -26,6 +38,12 @@ let box_open sk pk msg nonce = try Some (Sodium.Box.Bigbytes.box_open sk pk msg nonce) with | Sodium.Verification_failure -> None +let precompute = Sodium.Box.precompute +let fast_box = Sodium.Box.Bigbytes.fast_box +let fast_box_open ck msg nonce = + try Some (Sodium.Box.Bigbytes.fast_box_open ck msg nonce) with + | Sodium.Verification_failure -> None + let make_target target = if List.length target > 8 then raise TargetNot256Bit ; target diff --git a/src/utils/crypto_box.mli b/src/utils/crypto_box.mli index 5902ebec8..0ae416919 100644 --- a/src/utils/crypto_box.mli +++ b/src/utils/crypto_box.mli @@ -21,15 +21,22 @@ val default_target : target type secret_key type public_key +module Public_key_hash : Hash.HASH +type channel_key val public_key_encoding : public_key Data_encoding.t val secret_key_encoding : secret_key Data_encoding.t -val random_keypair : unit -> secret_key * public_key +val hash : public_key -> Public_key_hash.t +val random_keypair : unit -> secret_key * public_key * Public_key_hash.t val box : secret_key -> public_key -> MBytes.t -> nonce -> MBytes.t - val box_open : secret_key -> public_key -> MBytes.t -> nonce -> MBytes.t option +val precompute : secret_key -> public_key -> channel_key +val fast_box : channel_key -> MBytes.t -> nonce -> MBytes.t +val fast_box_open : channel_key -> MBytes.t -> nonce -> MBytes.t option + val check_proof_of_work : public_key -> nonce -> target -> bool val generate_proof_of_work : public_key -> target -> nonce + diff --git a/src/utils/error_monad.ml b/src/utils/error_monad.ml index f689b8410..8ff3375ae 100644 --- a/src/utils/error_monad.ml +++ b/src/utils/error_monad.ml @@ -174,6 +174,11 @@ module Make() = struct let fail s = Lwt.return (Error [ s ]) + let protect ~on_error t = + t >>= function + | Ok res -> return res + | Error err -> on_error err + let (>>?) v f = match v with | Error _ as err -> err @@ -286,6 +291,9 @@ module Make() = struct let fail_unless cond exn = if cond then return () else fail exn + let unless cond f = + if cond then return () else f () + let pp_print_error ppf errors = Format.fprintf ppf "@[Error, dumping error stack:@,%a@]@." (Format.pp_print_list pp) @@ -332,15 +340,20 @@ let error_exn s = Error [ Exn s ] let trace_exn exn f = trace (Exn exn) f let record_trace_exn exn f = record_trace (Exn exn) f +let pp_exn ppf exn = pp ppf (Exn exn) + let () = register_error_kind `Temporary ~id:"failure" ~title:"Generic error" ~description:"Unclassified error" + ~pp:Format.pp_print_string Data_encoding.(obj1 (req "msg" string)) (function | Exn (Failure msg) -> Some msg + | Exn (Unix.Unix_error (err, fn, _)) -> + Some ("Unix error in " ^ fn ^ ": " ^ Unix.error_message err) | Exn exn -> Some (Printexc.to_string exn) | _ -> None) (fun msg -> Exn (Failure msg)) diff --git a/src/utils/error_monad.mli b/src/utils/error_monad.mli index 4b3f0e1b4..11e607101 100644 --- a/src/utils/error_monad.mli +++ b/src/utils/error_monad.mli @@ -29,6 +29,7 @@ val failwith : val error_exn : exn -> 'a tzresult val record_trace_exn : exn -> 'a tzresult -> 'a tzresult val trace_exn : exn -> 'b tzresult Lwt.t -> 'b tzresult Lwt.t +val pp_exn : Format.formatter -> exn -> unit type error += Exn of exn type error += Unclassified of string diff --git a/src/utils/error_monad_sig.ml b/src/utils/error_monad_sig.ml index 02964ae79..493d3f000 100644 --- a/src/utils/error_monad_sig.ml +++ b/src/utils/error_monad_sig.ml @@ -100,6 +100,12 @@ module type S = sig (** Erroneous return on failed assertion *) val fail_unless : bool -> error -> unit tzresult Lwt.t + val unless : bool -> (unit -> unit tzresult Lwt.t) -> unit tzresult Lwt.t + + val protect : + on_error: (error list -> 'a tzresult Lwt.t) -> + 'a tzresult Lwt.t -> 'a tzresult Lwt.t + (** {2 In-monad list iterators} ********************************************) (** A {!List.iter} in the monad *) diff --git a/src/utils/hash.ml b/src/utils/hash.ml index b088cfdf3..1e2bc1fce 100644 --- a/src/utils/hash.ml +++ b/src/utils/hash.ml @@ -254,7 +254,7 @@ module Hash_map (Hash : HASH) = struct Data_encoding.(list (tup2 Hash.encoding arg_encoding)) end -module Hash_table (Hash : HASH) +module Hash_table (Hash : MINIMAL_HASH) : Hashtbl.S with type key = Hash.t = Hashtbl.Make (struct type t = Hash.t diff --git a/src/utils/hash.mli b/src/utils/hash.mli index 57f8d25b1..aab5d7301 100644 --- a/src/utils/hash.mli +++ b/src/utils/hash.mli @@ -103,7 +103,7 @@ module Hash_map (Hash : HASH) : sig end (** Builds a Hashtbl using some Hash type as keys. *) -module Hash_table (Hash : HASH) : Hashtbl.S with type key = Hash.t +module Hash_table (Hash : MINIMAL_HASH) : Hashtbl.S with type key = Hash.t (** {2 Predefined Hashes } ****************************************************) diff --git a/src/utils/logging.ml b/src/utils/logging.ml index 173fbb3d7..b41340dbf 100644 --- a/src/utils/logging.ml +++ b/src/utils/logging.ml @@ -30,7 +30,7 @@ let log_f Format.ikfprintf (fun _ -> Lwt.return_unit) Format.std_formatter format else Format.kasprintf - (Lwt_log.log ?exn ~section ?location ?logger ~level) + (fun msg -> Lwt_log.log ?exn ~section ?location ?logger ~level msg) format let ign_log_f @@ -39,8 +39,7 @@ let ign_log_f Format.ikfprintf (fun _ -> ()) Format.std_formatter format else Format.kasprintf - (fun s -> - Lwt_log.ign_log ?exn ~section ?location ?logger ~level s) + (fun msg -> Lwt_log.ign_log ?exn ~section ?location ?logger ~level msg) format module Make(S : sig val name: string end) : LOG = struct @@ -87,8 +86,10 @@ module Client = struct end module Webclient = Make(struct let name = "webclient" end) +let template = "$(date) $(name)[$(pid)]: $(message)" + let default_logger () = - Lwt_log.channel ~close_mode:`Keep ~channel:Lwt_io.stderr () + Lwt_log.channel ~template ~close_mode:`Keep ~channel:Lwt_io.stderr () type kind = | Null @@ -96,6 +97,7 @@ type kind = | Stderr | File of string | Syslog + | Manual of Lwt_log.logger let init kind = let logger = @@ -103,12 +105,13 @@ let init kind = | Stderr -> default_logger () | Stdout -> - Lwt_log.channel ~close_mode:`Keep ~channel:Lwt_io.stdout () + Lwt_log.channel ~template ~close_mode:`Keep ~channel:Lwt_io.stdout () | File file_name -> - Lwt_main.run (Lwt_log.file ~file_name ()) + Lwt_main.run (Lwt_log.file ~file_name ~template ()) | Null -> Lwt_log.null | Syslog -> Printf.eprintf "Warning: log_kind \"syslog\" not yet implemented.\n%!"; - default_logger () in + default_logger () + | Manual logger -> logger in Lwt_log.default := logger diff --git a/src/utils/logging.mli b/src/utils/logging.mli index 155ffa2ff..fb999b7b0 100644 --- a/src/utils/logging.mli +++ b/src/utils/logging.mli @@ -54,5 +54,6 @@ type kind = | Stderr | File of string | Syslog + | Manual of Lwt_log.logger val init: kind -> unit diff --git a/src/utils/lwt_exit.ml b/src/utils/lwt_exit.ml index 2e82b1fe8..09481e875 100644 --- a/src/utils/lwt_exit.ml +++ b/src/utils/lwt_exit.ml @@ -7,7 +7,6 @@ (* *) (**************************************************************************) - exception Exit let termination_thread, exit_wakener = Lwt.wait () @@ -18,6 +17,12 @@ let () = (function | Exit -> () | exn -> - Printf.eprintf "Uncaught (asynchronous) exception: %S\n%s\n%!" - (Printexc.to_string exn) (Printexc.get_backtrace ()); + Format.eprintf + "@[Uncaught (asynchronous) exception (%d):@ %a@]" + (Unix.getpid ()) + Error_monad.pp_exn exn ; + let backtrace = Printexc.get_backtrace () in + if String.length backtrace <> 0 then + Format.eprintf "\n%s" backtrace ; + Format.eprintf "@." ; Lwt.wakeup exit_wakener 1) diff --git a/src/utils/lwt_pipe.ml b/src/utils/lwt_pipe.ml index f6348218a..e86293fb4 100644 --- a/src/utils/lwt_pipe.ml +++ b/src/utils/lwt_pipe.ml @@ -11,15 +11,25 @@ open Lwt.Infix type 'a t = { queue : 'a Queue.t ; - size : int ; + size : int option ; + mutable closed : bool ; mutable push_waiter : (unit Lwt.t * unit Lwt.u) option ; - mutable pop_waiter : (unit Lwt.t * unit Lwt.u) option } + mutable pop_waiter : (unit Lwt.t * unit Lwt.u) option ; + empty: unit Lwt_condition.t ; + full: unit Lwt_condition.t ; + not_full : unit Lwt_condition.t ; + } -let create ~size = +let create ?size () = { queue = Queue.create () ; size ; + closed = false ; push_waiter = None ; - pop_waiter = None } + pop_waiter = None ; + empty = Lwt_condition.create () ; + full = Lwt_condition.create () ; + not_full = Lwt_condition.create () ; + } let notify_push q = match q.push_waiter with @@ -37,69 +47,164 @@ let notify_pop q = let wait_push q = match q.push_waiter with - | Some (t, _) -> t + | Some (t, _) -> Lwt.protected t | None -> let waiter, wakener = Lwt.wait () in q.push_waiter <- Some (waiter, wakener) ; - waiter + Lwt.protected waiter let wait_pop q = match q.pop_waiter with - | Some (t, _) -> t + | Some (t, _) -> Lwt.protected t | None -> let waiter, wakener = Lwt.wait () in q.pop_waiter <- Some (waiter, wakener) ; - waiter + Lwt.protected waiter -let rec push ({ queue ; size } as q) elt = - if Queue.length queue < size then begin +let available_space { size } len = + match size with + | None -> true + | Some size -> len < size + +let length { queue } = Queue.length queue +let is_empty { queue } = Queue.is_empty queue +let is_full ({ queue } as q) = not (available_space q (Queue.length queue)) + +let rec empty q = + if is_empty q + then Lwt.return_unit + else (Lwt_condition.wait q.empty >>= fun () -> empty q) +let rec full q = + if is_full q + then Lwt.return_unit + else (Lwt_condition.wait q.full >>= fun () -> full q) +let rec not_full q = + if not (is_empty q) + then Lwt.return_unit + else (Lwt_condition.wait q.not_full >>= fun () -> not_full q) + +exception Closed + +let rec push ({ closed ; queue ; full } as q) elt = + let len = Queue.length queue in + if closed then Lwt.fail Closed + else if available_space q len then begin Queue.push elt queue ; notify_push q ; + (if not (available_space q (len + 1)) then Lwt_condition.signal full ()); Lwt.return_unit end else wait_pop q >>= fun () -> push q elt -let rec push_now ({ queue; size } as q) elt = - Queue.length queue < size && begin +let rec push_now ({ closed ; queue ; full } as q) elt = + if closed then raise Closed ; + let len = Queue.length queue in + available_space q len && begin Queue.push elt queue ; notify_push q ; + (if not (available_space q (len + 1)) then Lwt_condition.signal full ()) ; true end -let rec pop ({ queue } as q) = +exception Full + +let push_now_exn q elt = + if not (push_now q elt) then raise Full + +let rec pop_all ({ closed ; queue ; empty ; not_full } as q) = + let was_full = is_full q in + if not (Queue.is_empty queue) then + let queue_copy = Queue.copy queue in + Queue.clear queue; + notify_pop q ; + (if was_full then Lwt_condition.signal not_full ()); + Lwt_condition.signal empty (); + Lwt.return queue_copy + else if closed then + Lwt.fail Closed + else + wait_push q >>= fun () -> + pop_all q + +let rec pop ({ closed ; queue ; empty ; not_full } as q) = + let was_full = is_full q in if not (Queue.is_empty queue) then let elt = Queue.pop queue in notify_pop q ; + (if was_full then Lwt_condition.signal not_full ()); + (if Queue.length queue = 0 then Lwt_condition.signal empty ()); Lwt.return elt + else if closed then + Lwt.fail Closed else wait_push q >>= fun () -> pop q -let rec peek ({ queue } as q) = +let rec peek ({ closed ; queue } as q) = if not (Queue.is_empty queue) then let elt = Queue.peek queue in Lwt.return elt + else if closed then + Lwt.fail Closed else wait_push q >>= fun () -> peek q -let pop_now_exn ({ queue } as q) = +exception Empty + +let pop_now_exn ({ closed ; queue ; empty ; not_full } as q) = + let was_full = is_full q in + if Queue.is_empty queue then + (if closed then raise Closed else raise Empty) ; let elt = Queue.pop queue in + (if was_full then Lwt_condition.signal not_full ()); + (if Queue.length queue = 0 then Lwt_condition.signal empty ()); notify_pop q ; elt +let pop_all_now ({ closed ; queue ; empty ; not_full } as q) = + let was_empty = is_empty q in + let was_full = is_full q in + if Queue.is_empty queue then + (if closed then raise Closed else raise Empty) ; + let queue_copy = Queue.copy queue in + Queue.clear queue ; + (if was_full then Lwt_condition.signal not_full ()); + (if not was_empty then Lwt_condition.signal empty ()); + notify_pop q ; + queue_copy + let pop_now q = match pop_now_exn q with - | exception Queue.Empty -> None + | exception Empty -> None | elt -> Some elt -let length { queue } = Queue.length queue -let is_empty { queue } = Queue.is_empty queue - let rec values_available q = if is_empty q then - wait_push q >>= fun () -> - values_available q + if q.closed then + raise Closed + else + wait_push q >>= fun () -> + values_available q else Lwt.return_unit + +let close q = + if not q.closed then begin + q.closed <- true ; + notify_push q ; + notify_pop q ; + Lwt_condition.broadcast_exn q.full Closed ; + end + +let rec iter q ~f = + Lwt.catch begin fun () -> + pop q >>= fun elt -> + f elt >>= fun () -> + iter q ~f + end begin function + | Closed -> Lwt.return_unit + | exn -> Lwt.fail exn + end + diff --git a/src/utils/lwt_pipe.mli b/src/utils/lwt_pipe.mli index f880522d8..8b282f36a 100644 --- a/src/utils/lwt_pipe.mli +++ b/src/utils/lwt_pipe.mli @@ -14,7 +14,7 @@ type 'a t (** Type of queues holding values of type ['a]. *) -val create : size:int -> 'a t +val create : ?size:int -> unit -> 'a t (** [create ~size] is an empty queue that can hold max [size] elements. *) @@ -22,6 +22,10 @@ val push : 'a t -> 'a -> unit Lwt.t (** [push q v] is a thread that blocks while [q] contains more than [size] elements, then adds [v] at the end of [q]. *) +val pop_all : 'a t -> 'a Queue.t Lwt.t +(** [pop' q] is a thread that returns all elements in [q] or waits + till there is at least one element in [q]. *) + val pop : 'a t -> 'a Lwt.t (** [pop q] is a thread that blocks while [q] is empty, then removes and returns the first element in [q]. *) @@ -38,10 +42,22 @@ val push_now : 'a t -> 'a -> bool (** [push_now q v] adds [v] at the ends of [q] immediately and returns [false] if [q] is currently full, [true] otherwise. *) +exception Full + +val push_now_exn : 'a t -> 'a -> unit +(** [push_now q v] adds [v] at the ends of [q] immediately or + raise [Full] if [q] is currently full. *) + +val pop_all_now : 'a t -> 'a Queue.t +(** [pop_all_now q] is a copy of [q]'s internal queue, that may be + empty. *) + val pop_now : 'a t -> 'a option (** [pop_now q] maybe removes and returns the first element in [q] if [q] contains at least one element. *) +exception Empty + val pop_now_exn : 'a t -> 'a (** [pop_now_exn q] removes and returns the first element in [q] if [q] contains at least one element, or raise [Empty] otherwise. *) @@ -52,3 +68,30 @@ val length : 'a t -> int val is_empty : 'a t -> bool (** [is_empty q] is [true] if [q] is empty, [false] otherwise. *) +val is_full : 'a t -> bool +(** [is_full q] is [true] if [q] is full, [false] otherwise. *) + +val empty : 'a t -> unit Lwt.t +(** [empty q] returns when [q] becomes empty. *) + +val full : 'a t -> unit Lwt.t +(** [full q] returns when [q] becomes full. *) + +val not_full : 'a t -> unit Lwt.t +(** [not_full q] returns when [q] stop being full. *) + +val iter : 'a t -> f:('a -> unit Lwt.t) -> unit Lwt.t +(** [iter q ~f] pops all elements of [q] and applies [f] on them. *) + +exception Closed + +val close : 'a t -> unit +(** [close q] the write end of [q]: + + * Future write attempts will fail with [Closed]. + * If there are reads blocked, they will unblock and fail with [Closed]. + * Future read attempts will drain the data until there is no data left. + + Thus, after a pipe has been closed, reads never block. + Close is idempotent. +*) diff --git a/src/utils/lwt_utils.ml b/src/utils/lwt_utils.ml index d3ad37d5b..00f857ab9 100644 --- a/src/utils/lwt_utils.ml +++ b/src/utils/lwt_utils.ml @@ -12,7 +12,7 @@ module LC = Lwt_condition open Lwt.Infix open Logging.Core -let may f = function +let may ~f = function | None -> Lwt.return_unit | Some x -> f x @@ -39,10 +39,13 @@ let canceler () else begin canceling := true ; LC.broadcast cancelation () ; - !cancel_hook () >>= fun () -> - canceled := true ; - LC.broadcast cancelation_complete () ; - Lwt.return () + Lwt.finalize + !cancel_hook + (fun () -> + canceled := true ; + LC.broadcast cancelation_complete () ; + Lwt.return ()) >>= fun () -> + Lwt.return_unit end in let on_cancel cb = @@ -55,6 +58,53 @@ let canceler () in cancelation, cancel, on_cancel +module Canceler = struct + + type t = { + cancelation: unit Lwt_condition.t ; + cancelation_complete: unit Lwt_condition.t ; + mutable cancel_hook: unit -> unit Lwt.t ; + mutable canceling: bool ; + mutable canceled: bool ; + } + + let create () = + let cancelation = LC.create () in + let cancelation_complete = LC.create () in + { cancelation ; cancelation_complete ; + cancel_hook = (fun () -> Lwt.return ()) ; + canceling = false ; + canceled = false ; + } + + let cancel st = + if st.canceled then + Lwt.return () + else if st.canceling then + LC.wait st.cancelation_complete + else begin + st.canceling <- true ; + LC.broadcast st.cancelation () ; + Lwt.finalize + st.cancel_hook + (fun () -> + st.canceled <- true ; + LC.broadcast st.cancelation_complete () ; + Lwt.return ()) + end + + let on_cancel st cb = + let hook = st.cancel_hook in + st.cancel_hook <- (fun () -> hook () >>= cb) + + let cancelation st = + if st.canceling then Lwt.return () + else LC.wait st.cancelation + + let canceled st = st.canceling + +end + type trigger = | Absent | Present @@ -114,12 +164,11 @@ let queue () : ('a -> unit) * (unit -> 'a list Lwt.t) = queue, wait (* A worker launcher, takes a cancel callback to call upon *) -let worker ?(safe=false) name ~run ~cancel = +let worker name ~run ~cancel = let stop = LC.create () in let fail e = log_error "%s worker failed with %s" name (Printexc.to_string e) ; - cancel () >>= fun () -> - if safe then Lwt.return_unit else Lwt.fail e + cancel () in let waiter = LC.wait stop in log_info "%s worker started" name ; @@ -263,6 +312,17 @@ let write_mbytes ?(pos=0) ?len descr buf = | nb_written -> inner (pos + nb_written) (len - nb_written) in inner pos len +let write_bytes ?(pos=0) ?len descr buf = + let len = match len with None -> Bytes.length buf - pos | Some l -> l in + let rec inner pos len = + if len = 0 then + Lwt.return_unit + else + Lwt_unix.write descr buf pos len >>= function + | 0 -> Lwt.fail End_of_file (* other endpoint cleanly closed its connection *) + | nb_written -> inner (pos + nb_written) (len - nb_written) in + inner pos len + let (>>=) = Lwt.bind let remove_dir dir = @@ -297,3 +357,49 @@ let create_file ?(perm = 0o644) name content = Lwt_unix.openfile name Unix.([O_TRUNC; O_CREAT; O_WRONLY]) perm >>= fun fd -> Lwt_unix.write_string fd content 0 (String.length content) >>= fun _ -> Lwt_unix.close fd + +let safe_close fd = + Lwt.catch + (fun () -> Lwt_unix.close fd) + (fun _ -> Lwt.return_unit) + +open Error_monad + +type error += Canceled + +let protect ?on_error ?canceler t = + let cancelation = + match canceler with + | None -> never_ending + | Some canceler -> + ( Canceler.cancelation canceler >>= fun () -> + fail Canceled ) in + let res = + Lwt.pick [ cancelation ; + Lwt.catch t (fun exn -> fail (Exn exn)) ] in + res >>= function + | Ok _ -> res + | Error err -> + let canceled = + Utils.unopt_map canceler ~default:false ~f:Canceler.canceled in + let err = if canceled then [Canceled] else err in + match on_error with + | None -> Lwt.return (Error err) + | Some on_error -> on_error err + +type error += Timeout + +let with_timeout ?(canceler = Canceler.create ()) timeout f = + let t = Lwt_unix.sleep timeout in + Lwt.choose [ + (t >|= fun () -> None) ; + (f canceler >|= fun x -> Some x) + ] >>= function + | Some x when Lwt.state t = Lwt.Sleep -> + Lwt.cancel t ; + Lwt.return x + | _ -> + Canceler.cancel canceler >>= fun () -> + fail Timeout + + diff --git a/src/utils/lwt_utils.mli b/src/utils/lwt_utils.mli index 0fd73d6cd..78cf995a2 100644 --- a/src/utils/lwt_utils.mli +++ b/src/utils/lwt_utils.mli @@ -7,7 +7,7 @@ (* *) (**************************************************************************) -val may : ('a -> unit Lwt.t) -> 'a option -> unit Lwt.t +val may: f:('a -> unit Lwt.t) -> 'a option -> unit Lwt.t val never_ending: 'a Lwt.t @@ -16,8 +16,18 @@ val canceler : unit -> (unit -> unit Lwt.t) * ((unit -> unit Lwt.t) -> unit) +module Canceler : sig + + type t + val create : unit -> t + val cancel : t -> unit Lwt.t + val cancelation : t -> unit Lwt.t + val on_cancel : t -> (unit -> unit Lwt.t) -> unit + val canceled : t -> bool + +end + val worker: - ?safe:bool -> string -> run:(unit -> unit Lwt.t) -> cancel:(unit -> unit Lwt.t) -> @@ -33,9 +43,27 @@ val read_bytes: val read_mbytes: ?pos:int -> ?len:int -> Lwt_unix.file_descr -> MBytes.t -> unit Lwt.t +val write_bytes: + ?pos:int -> ?len:int -> Lwt_unix.file_descr -> bytes -> unit Lwt.t val write_mbytes: ?pos:int -> ?len:int -> Lwt_unix.file_descr -> MBytes.t -> unit Lwt.t val remove_dir: string -> unit Lwt.t val create_dir: ?perm:int -> string -> unit Lwt.t val create_file: ?perm:int -> string -> string -> unit Lwt.t + +val safe_close: Lwt_unix.file_descr -> unit Lwt.t + +open Error_monad + +type error += Canceled +val protect : + ?on_error:(error list -> 'a tzresult Lwt.t) -> + ?canceler:Canceler.t -> + (unit -> 'a tzresult Lwt.t) -> 'a tzresult Lwt.t + +type error += Timeout +val with_timeout: + ?canceler:Canceler.t -> + float -> (Canceler.t -> 'a tzresult Lwt.t) -> 'a tzresult Lwt.t + diff --git a/src/utils/moving_average.ml b/src/utils/moving_average.ml index 00b79977c..eea6a4334 100644 --- a/src/utils/moving_average.ml +++ b/src/utils/moving_average.ml @@ -7,31 +7,80 @@ (* *) (**************************************************************************) -class type ma = object - method add_float : float -> unit - method add_int : int -> unit - method get : float -end +open Lwt.Infix -class virtual base ?(init = 0.) () = object (self) - val mutable acc : float = init - method virtual add_float : float -> unit - method add_int x = self#add_float (float_of_int x) - method get = acc -end +module Inttbl = Hashtbl.Make(struct + type t = int + let equal (x: int) (y: int) = x = y + let hash = Hashtbl.hash + end) -class sma ?init () = object - inherit base ?init () - val mutable i = match init with None -> 0 | _ -> 1 - method add_float x = - acc <- (acc +. (x -. acc) /. (float_of_int @@ succ i)) ; - i <- succ i -end +type t = { + id: int; + alpha: int ; + mutable total: int ; + mutable current: int ; + mutable average: int ; +} -class ema ?init ~alpha () = object - inherit base ?init () - val alpha = alpha - method add_float x = - acc <- alpha *. x +. (1. -. alpha) *. acc -end +let counters = Inttbl.create 51 +let updated = Lwt_condition.create () + +let update_hook = ref [] +let on_update f = update_hook := f :: !update_hook + +let worker_loop () = + let prev = ref @@ Mtime.elapsed () in + let rec inner sleep = + sleep >>= fun () -> + let sleep = Lwt_unix.sleep 1. in + let now = Mtime.elapsed () in + let elapsed = int_of_float (Mtime.(to_ms now -. to_ms !prev)) in + prev := now; + Inttbl.iter + (fun _ c -> + c.average <- + (c.alpha * c.current) / elapsed + (1000 - c.alpha) * c.average / 1000; + c.current <- 0) + counters ; + List.iter (fun f -> f ()) !update_hook ; + Lwt_condition.broadcast updated () ; + inner sleep + in + inner (Lwt_unix.sleep 1.) + +let worker = + lazy begin + Lwt.async begin fun () -> + let (_cancelation, cancel, _on_cancel) = Lwt_utils.canceler () in + Lwt_utils.worker "counter" ~run:worker_loop ~cancel + end + end + +let create = + let cpt = ref 0 in + fun ~init ~alpha -> + Lazy.force worker ; + let id = !cpt in + incr cpt ; + assert (0. < alpha && alpha <= 1.) ; + let alpha = int_of_float (1000. *. alpha) in + let c = { id ; alpha ; total = 0 ; current = 0 ; average = init } in + Inttbl.add counters id c ; + c + +let add c x = + c.total <- c.total + x ; + c.current <- c.current + x + +let destroy c = + Inttbl.remove counters c.id + +type stat = { + total: int ; + average: int ; +} + +let stat ({ total ; average } : t) : stat = + { total ; average } diff --git a/src/utils/moving_average.mli b/src/utils/moving_average.mli index a5768ee51..24acbe95b 100644 --- a/src/utils/moving_average.mli +++ b/src/utils/moving_average.mli @@ -7,28 +7,18 @@ (* *) (**************************************************************************) -(** Moving averages. The formulas are from Wikipedia - [https://en.wikipedia.org/wiki/Moving_average] *) +type t -class type ma = object - method add_float : float -> unit - method add_int : int -> unit - method get : float -end -(** Common class type for objects computing a cumulative moving - average of some flavor. In a cumulative moving average, the data - arrive in an ordered datum stream, and the user would like to get - the average of all of the data up until the current datum - point. The method [add_float] and [add_int] are used to add the - next datum. The method [get] and [get_exn] are used to compute the - moving average up until the current datum point. *) +val create: init:int -> alpha:float -> t +val destroy: t -> unit -class sma : ?init:float -> unit -> ma -(** [sma ?init ()] is an object that computes the Simple Moving - Average of a datum stream. [SMA(n+1) = SMA(n) + (x_(n+1) / SMA(n)) - / (n+1)] *) +val add: t -> int -> unit -class ema : ?init:float -> alpha:float -> unit -> ma -(** [ema ?init ~alpha ()] is an object that computes the Exponential - Moving Average of a datum stream. [EMA(n+1) = alpha * x_(n+1) + - (1 - alpha) * x_n] *) +val on_update: (unit -> unit) -> unit +val updated: unit Lwt_condition.t + +type stat = { + total: int ; + average: int ; +} +val stat: t -> stat diff --git a/src/utils/ring.ml b/src/utils/ring.ml new file mode 100644 index 000000000..7c829622e --- /dev/null +++ b/src/utils/ring.ml @@ -0,0 +1,59 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +type 'a raw = + | Empty of int + | Inited of { + data : 'a array ; + mutable pos : int ; + } + +type 'a t = 'a raw ref + +let create size = ref (Empty size) + +let add r v = + match !r with + | Empty size -> + r := Inited { data = Array.make size v ; pos = 0 } + | Inited s -> + s.pos <- + if s.pos = 2 * Array.length s.data - 1 then + Array.length s.data + else + s.pos + 1 ; + s.data.(s.pos mod Array.length s.data) <- v + +let add_list r l = List.iter (add r) l + +let last r = + match !r with + | Empty _ -> None + | Inited { data ; pos } -> Some data.(pos mod Array.length data) + +let fold r ~init ~f = + match !r with + | Empty _ -> init + | Inited { data ; pos } -> + let size = Array.length data in + let acc = ref init in + for i = 0 to min pos (size - 1) do + acc := f !acc data.((pos - i) mod size) + done ; + !acc + +let elements t = + fold t ~init:[] ~f:(fun acc elt -> elt :: acc) + +exception Empty + +let last_exn r = + match last r with + | None -> raise Empty + | Some d -> d diff --git a/src/utils/ring.mli b/src/utils/ring.mli new file mode 100644 index 000000000..fe1b71b51 --- /dev/null +++ b/src/utils/ring.mli @@ -0,0 +1,20 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(** Imperative Ring Buffer *) + +type 'a t +val create : int -> 'a t +val add : 'a t -> 'a -> unit +val add_list : 'a t -> 'a list -> unit +val last : 'a t -> 'a option +exception Empty +val last_exn : 'a t -> 'a +val fold : 'a t -> init:'b -> f:('b -> 'a -> 'b) -> 'b +val elements : 'a t -> 'a list diff --git a/src/utils/time.ml b/src/utils/time.ml index e52fa775a..c4ea6f4dc 100644 --- a/src/utils/time.ml +++ b/src/utils/time.ml @@ -10,106 +10,125 @@ open Error_monad open CalendarLib -type t = int64 +module T = struct + include Int64 -let compare = Int64.compare -let (=) x y = compare x y = 0 -let equal = (=) -let (<>) x y = compare x y <> 0 -let (<) x y = compare x y < 0 -let (<=) x y = compare x y <= 0 -let (>=) x y = compare x y >= 0 -let (>) x y = compare x y > 0 -let min x y = if x <= y then x else y -let max x y = if x <= y then y else x + let diff a b = + let sign = a >= b in + let res = Int64.sub a b in + let res_sign = res >= 0L in + if sign = res_sign then res else invalid_arg "Time.diff" ;; -let add = Int64.add -let diff = Int64.sub + let add a d = + let sign = d >= 0L in + let res = Int64.add a d in + let incr_sign = res >= a in + if sign = incr_sign then res else invalid_arg "Time.add" ;; -let now () = Int64.of_float (Unix.gettimeofday ()) + let hash = to_int + let (=) = equal + let (<>) x y = compare x y <> 0 + let (<) x y = compare x y < 0 + let (<=) x y = compare x y <= 0 + let (>=) x y = compare x y >= 0 + let (>) x y = compare x y > 0 + let min x y = if x <= y then x else y + let max x y = if x <= y then y else x -let of_seconds x = x -let to_seconds x = x + let min_value = min_int + let epoch = 0L + let max_value = max_int -let formats = - [ "%Y-%m-%dT%H:%M:%SZ" ; "%Y-%m-%d %H:%M:%SZ"; - "%Y-%m-%dT%H:%M:%S%:z"; "%Y-%m-%d %H:%M:%S%:z"; ] + let now () = Int64.of_float (Unix.gettimeofday ()) -let int64_of_calendar c = - let round fc = - let f, i = modf fc in - Int64.(add (of_float i) Pervasives.(if f < 0.5 then 0L else 1L)) in - round @@ Calendar.Precise.to_unixfloat c + let of_seconds x = x + let to_seconds x = x -let rec iter_formats s = function - | [] -> None - | f :: fs -> - try - Some (int64_of_calendar @@ Printer.Precise_Calendar.from_fstring f s) - with _ -> iter_formats s fs + let formats = + [ "%Y-%m-%dT%H:%M:%SZ" ; "%Y-%m-%d %H:%M:%SZ"; + "%Y-%m-%dT%H:%M:%S%:z"; "%Y-%m-%d %H:%M:%S%:z"; ] -let of_notation s = - iter_formats s formats -let of_notation_exn s = - match of_notation s with - | None -> invalid_arg "Time.of_notation: can't parse." - | Some t -> t + let int64_of_calendar c = + let round fc = + let f, i = modf fc in + Int64.(add (of_float i) Pervasives.(if f < 0.5 then 0L else 1L)) in + round @@ Calendar.Precise.to_unixfloat c -let to_notation t = - let ft = Int64.to_float t in - if Int64.of_float ft <> t then - "out_of_range" - else - Printer.Precise_Calendar.sprint - "%Y-%m-%dT%H:%M:%SZ" - (Calendar.Precise.from_unixfloat ft) + let rec iter_formats s = function + | [] -> None + | f :: fs -> + try + Some (int64_of_calendar @@ Printer.Precise_Calendar.from_fstring f s) + with _ -> iter_formats s fs -let rfc_encoding = - let open Data_encoding in - def - "timestamp" @@ - describe - ~title: - "RFC 339 formatted timestamp" - ~description: - "A date in human readble form as specified in RFC 3339." @@ - conv - to_notation - (fun s -> match of_notation s with - | Some s -> s - | None -> Data_encoding.Json.cannot_destruct "Time.of_notation") - string + let of_notation s = + iter_formats s formats + let of_notation_exn s = + match of_notation s with + | None -> invalid_arg "Time.of_notation: can't parse." + | Some t -> t -let encoding = - let open Data_encoding in - splitted - ~binary: int64 - ~json: - (union [ - case - rfc_encoding - (fun i -> Some i) - (fun i -> i) ; - case - int64 - (fun _ -> None) - (fun i -> i) ; - ]) + let to_notation t = + let ft = Int64.to_float t in + if Int64.of_float ft <> t then + "out_of_range" + else + Printer.Precise_Calendar.sprint + "%Y-%m-%dT%H:%M:%SZ" + (Calendar.Precise.from_unixfloat ft) -type 'a timed_data = { - data: 'a ; - time: t ; -} + let rfc_encoding = + let open Data_encoding in + def + "timestamp" @@ + describe + ~title: + "RFC 3339 formatted timestamp" + ~description: + "A date in human readble form as specified in RFC 3339." @@ + conv + to_notation + (fun s -> match of_notation s with + | Some s -> s + | None -> Data_encoding.Json.cannot_destruct "Time.of_notation") + string -let timed_encoding arg_encoding = - let open Data_encoding in - conv - (fun {time; data} -> (time, data)) - (fun (time, data) -> {time; data}) - (tup2 encoding arg_encoding) + let encoding = + let open Data_encoding in + splitted + ~binary: int64 + ~json: + (union [ + case + rfc_encoding + (fun i -> Some i) + (fun i -> i) ; + case + int64 + (fun _ -> None) + (fun i -> i) ; + ]) -let make_timed data = { - data ; time = now () ; -} + type 'a timed_data = { + data: 'a ; + time: t ; + } -let pp_hum ppf t = Format.pp_print_string ppf (to_notation t) + let timed_encoding arg_encoding = + let open Data_encoding in + conv + (fun {time; data} -> (time, data)) + (fun (time, data) -> {time; data}) + (tup2 encoding arg_encoding) + + let make_timed data = { + data ; time = now () ; + } + + let pp_hum ppf t = Format.pp_print_string ppf (to_notation t) +end + +include T +module Set = Set.Make(T) +module Map = Map.Make(T) +module Table = Hashtbl.Make(T) diff --git a/src/utils/time.mli b/src/utils/time.mli index 8d209894e..7498899e5 100644 --- a/src/utils/time.mli +++ b/src/utils/time.mli @@ -9,6 +9,10 @@ type t +val min_value : t +val epoch : t +val max_value : t + val add : t -> int64 -> t val diff : t -> t -> int64 @@ -46,3 +50,7 @@ type 'a timed_data = { val make_timed : 'a -> 'a timed_data val timed_encoding : 'a Data_encoding.t -> 'a timed_data Data_encoding.t + +module Set : Set.S with type elt = t +module Map : Map.S with type key = t +module Table : Hashtbl.S with type key = t diff --git a/test/Makefile b/test/Makefile index 429836541..734f8cd4b 100644 --- a/test/Makefile +++ b/test/Makefile @@ -1,5 +1,11 @@ -TESTS := data-encoding store context state basic basic.sh +TESTS := \ + data-encoding \ + store context state \ + basic basic.sh \ + p2p-io-scheduler \ + p2p-connection \ + p2p-connection-pool all: test @@ -33,9 +39,11 @@ PACKAGES := \ dynlink \ ezjsonm \ git \ + ipv6-multicast \ irmin.unix \ lwt \ lwt.unix \ + mtime.os \ ocplib-endian \ ocplib-ocamlres \ ocplib-json-typed.bson \ @@ -66,9 +74,9 @@ ${NODELIB} ${CLIENTLIB}: ${MAKE} -C ../src $@ .PHONY: build-test run-test test -build-test: ${addprefix build-test-,${TESTS}} test-p2p +build-test: ${addprefix build-test-,${TESTS}} run-test: - @$(patsubst %,${MAKE} run-test-% ; , ${TESTS}) \ + @$(patsubst %,${MAKE} run-test-% && , ${TESTS}) \ echo && echo "Success" && echo test: @${MAKE} --no-print-directory build-test @@ -177,13 +185,63 @@ clean:: ############################################################################ ## p2p test program -TEST_P2P_INTFS = +.PHONY:build-test-p2p-io-scheduler run-test-p2p-io-scheduler +build-test-p2p-io-scheduler: test-p2p-io-scheduler +run-test-p2p-io-scheduler: + ./test-p2p-io-scheduler \ + --delay 20 --clients 8 \ + --max-upload-speed $$((1 << 18)) \ + --max-download-speed $$((1 << 20)) -TEST_P2P_IMPLS = \ - test_p2p.ml +.PHONY:build-test-p2p-connection run-test-p2p-connection +build-test-p2p-connection: test-p2p-connection +run-test-p2p-connection: + ./test-p2p-connection + +.PHONY:build-test-p2p-connection-pool run-test-p2p-connection-pool +build-test-p2p-connection-pool: test-p2p-connection-pool +run-test-p2p-connection-pool: + ./test-p2p-connection-pool --clients 10 --repeat 5 + +TEST_P2P_IO_SCHEDULER_IMPLS = \ + lib/process.ml \ + test_p2p_io_scheduler.ml + +TEST_P2P_CONNECTION_IMPLS = \ + lib/process.ml \ + test_p2p_connection.ml + +TEST_P2P_CONNECTION_POOL_IMPLS = \ + lib/process.ml \ + test_p2p_connection_pool.ml + +${TEST_P2P_IO_SCHEDULER_IMPLS:.ml=.cmx}: ${NODELIB} +test-p2p-io-scheduler: ${NODELIB} ${TEST_P2P_IO_SCHEDULER_IMPLS:.ml=.cmx} + ocamlfind ocamlopt -linkall -linkpkg ${OCAMLFLAGS} -o $@ $^ + +${TEST_P2P_CONNECTION_IMPLS:.ml=.cmx}: ${NODELIB} +test-p2p-connection: ${NODELIB} ${TEST_P2P_CONNECTION_IMPLS:.ml=.cmx} + ocamlfind ocamlopt -linkall -linkpkg ${OCAMLFLAGS} -o $@ $^ + +${TEST_P2P_CONNECTION_POOL_IMPLS:.ml=.cmx}: ${NODELIB} +test-p2p-connection-pool: ${NODELIB} ${TEST_P2P_CONNECTION_POOL_IMPLS:.ml=.cmx} + ocamlfind ocamlopt -linkall -linkpkg ${OCAMLFLAGS} -o $@ $^ + +clean:: + -rm -f test-p2p-io_scheduler + -rm -f test-p2p-connection + -rm -f test-p2p-connection-pool + +############################################################################ +## lwt pipe test program + +build-test-lwt-pipe: test-lwt-pipe + +TEST_PIPE_IMPLS = \ + test_lwt_pipe.ml ${TEST_BASIC_IMPLS:.ml=.cmx}: ${NODELIB} -test-p2p: ${NODELIB} ${TEST_P2P_IMPLS:.ml=.cmx} +test-lwt-pipe: ${NODELIB} ${TEST_PIPE_IMPLS:.ml=.cmx} ocamlfind ocamlopt -linkall -linkpkg ${OCAMLFLAGS} -o $@ $^ clean:: @@ -233,6 +291,14 @@ bisect: bisect-ppx-report $(COVERAGESRCDIR) \ -ignore-missing-files -html reports bisect*.out +##### + +lib/assert.cmx: lib/assert.cmi +lib/assert.cmi: ../src/node/db/persist.cmi + +lib/process.cmx: lib/process.cmi +lib/test.cmx: lib/test.cmi + ############################################################################ ## Generic rules diff --git a/test/lib/process.ml b/test/lib/process.ml new file mode 100644 index 000000000..2a60b2bbc --- /dev/null +++ b/test/lib/process.ml @@ -0,0 +1,79 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +include Logging.Make (struct let name = "process" end) + +open Error_monad + +exception Exited of int + +let detach ?(prefix = "") f = + Lwt_io.flush_all () >>= fun () -> + match Lwt_unix.fork () with + | 0 -> + Random.self_init () ; + let template = Format.asprintf "%s$(section): $(message)" prefix in + let logger = + Lwt_log.channel + ~template ~close_mode:`Keep ~channel:Lwt_io.stderr () in + Logging.init (Manual logger) ; + Lwt_main.run begin + lwt_log_notice "PID: %d" (Unix.getpid ()) >>= fun () -> + f () + end ; + exit 0 + | pid -> + Lwt.catch + (fun () -> + Lwt_unix.waitpid [] pid >>= function + | (_,Lwt_unix.WEXITED 0) -> + Lwt.return_unit + | (_,Lwt_unix.WEXITED n) -> + Lwt.fail (Exited n) + | (_,Lwt_unix.WSIGNALED _) + | (_,Lwt_unix.WSTOPPED _) -> + Lwt.fail Exit) + (function + | Lwt.Canceled -> + Unix.kill pid Sys.sigkill ; + Lwt.return_unit + | exn -> Lwt.fail exn) + +let handle_error f = + Lwt.catch + f + (fun exn -> Lwt.return (error_exn exn)) >>= function + | Ok () -> Lwt.return_unit + | Error err -> + lwt_log_error "%a" Error_monad.pp_print_error err >>= fun () -> + exit 1 + +let rec wait processes = + Lwt.catch + (fun () -> + Lwt.nchoose_split processes >>= function + | (_, []) -> lwt_log_notice "All done!" + | (_, processes) -> wait processes) + (function + | Exited n -> + lwt_log_notice "Early error!" >>= fun () -> + List.iter Lwt.cancel processes ; + Lwt.catch + (fun () -> Lwt.join processes) + (fun _ -> Lwt.return_unit) >>= fun () -> + lwt_log_notice "A process finished with error %d !" n >>= fun () -> + Pervasives.exit n + | exn -> + lwt_log_notice "Unexpected error!%a" + Error_monad.pp_exn exn >>= fun () -> + List.iter Lwt.cancel processes ; + Lwt.catch + (fun () -> Lwt.join processes) + (fun _ -> Lwt.return_unit) >>= fun () -> + Pervasives.exit 2) diff --git a/test/lib/process.mli b/test/lib/process.mli new file mode 100644 index 000000000..c1933cc11 --- /dev/null +++ b/test/lib/process.mli @@ -0,0 +1,15 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Error_monad +exception Exited of int + +val detach: ?prefix:string -> (unit -> unit Lwt.t) -> unit Lwt.t +val handle_error: (unit -> (unit, error list) result Lwt.t) -> unit Lwt.t +val wait: unit Lwt.t list -> unit Lwt.t diff --git a/test/test_lwt_pipe.ml b/test/test_lwt_pipe.ml new file mode 100644 index 000000000..3756a1483 --- /dev/null +++ b/test/test_lwt_pipe.ml @@ -0,0 +1,50 @@ +open Lwt.Infix +include Logging.Make (struct let name = "test-pipe" end) + +let rec producer queue = function + | 0 -> + lwt_log_notice "Done producing." + | n -> + Lwt_pipe.push queue () >>= fun () -> + producer queue (pred n) + +let rec consumer queue = function + | 0 -> + lwt_log_notice "Done consuming." + | n -> + Lwt_pipe.pop queue >>= fun _ -> + consumer queue (pred n) + +let rec gen acc f = function + | 0 -> acc + | n -> gen (f () :: acc) f (pred n) + +let run qsize nbp nbc p c = + let q = Lwt_pipe.create qsize in + let producers = gen [] (fun () -> producer q p) nbp in + let consumers = gen [] (fun () -> consumer q c) nbc in + Lwt.join producers <&> Lwt.join consumers + +let main () = + let qsize = ref 10 in + let nb_producers = ref 10 in + let nb_consumers = ref 10 in + let produced_per_producer = ref 10 in + let consumed_per_consumer = ref 10 in + let spec = Arg.[ + "-qsize", Set_int qsize, " Size of the pipe"; + "-nc", Set_int nb_consumers, " Number of consumers"; + "-np", Set_int nb_producers, " Number of producers"; + "-n", Set_int consumed_per_consumer, " Number of consumed items per consumers"; + "-p", Set_int produced_per_producer, " Number of produced items per producers"; + "-v", Unit (fun () -> Lwt_log_core.(add_rule "*" Info)), " Log up to info msgs"; + "-vv", Unit (fun () -> Lwt_log_core.(add_rule "*" Debug)), " Log up to debug msgs"; + ] + in + let anon_fun _ = () in + let usage_msg = "Usage: %s .\nArguments are:" in + Arg.parse spec anon_fun usage_msg; + run !qsize !nb_producers + !nb_consumers !produced_per_producer !consumed_per_consumer + +let () = Lwt_main.run @@ main () diff --git a/test/test_p2p.ml b/test/test_p2p.ml deleted file mode 100644 index bf1c44617..000000000 --- a/test/test_p2p.ml +++ /dev/null @@ -1,167 +0,0 @@ -open Lwt.Infix -open P2p - -include Logging.Make (struct let name = "test-p2p" end) - -module Param = struct - - let dump_encoding = Data_encoding.(Variable.list (tup2 string string)) - - type msg = - | Create of string * string - | Update of string * string - | Delete of string - | Dump of (string * string) list - - let encodings = [ - Encoding { tag = 0x10; - encoding = Data_encoding.(tup2 string string); - wrap = (function (k, v) -> Create (k, v)); - unwrap = (function Create (k, v) -> Some (k, v) | _ -> None); - max_length = Some 0x400; - }; - Encoding { tag = 0x11; - encoding = Data_encoding.(tup2 string string); - wrap = (function (k, v) -> Update (k, v)); - unwrap = (function Create (k, v) -> Some (k, v) | _ -> None); - max_length = Some 0x400; - }; - Encoding { tag = 0x12; - encoding = Data_encoding.string; - wrap = (function x -> Delete x); - unwrap = (function Delete x -> Some x | _ -> None); - max_length = Some 0x400; - }; - Encoding { tag = 0x13; - encoding = dump_encoding; - wrap = (function x -> Dump x); - unwrap = (function Dump x -> Some x | _ -> None); - max_length = Some 0x10000; - }; - ] - - type metadata = unit - let initial_metadata = () - let metadata_encoding = Data_encoding.empty - let score () = 0. - - let supported_versions = [ { name = "TEST"; major = 0; minor = 0; } ] -end - -module Net = Make(Param) - -let print_peer_info { Net.gid; addr; port; version = { name; major; minor } } = - Printf.sprintf "%s:%d (%s.%d.%d)" (Ipaddr.to_string addr) port name major minor - -let string_of_gid gid = Format.asprintf "%a" pp_gid gid - -let net_monitor config limits num_nets net = - let my_gid_str = string_of_gid @@ Net.gid net in - let send_msgs_to_neighbours neighbours = - Lwt_list.iter_p begin fun p -> - let { Net.gid } = Net.peer_info net p in - let remote_gid_str = string_of_gid gid in - Net.send net p (Create (my_gid_str, remote_gid_str)) >>= fun _ -> - lwt_log_notice "(%s) Done sending msg to %s" my_gid_str remote_gid_str - end neighbours >>= fun () -> - lwt_log_notice "(%s) Done sending all msgs." my_gid_str - in - let rec inner () = - let neighbours = Net.peers net in - let nb_neighbours = List.length neighbours in - if nb_neighbours < num_nets - 1 then begin - log_notice "(%s) I have %d peers" my_gid_str nb_neighbours; - Lwt_unix.sleep 1. >>= inner end - else begin - log_notice "(%s) I know all my %d peers" my_gid_str nb_neighbours; - Lwt.async (fun () -> send_msgs_to_neighbours neighbours); - let rec recv_peer_msgs acc = - if List.length acc = num_nets - 1 then begin - (* Print total sent/recv *) - let peers = Net.peers net in - ListLabels.iter peers ~f:begin fun p -> - let pi = Net.peer_info net p in - log_info "%a -> %a %d %d %.2f %.2f" pp_gid (Net.gid net) pp_gid pi.gid - pi.total_sent pi.total_recv pi.current_inflow pi.current_outflow; - end; - ListLabels.iter acc ~f:(fun (k, v) -> log_info "%s %s" k v); - Lwt.return_unit - end - else begin - lwt_log_notice "(%s) recv_peers_msgs: Got %d, need %d" - my_gid_str (List.length acc) (num_nets - 1) >>= fun () -> - Net.recv net >>= function - | p, (Create (their_gid, my_gid)) -> - lwt_log_notice "(%s) Got a message from %s" my_gid_str their_gid >>= fun () -> - recv_peer_msgs ((their_gid, my_gid) :: acc) - | _ -> assert false - end - in - recv_peer_msgs [] - end - in inner () - -let range n = - let rec inner acc = function - | -1 -> acc - | n -> inner (n :: acc) (pred n) - in - if n < 0 then invalid_arg "range" - else inner [] (pred n) - -let main () = - let incoming_port = ref @@ Some 11732 in - let discovery_port = ref @@ Some 10732 in - let closed_network = ref false in - - let max_packet_size = ref 1024 in - let peer_answer_timeout = ref 10. in - let blacklist_time = ref 100. in - let num_networks = ref 0 in - - let make_net nb_neighbours n = - let config = { - incoming_port = Utils.map_option !incoming_port ~f:(fun p -> p + n); - discovery_port = !discovery_port; - known_peers = []; - peers_file = ""; - closed_network = !closed_network; - } - in - let limits = { - max_message_size = !max_packet_size; - peer_answer_timeout = !peer_answer_timeout; - expected_connections = nb_neighbours; - min_connections = nb_neighbours; - max_connections = nb_neighbours; - blacklist_time = !blacklist_time; - } - in - Net.bootstrap ~config ~limits >|= fun net -> - config, limits, net - in - let spec = Arg.[ - "-start-port", Int (fun p -> incoming_port := Some p), " Incoming port"; - "-dport", Int (fun p -> discovery_port := Some p), " Discovery port"; - "-closed", Set closed_network, " Closed network mode"; - - "-max-packet-size", Set_int max_packet_size, "int Max size of packets"; - "-peer-answer-timeout", Set_float peer_answer_timeout, "float Number of seconds"; - "-blacklist-time", Set_float blacklist_time, "float Number of seconds"; - "-v", Unit (fun () -> Lwt_log_core.(add_rule "*" Info)), " Log up to info msgs"; - "-vv", Unit (fun () -> Lwt_log_core.(add_rule "*" Debug)), " Log up to debug msgs"; - ] - in - let anon_fun num_peers = num_networks := int_of_string num_peers in - let usage_msg = "Usage: %s .\nArguments are:" in - Arg.parse spec anon_fun usage_msg; - let nets = range !num_networks in - Lwt_list.map_p (make_net (pred !num_networks)) nets >>= fun nets -> - Lwt_list.iter_p (fun (cfg, limits, net) -> net_monitor cfg limits !num_networks net) nets >>= fun () -> - lwt_log_notice "All done!" - -let () = - Sys.catch_break true; - try - Lwt_main.run @@ main () - with _ -> () diff --git a/test/test_p2p_connection.ml b/test/test_p2p_connection.ml new file mode 100644 index 000000000..e0d84cbc8 --- /dev/null +++ b/test/test_p2p_connection.ml @@ -0,0 +1,204 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(* TODO Use Kaputt on the client side and remove `assert` from the + server. *) + +open Error_monad +open P2p_types +include Logging.Make (struct let name = "test-p2p-connection" end) + +let proof_of_work_target = + Crypto_box.make_target [Int64.shift_left 1L 48] +let id1 = Identity.generate proof_of_work_target +let id2 = Identity.generate proof_of_work_target + +let id0 = + (* Luckilly, this will be an insuficient proof of work! *) + Identity.generate (Crypto_box.make_target []) + +let versions = Version.[{ name = "TEST" ; minor = 0 ; major = 0 }] + +let rec listen ?port addr = + let tentative_port = + match port with + | None -> 1024 + Random.int 8192 + | Some port -> port in + let uaddr = Ipaddr_unix.V6.to_inet_addr addr in + let main_socket = Lwt_unix.(socket PF_INET6 SOCK_STREAM 0) in + Lwt_unix.(setsockopt main_socket SO_REUSEADDR true) ; + Lwt.catch begin fun () -> + Lwt_unix.Versioned.bind_2 main_socket + (ADDR_INET (uaddr, tentative_port)) >>= fun () -> + Lwt_unix.listen main_socket 1 ; + Lwt.return (main_socket, tentative_port) + end begin function + | Unix.Unix_error + ((Unix.EADDRINUSE | Unix.EADDRNOTAVAIL), _, _) when port = None -> + listen addr + | exn -> Lwt.fail exn + end + +let raw_accept sched main_socket = + Lwt_unix.accept main_socket >>= fun (fd, sockaddr) -> + let fd = P2p_io_scheduler.register sched fd in + let point = + match sockaddr with + | Lwt_unix.ADDR_UNIX _ -> assert false + | Lwt_unix.ADDR_INET (addr, port) -> + Ipaddr_unix.V6.of_inet_addr_exn addr, port in + Lwt.return (fd, point) + +let accept sched main_socket = + raw_accept sched main_socket >>= fun (fd, point) -> + P2p_connection.authenticate + ~proof_of_work_target + ~incoming:true fd point id1 versions + +let raw_connect sched addr port = + let fd = Lwt_unix.socket PF_INET6 SOCK_STREAM 0 in + let uaddr = + Lwt_unix.ADDR_INET (Ipaddr_unix.V6.to_inet_addr addr, port) in + Lwt_unix.connect fd uaddr >>= fun () -> + let fd = P2p_io_scheduler.register sched fd in + Lwt.return fd + +let connect sched addr port id = + raw_connect sched addr port >>= fun fd -> + P2p_connection.authenticate + ~proof_of_work_target + ~incoming:false fd (addr, port) id versions >>=? fun (info, auth_fd) -> + assert (not info.incoming) ; + assert (Gid.compare info.gid id1.gid = 0) ; + return auth_fd + +let simple_msg = + MBytes.create (1 lsl 1) + +let is_rejected = function + | Error [P2p_connection.Rejected] -> true + | Ok _ | Error _ -> false + +let is_connection_closed = function + | Error [P2p_io_scheduler.Connection_closed] -> true + | Ok _ | Error _ -> false + +let bytes_encoding = Data_encoding.Variable.bytes + +let server main_socket = + let sched = P2p_io_scheduler.create ~read_buffer_size:(1 lsl 12) () in + (* Low-level test. *) + raw_accept sched main_socket >>= fun (fd, point) -> + lwt_log_notice "Low_level" >>= fun () -> + P2p_io_scheduler.write fd simple_msg >>=? fun () -> + P2p_io_scheduler.close fd >>=? fun _ -> + lwt_log_notice "Low_level OK" >>= fun () -> + (* Kick the first connection. *) + accept sched main_socket >>=? fun (info, auth_fd) -> + lwt_log_notice "Kick" >>= fun () -> + assert (info.incoming) ; + assert (Gid.compare info.gid id2.gid = 0) ; + P2p_connection.kick auth_fd >>= fun () -> + lwt_log_notice "Kick OK" >>= fun () -> + (* Let's be rejected. *) + accept sched main_socket >>=? fun (info, auth_fd) -> + P2p_connection.accept auth_fd bytes_encoding >>= fun conn -> + assert (is_rejected conn) ; + lwt_log_notice "Kicked OK" >>= fun () -> + (* Accept and send a single message. *) + accept sched main_socket >>=? fun (info, auth_fd) -> + lwt_log_notice "Single" >>= fun () -> + P2p_connection.accept auth_fd bytes_encoding >>=? fun conn -> + P2p_connection.write_sync conn simple_msg >>=? fun () -> + P2p_connection.close conn >>= fun _stat -> + lwt_log_notice "Single OK" >>= fun () -> + (* Accept and send a single message, while the client expected 2. *) + accept sched main_socket >>=? fun (info, auth_fd) -> + lwt_log_notice "Early close (read)" >>= fun () -> + P2p_connection.accept auth_fd bytes_encoding >>=? fun conn -> + P2p_connection.write_sync conn simple_msg >>=? fun () -> + P2p_connection.close conn >>= fun _stat -> + lwt_log_notice "Early close (read) OK" >>= fun () -> + (* Accept and wait for the client to close the connection. *) + accept sched main_socket >>=? fun (info, auth_fd) -> + lwt_log_notice "Early close (write)" >>= fun () -> + P2p_connection.accept auth_fd bytes_encoding >>=? fun conn -> + P2p_connection.close conn >>= fun _stat -> + lwt_log_notice "Early close (write) OK" >>= fun () -> + P2p_io_scheduler.shutdown sched >>= fun () -> + Lwt_unix.sleep 0.2 >>= fun () -> + lwt_log_notice "Success" >>= fun () -> + return () + +let client addr port = + let msg = MBytes.create (MBytes.length simple_msg) in + let sched = P2p_io_scheduler.create ~read_buffer_size:(1 lsl 12) () in + raw_connect sched addr port >>= fun fd -> + P2p_io_scheduler.read_full fd msg >>=? fun () -> + assert (MBytes.compare simple_msg msg = 0) ; + P2p_io_scheduler.close fd >>=? fun () -> + lwt_log_notice "Low_level OK" >>= fun () -> + (* let's be rejected. *) + connect sched addr port id2 >>=? fun auth_fd -> + P2p_connection.accept auth_fd bytes_encoding >>= fun conn -> + assert (is_rejected conn) ; + lwt_log_notice "Kick OK" >>= fun () -> + (* let's reject! *) + lwt_log_notice "Kicked" >>= fun () -> + connect sched addr port id2 >>=? fun auth_fd -> + P2p_connection.kick auth_fd >>= fun () -> + (* let's exchange a simple message. *) + connect sched addr port id2 >>=? fun auth_fd -> + P2p_connection.accept auth_fd bytes_encoding >>=? fun conn -> + P2p_connection.read conn >>=? fun msg -> + assert (MBytes.compare simple_msg msg = 0) ; + P2p_connection.close conn >>= fun _stat -> + lwt_log_notice "Simple OK" >>= fun () -> + (* let's detect a closed connection on `read`. *) + connect sched addr port id2 >>=? fun auth_fd -> + P2p_connection.accept auth_fd bytes_encoding >>=? fun conn -> + P2p_connection.read conn >>=? fun msg -> + assert (MBytes.compare simple_msg msg = 0) ; + P2p_connection.read conn >>= fun msg -> + assert (is_connection_closed msg) ; + P2p_connection.close conn >>= fun _stat -> + lwt_log_notice "Early close (read) OK" >>= fun () -> + (* let's detect a closed connection on `write`. *) + connect sched addr port id2 >>=? fun auth_fd -> + P2p_connection.accept auth_fd bytes_encoding >>=? fun conn -> + Lwt_unix.sleep 0.1 >>= fun () -> + P2p_connection.write_sync conn simple_msg >>= fun unit -> + assert (is_connection_closed unit) ; + P2p_connection.close conn >>= fun _stat -> + lwt_log_notice "Early close (write) OK" >>= fun () -> + P2p_io_scheduler.shutdown sched >>= fun () -> + lwt_log_notice "Success" >>= fun () -> + return () + +let default_addr = Ipaddr.V6.localhost + +let main () = + listen default_addr >>= fun (main_socket, port) -> + let server = + Process.detach ~prefix:"server " begin fun () -> + Process.handle_error begin fun () -> + server main_socket + end + end in + let client = + Process.detach ~prefix:"client " begin fun () -> + Lwt_utils.safe_close main_socket >>= fun () -> + Process.handle_error begin fun () -> + client default_addr port + end + end in + Process.wait [ server ; client ] + +let () = + Lwt_main.run (main ()) diff --git a/test/test_p2p_connection_pool.ml b/test/test_p2p_connection_pool.ml new file mode 100644 index 000000000..bf3e8b20c --- /dev/null +++ b/test/test_p2p_connection_pool.ml @@ -0,0 +1,196 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Error_monad +open P2p_types +include Logging.Make (struct let name = "test-p2p-connection-pool" end) + +type message = + | Ping + + +let msg_config : message P2p_connection_pool.message_config = { + encoding = [ + P2p_connection_pool.Encoding { + tag = 0x10 ; + encoding = Data_encoding.empty ; + wrap = (function () -> Ping) ; + unwrap = (function Ping -> Some ()) ; + max_length = None ; + } ; + ] ; + versions = Version.[ { name = "TEST" ; major = 0 ; minor = 0 } ] ; +} + +type metadata = unit + +let meta_config : metadata P2p_connection_pool.meta_config = { + encoding = Data_encoding.empty ; + initial = () ; +} + +let rec connect ~timeout pool point = + lwt_log_info "Connect to %a" Point.pp point >>= fun () -> + P2p_connection_pool.connect pool point ~timeout >>= function + | Error [P2p_connection_pool.Connected] -> begin + match P2p_connection_pool.Points.find_connection pool point with + | Some conn -> return conn + | None -> failwith "Woops..." + end + | Error ([ P2p_connection_pool.Connection_refused + | P2p_connection_pool.Pending_connection + | P2p_connection.Rejected + | Lwt_utils.Canceled + | Lwt_utils.Timeout + | P2p_connection_pool.Rejected _ + ] as err) -> + lwt_log_info "@[Connection to %a failed:@ %a@]" + Point.pp point pp_print_error err >>= fun () -> + Lwt_unix.sleep (0.5 +. Random.float 2.) >>= fun () -> + connect ~timeout pool point + | Ok _ | Error _ as res -> Lwt.return res + +let connect_all ~timeout pool points = + map_p (connect ~timeout pool) points + +type error += Connect | Write | Read + +let write_all conns msg = + iter_p + (fun conn -> + trace Write @@ P2p_connection_pool.write_sync conn msg) + conns + +let read_all conns = + iter_p + (fun conn -> + trace Read @@ P2p_connection_pool.read conn >>=? fun Ping -> + return ()) + conns + +let rec connect_random pool total rem point n = + Lwt_unix.sleep (0.2 +. Random.float 1.0) >>= fun () -> + (trace Connect @@ connect ~timeout:2. pool point) >>=? fun conn -> + (trace Write @@ P2p_connection_pool.write conn Ping) >>= fun _ -> + (trace Read @@ P2p_connection_pool.read conn) >>=? fun Ping -> + Lwt_unix.sleep (0.2 +. Random.float 1.0) >>= fun () -> + P2p_connection_pool.disconnect conn >>= fun () -> + begin + decr rem ; + if !rem mod total = 0 then + lwt_log_notice "Remaining: %d." (!rem / total) + else + Lwt.return () + end >>= fun () -> + if n > 1 then + connect_random pool total rem point (pred n) + else + return () + +let connect_random_all pool points n = + let total = List.length points in + let rem = ref (n * total) in + iter_p (fun point -> connect_random pool total rem point n) points + +let close_all conns = + Lwt_list.iter_p P2p_connection_pool.disconnect conns + + +let run_net config repeat points addr port = + Lwt_unix.sleep (Random.float 2.0) >>= fun () -> + let sched = P2p_io_scheduler.create ~read_buffer_size:(1 lsl 12) () in + P2p_connection_pool.create + config meta_config msg_config sched >>= fun pool -> + P2p_welcome.run ~backlog:10 pool ~addr port >>= fun welcome -> + connect_all ~timeout:2. pool points >>=? fun conns -> + lwt_log_notice "Bootstrap OK" >>= fun () -> + write_all conns Ping >>=? fun () -> + lwt_log_notice "Sent all messages." >>= fun () -> + read_all conns >>=? fun () -> + lwt_log_notice "Read all messages." >>= fun () -> + close_all conns >>= fun () -> + lwt_log_notice "Begin random connections." >>= fun () -> + connect_random_all pool points repeat >>=? fun () -> + lwt_log_notice "Shutting down" >>= fun () -> + P2p_welcome.shutdown welcome >>= fun () -> + P2p_connection_pool.destroy pool >>= fun () -> + P2p_io_scheduler.shutdown sched >>= fun () -> + lwt_log_notice "Shutdown Ok" >>= fun () -> + return () + +let make_net points repeat n = + let point, points = Utils.select n points in + let proof_of_work_target = Crypto_box.make_target [] in + let identity = Identity.generate proof_of_work_target in + let config = P2p_connection_pool.{ + identity ; + proof_of_work_target ; + trusted_points = points ; + peers_file = "/dev/null" ; + closed_network = true ; + listening_port = Some (snd point) ; + min_connections = List.length points ; + max_connections = List.length points ; + max_incoming_connections = List.length points ; + authentification_timeout = 2. ; + incoming_app_message_queue_size = None ; + incoming_message_queue_size = None ; + outgoing_message_queue_size = None ; + } in + Process.detach + ~prefix:(Format.asprintf "%a " Gid.pp identity.gid) + begin fun () -> + run_net config repeat points (fst point) (snd point) >>= function + | Ok () -> Lwt.return_unit + | Error err -> + lwt_log_error "@[Unexpected error: %d@ %a@]" + (List.length err) + pp_print_error err >>= fun () -> + exit 1 + end + +let addr = ref Ipaddr.V6.localhost +let port = ref (1024 + Random.int 8192) +let clients = ref 10 +let repeat = ref 5 + +let spec = Arg.[ + + "--port", Int (fun p -> port := p), " Listening port of the first peer."; + + "--addr", String (fun p -> addr := Ipaddr.V6.of_string_exn p), + " Listening addr"; + + "--clients", Set_int clients, " Number of concurrent clients." ; + + "--repeat", Set_int repeat, " Number of connections/disconnections." ; + + "-v", Unit (fun () -> Lwt_log_core.(add_rule "p2p.connection-pool" Info)), + " Log up to info msgs" ; + + "-vv", Unit (fun () -> Lwt_log_core.(add_rule "p2p.connection-pool" Debug)), + " Log up to debug msgs"; + + ] + +let main () = + let open Utils in + let anon_fun num_peers = raise (Arg.Bad "No anonymous argument.") in + let usage_msg = "Usage: %s .\nArguments are:" in + Arg.parse spec anon_fun usage_msg ; + let ports = !port -- (!port + !clients - 1) in + let points = List.map (fun port -> !addr, port) ports in + Lwt_list.iter_p (make_net points !repeat) (0 -- (!clients - 1)) + +let () = + Sys.catch_break true ; + try + Logging.init Stderr ; + Lwt_main.run @@ main () + with _ -> () diff --git a/test/test_p2p_io_scheduler.ml b/test/test_p2p_io_scheduler.ml new file mode 100644 index 000000000..e41fca204 --- /dev/null +++ b/test/test_p2p_io_scheduler.ml @@ -0,0 +1,232 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Error_monad +open P2p_types +include Logging.Make (struct let name = "test-p2p-io-scheduler" end) + +exception Error of error list + +let rec listen ?port addr = + let tentative_port = + match port with + | None -> 1024 + Random.int 8192 + | Some port -> port in + let uaddr = Ipaddr_unix.V6.to_inet_addr addr in + let main_socket = Lwt_unix.(socket PF_INET6 SOCK_STREAM 0) in + Lwt_unix.(setsockopt main_socket SO_REUSEADDR true) ; + Lwt.catch begin fun () -> + Lwt_unix.Versioned.bind_2 main_socket + (ADDR_INET (uaddr, tentative_port)) >>= fun () -> + Lwt_unix.listen main_socket 50 ; + Lwt.return (main_socket, tentative_port) + end begin function + | Unix.Unix_error + ((Unix.EADDRINUSE | Unix.EADDRNOTAVAIL), _, _) when port = None -> + listen addr + | exn -> Lwt.fail exn + end + +let accept main_socket = + Lwt_unix.accept main_socket >>= fun (fd, sockaddr) -> + return fd + +let rec accept_n main_socket n = + if n <= 0 then + return [] + else + accept_n main_socket (n-1) >>=? fun acc -> + accept main_socket >>=? fun conn -> + return (conn :: acc) + +let connect addr port = + let fd = Lwt_unix.socket PF_INET6 SOCK_STREAM 0 in + let uaddr = + Lwt_unix.ADDR_INET (Ipaddr_unix.V6.to_inet_addr addr, port) in + Lwt_unix.connect fd uaddr >>= fun () -> + return fd + +let simple_msgs = + [| + MBytes.create (1 lsl 6) ; + MBytes.create (1 lsl 7) ; + MBytes.create (1 lsl 8) ; + MBytes.create (1 lsl 9) ; + MBytes.create (1 lsl 10) ; + MBytes.create (1 lsl 11) ; + MBytes.create (1 lsl 12) ; + MBytes.create (1 lsl 13) ; + MBytes.create (1 lsl 14) ; + MBytes.create (1 lsl 15) ; + MBytes.create (1 lsl 16) ; + |] +let nb_simple_msgs = Array.length simple_msgs + +let receive conn = + let buf = MBytes.create (1 lsl 16) in + let rec loop () = + P2p_io_scheduler.read conn buf >>= function + | Ok _ -> loop () + | Error [P2p_io_scheduler.Connection_closed] -> + Lwt.return () + | Error err -> Lwt.fail (Error err) + in + loop () + +let server + ?(display_client_stat = true) + ?max_download_speed ?read_queue_size ~read_buffer_size + main_socket n = + let sched = + P2p_io_scheduler.create + ?max_download_speed + ?read_queue_size + ~read_buffer_size + () in + Moving_average.on_update begin fun () -> + log_notice "Stat: %a" Stat.pp (P2p_io_scheduler.global_stat sched) ; + if display_client_stat then + P2p_io_scheduler.iter_connection sched + (fun id conn -> + log_notice " client(%d) %a" id Stat.pp (P2p_io_scheduler.stat conn)) ; + end ; + (* Accept and read message until the connection is closed. *) + accept_n main_socket n >>=? fun conns -> + let conns = List.map (P2p_io_scheduler.register sched) conns in + Lwt.join (List.map receive conns) >>= fun () -> + iter_p P2p_io_scheduler.close conns >>=? fun () -> + log_notice "OK %a" Stat.pp (P2p_io_scheduler.global_stat sched) ; + return () + +let max_size ?max_upload_speed () = + match max_upload_speed with + | None -> nb_simple_msgs + | Some max_upload_speed -> + let rec loop n = + if n <= 1 then 1 + else if MBytes.length simple_msgs.(n-1) <= max_upload_speed then n + else loop (n - 1) + in + loop nb_simple_msgs + +let rec send conn nb_simple_msgs = + Lwt_main.yield () >>= fun () -> + let msg = simple_msgs.(Random.int nb_simple_msgs) in + P2p_io_scheduler.write conn msg >>=? fun () -> + send conn nb_simple_msgs + +let client ?max_upload_speed ?write_queue_size addr port time n = + let sched = + P2p_io_scheduler.create + ?max_upload_speed ?write_queue_size ~read_buffer_size:(1 lsl 12) () in + connect addr port >>=? fun conn -> + let conn = P2p_io_scheduler.register sched conn in + let nb_simple_msgs = max_size ?max_upload_speed () in + Lwt.pick [ send conn nb_simple_msgs ; + Lwt_unix.sleep time >>= return ] >>=? fun () -> + P2p_io_scheduler.close conn >>=? fun () -> + let stat = P2p_io_scheduler.stat conn in + lwt_log_notice "Client OK %a" Stat.pp stat >>= fun () -> + return () + +let run + ?display_client_stat + ?max_download_speed ?max_upload_speed + ~read_buffer_size ?read_queue_size ?write_queue_size + addr port time n = + Logging.init Stderr ; + listen ?port addr >>= fun (main_socket, port) -> + let server = + Process.detach ~prefix:"server " begin fun () -> + Process.handle_error begin fun () -> + server + ?display_client_stat ?max_download_speed + ~read_buffer_size ?read_queue_size + main_socket n + end + end in + let client n = + let prefix = Printf.sprintf "client(%d) " n in + Process.detach ~prefix begin fun () -> + Lwt_utils.safe_close main_socket >>= fun () -> + Process.handle_error begin fun () -> + client ?max_upload_speed ?write_queue_size addr port time n + end + end in + Process.wait (server :: List.map client Utils.(1 -- n)) + +let () = Random.self_init () + +let addr = ref Ipaddr.V6.localhost +let port = ref None + +let max_download_speed = ref None +let max_upload_speed = ref None + +let read_buffer_size = ref (1 lsl 14) +let read_queue_size = ref (Some 1) +let write_queue_size = ref (Some 1) + +let delay = ref 60. +let clients = ref 8 + +let display_client_stat = ref None + +let spec = + Arg.[ + + "--port", Int (fun p -> port := Some p), " Listening port"; + + "--addr", String (fun p -> addr := Ipaddr.V6.of_string_exn p), + " Listening addr"; + + "--max-download-speed", Int (fun i -> max_download_speed := Some i), + " Max download speed in B/s (default: unbounded)"; + + "--max-upload-speed", Int (fun i -> max_upload_speed := Some i), + " Max upload speed in B/s (default: unbounded)"; + + "--read-buffer-size", Set_int read_buffer_size, + " Size of the read buffers"; + + "--read-queue-size", Int (fun i -> + read_queue_size := if i <= 0 then None else Some i), + " Size of the read queue (0=unbounded)"; + + "--write-queue-size", Int (fun i -> + write_queue_size := if i <= 0 then None else Some i), + " Size of the write queue (0=unbounded)"; + + "--delay", Set_float delay, " Client execution time."; + "--clients", Set_int clients, " Number of concurrent clients."; + + "--hide-clients-stat", Unit (fun () -> display_client_stat := Some false), + " Hide the client bandwidth statistic." ; + + "--display_clients_stat", Unit (fun () -> display_client_stat := Some true), + " Display the client bandwidth statistic." ; + + ] + +let () = + let anon_fun num_peers = raise (Arg.Bad "No anonymous argument.") in + let usage_msg = "Usage: %s .\nArguments are:" in + Arg.parse spec anon_fun usage_msg + +let () = + Sys.catch_break true ; + Lwt_main.run + (run + ?display_client_stat:!display_client_stat + ?max_download_speed:!max_download_speed + ?max_upload_speed:!max_upload_speed + ~read_buffer_size:!read_buffer_size + ?read_queue_size:!read_queue_size + ?write_queue_size:!write_queue_size + !addr !port !delay !clients)