diff --git a/README.md b/README.md index 433ee3895..55d991134 100644 --- a/README.md +++ b/README.md @@ -61,7 +61,7 @@ Running the node in a sandbox To run a single instance of a Tezos node in sandbox mode: ``` -./tezos-node --sandbox /path/to/a/custom/data/dir --rpc-addr :::8732 +./tezos-node --sandbox --rpc-addr :::8732 ``` This "sandboxed" node will not participate in the P2P network, but will accept @@ -77,20 +77,22 @@ test network. Use the following command to run a node that will accept incoming connections: ``` -./tezos-node +./tezos-node --generate-identity --expected-pow 24. ``` -The node will listen to connections coming in on `0.0.0.0:9732` (and -`[::]:9732`). All used data is stored at `$HOME/.tezos-node/`. For example, -the default configuration file is at `$HOME/.tezos-node/config`. +This will first generate a new node identity and compute the associated stamp +of proof-of-work. Then, the node will listen to connections coming in on +`0.0.0.0:9732` (and`[::]:9732`). All used data is stored at +`$HOME/.tezos-node/`. For example, the default configuration file is +at `$HOME/.tezos-node/config.json`. To run multiple nodes on the same machine, you can duplicate and edit -`$HOME/.tezos-node/config` while making sure they don't share paths to the +`$HOME/.tezos-node/config.json` while making sure they don't share paths to the database or any other data file (cf. options `db.store` ; `db.context` ; -`net.peers` and `protocol.dir`). +`db.protocol`, `net.peers-metadata` and `net.identity`). You could also let Tezos generate a config file by specifying options on the -command line. For instance, if `$dir/config` does not exist, the following +command line. For instance, if `$dir/config.json` does not exist, the following command will generate it and replace the default values with the values from the command line: @@ -102,20 +104,23 @@ The Tezos server has a built-in mechanism to discover peers on the local network (using UDP packets broadcasted on port 7732). If this mechanism is not sufficient, one can provide Tezos with a list of -initial peers, either by editing the option `net.bootstrap.peers` in the -`config` file, or by specifying a command line parameter: +initial peers, either by editing the option `net.bootstrap-peers` in the +`config.json` file, or by specifying a command line parameter: ``` ./tezos-node --base-dir "$dir" --net-addr 127.0.0.1:2023 \ --peer 127.0.0.1:2021 --peer 127.0.0.1:2022 ``` -If `"$dir"/config` exists, the command line options override those read in the -config file. Tezos won't modify the content of an existing `"$dir"/config` -file. +If `"$dir"/config.json` exists, the command line options override those +read in the config file. By default, Tezos won't modify the content of an +existing `"$dir"/config.json` file. But, you may explicit ask the node +to reset or to update the file according to the command line parameters +with the following commands line: ``` -./tezos-node --config-file "$dir"/config +./tezos-node --reset-config --base-dir "$dir" --net-addr 127.0.0.1:9733 +./tezos-node --update-config --base-dir "$dir" --net-addr 127.0.0.1:9734 ``` @@ -129,7 +134,7 @@ Typically, if you are not trying to run a local network and just want to explore the RPC, you would run: ``` -./tezos-node --sandbox /path/to/a/custom/data/dir --rpc-addr :::8732 +./tezos-node --sandbox --rpc-addr :::8732 ``` The RPC interface is self-documented and the `tezos-client` executable is able @@ -151,7 +156,7 @@ You might also want the JSON schema describing the expected input and output of a RPC. For instance: ``` -./tezos-client rpc schema /block/genesis/hash +./tezos-client rpc schema /blocks/genesis/hash ``` Note: you can get the same information, but as a raw JSON object, with a simple @@ -170,4 +175,4 @@ The minimal CLI client Work in progress. -See `./tezos-client -help` for available commands. \ No newline at end of file +See `./tezos-client -help` for available commands. diff --git a/src/Makefile b/src/Makefile index 758de0561..2eea22a93 100644 --- a/src/Makefile +++ b/src/Makefile @@ -168,12 +168,12 @@ UTILS_LIB_INTFS := \ UTILS_LIB_IMPLS := \ utils/base48.ml \ utils/cli_entries.ml \ + utils/error_monad_sig.ml \ + utils/error_monad.ml \ utils/data_encoding_ezjsonm.ml \ utils/time.ml \ utils/hash.ml \ utils/crypto_box.ml \ - utils/error_monad_sig.ml \ - utils/error_monad.ml \ utils/lwt_exit.ml \ utils/logging.ml \ utils/lwt_utils.ml \ diff --git a/src/client/client_aliases.ml b/src/client/client_aliases.ml index 1a80cc78c..b4899d5de 100644 --- a/src/client/client_aliases.ml +++ b/src/client/client_aliases.ml @@ -88,10 +88,10 @@ module Alias = functor (Entity : Entity) -> struct let filename = filename () in if not (Sys.file_exists filename) then return [] else Data_encoding_ezjsonm.read_file filename >>= function - | None -> + | Error _ -> cctxt.Client_commands.error "couldn't to read the %s alias file" Entity.name - | Some json -> + | Ok json -> match Data_encoding.Json.destruct encoding json with | exception _ -> (* TODO print_error *) cctxt.Client_commands.error @@ -132,8 +132,8 @@ module Alias = functor (Entity : Entity) -> struct let filename = filename () in let json = Data_encoding.Json.construct encoding list in Data_encoding_ezjsonm.write_file filename json >>= function - | false -> fail (Failure "Json.write_file") - | true -> return ()) + | Error _ -> fail (Failure "Json.write_file") + | Ok () -> return ()) (fun exn -> cctxt.Client_commands.error "could not write the %s alias file: %s." diff --git a/src/client/embedded/bootstrap/client_proto_nonces.ml b/src/client/embedded/bootstrap/client_proto_nonces.ml index a9acf47f3..26e8af42a 100644 --- a/src/client/embedded/bootstrap/client_proto_nonces.ml +++ b/src/client/embedded/bootstrap/client_proto_nonces.ml @@ -29,8 +29,9 @@ let load cctxt = Lwt.return [] else Data_encoding_ezjsonm.read_file filename >>= function - | None -> cctxt.Client_commands.error "couldn't to read the nonces file" - | Some json -> + | Error _ -> + cctxt.Client_commands.error "couldn't to read the nonces file" + | Ok json -> match Data_encoding.Json.destruct encoding json with | exception _ -> (* TODO print_error *) cctxt.Client_commands.error "didn't understand the nonces file" @@ -51,8 +52,8 @@ let save cctxt list = let filename = filename () in let json = Data_encoding.Json.construct encoding list in Data_encoding_ezjsonm.write_file filename json >>= function - | false -> failwith "Json.write_file" - | true -> return ()) + | Error _ -> failwith "Json.write_file" + | Ok () -> return ()) (fun exn -> cctxt.Client_commands.error "could not write the nonces file: %s." (Printexc.to_string exn)) diff --git a/src/client/embedded/bootstrap/mining/client_mining_endorsement.ml b/src/client/embedded/bootstrap/mining/client_mining_endorsement.ml index 0d268a2c4..a9d005cf7 100644 --- a/src/client/embedded/bootstrap/mining/client_mining_endorsement.ml +++ b/src/client/embedded/bootstrap/mining/client_mining_endorsement.ml @@ -51,9 +51,9 @@ end = struct let filename = filename () in if not (Sys.file_exists filename) then return LevelMap.empty else Data_encoding_ezjsonm.read_file filename >>= function - | None -> + | Error _ -> cctxt.Client_commands.error "couldn't to read the endorsement file" - | Some json -> + | Ok json -> match Data_encoding.Json.destruct encoding json with | exception _ -> (* TODO print_error *) cctxt.Client_commands.error "didn't understand the endorsement file" @@ -69,8 +69,8 @@ end = struct let filename = filename () in let json = Data_encoding.Json.construct encoding map in Data_encoding_ezjsonm.write_file filename json >>= function - | false -> failwith "Json.write_file" - | true -> return ()) + | Error _ -> failwith "Json.write_file" + | Ok () -> return ()) (fun exn -> cctxt.Client_commands.error "could not write the endorsement file: %s." (Printexc.to_string exn)) diff --git a/src/client/embedded/bootstrap/mining/client_mining_forge.ml b/src/client/embedded/bootstrap/mining/client_mining_forge.ml index 3ea587027..e21ee087d 100644 --- a/src/client/embedded/bootstrap/mining/client_mining_forge.ml +++ b/src/client/embedded/bootstrap/mining/client_mining_forge.ml @@ -171,9 +171,9 @@ end = struct let filename = filename () in if not (Sys.file_exists filename) then return LevelMap.empty else Data_encoding_ezjsonm.read_file filename >>= function - | None -> + | Error _ -> failwith "couldn't to read the block file" - | Some json -> + | Ok json -> match Data_encoding.Json.destruct encoding json with | exception _ -> (* TODO print_error *) failwith "didn't understand the block file" @@ -189,8 +189,8 @@ end = struct let filename = filename () in let json = Data_encoding.Json.construct encoding map in Data_encoding_ezjsonm.write_file filename json >>= function - | false -> failwith "Json.write_file" - | true -> return ()) + | Error _ -> failwith "Json.write_file" + | Ok () -> return ()) (fun exn -> Error_monad.failwith "could not write the block file: %s." diff --git a/src/minutils/utils.ml b/src/minutils/utils.ml index bf6f36792..db569c68c 100644 --- a/src/minutils/utils.ml +++ b/src/minutils/utils.ml @@ -9,13 +9,16 @@ module StringMap = Map.Make (String) -let split delim ?(limit = max_int) path = +let split delim ?(dup = true) ?(limit = max_int) path = let l = String.length path in let rec do_slashes acc limit i = if i >= l then List.rev acc else if String.get path i = delim then - do_slashes acc limit (i + 1) + if dup then + do_slashes acc limit (i + 1) + else + do_split acc limit (i + 1) else do_split acc limit i and do_split acc limit i = @@ -55,8 +58,8 @@ let iter_option ~f = function | None -> () | Some x -> f x -let unopt x = function - | None -> x +let unopt ~default = function + | None -> default | Some x -> x let unopt_map ~f ~default = function @@ -85,8 +88,16 @@ 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) - (split ' ' description) + (Format.pp_print_list ~pp_sep:Format.pp_print_newline + (fun ppf line -> + Format.pp_print_list ~pp_sep:Format.pp_print_space + (fun ppf w -> + (* replace   by real spaces... *) + Format.fprintf ppf "%s@ " + (Stringext.replace_all ~pattern:"\xC2\xA0" ~with_:" " w)) + ppf + (split ' ' line))) + (split ~dup:false '\n' description) let rec remove_elem_from_list nb = function | [] -> [] @@ -128,6 +139,8 @@ let rec (--) i j = if j < i then acc else loop (j :: acc) (pred j) in loop [] j +let rec repeat n x = if n <= 0 then [] else x :: repeat (pred n) x + let take_n_unsorted n l = let rec loop acc n = function | [] -> l diff --git a/src/minutils/utils.mli b/src/minutils/utils.mli index 0b3ec0f00..c22b03aa8 100644 --- a/src/minutils/utils.mli +++ b/src/minutils/utils.mli @@ -16,12 +16,12 @@ val split_path: string -> string list (** Splits a string on a delimier character, grouping multiple delimiters, and ignoring delimiters at the beginning and end of string, if [limit] is passed, stops after [limit] split(s). *) -val split: char -> ?limit: int -> string -> string list +val split: char -> ?dup:bool -> ?limit: int -> string -> string list 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: default:'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 @@ -51,6 +51,8 @@ val (<<) : ('b -> 'c) -> ('a -> 'b) -> 'a -> 'c (** Sequence: [i--j] is the sequence [i;i+1;...;j-1;j] *) val (--) : int -> int -> int list +val repeat: int -> 'a -> 'a 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 diff --git a/src/node/net/p2p.ml b/src/node/net/p2p.ml index 87d9352b3..94be084e8 100644 --- a/src/node/net/p2p.ml +++ b/src/node/net/p2p.ml @@ -224,7 +224,7 @@ end module Fake = struct - let id = Identity.generate Crypto_box.default_target + let id = Identity.generate (Crypto_box.make_target 0.) let empty_stat = { Stat.total_sent = 0 ; total_recv = 0 ; @@ -261,9 +261,8 @@ type ('msg, 'meta) t = { } type ('msg, 'meta) net = ('msg, 'meta) t -let bootstrap ~config ~limits meta_cfg msg_cfg = +let create ~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 ; diff --git a/src/node/net/p2p.mli b/src/node/net/p2p.mli index 06b3dc93e..b74f36fe1 100644 --- a/src/node/net/p2p.mli +++ b/src/node/net/p2p.mli @@ -124,7 +124,7 @@ type ('msg, 'meta) net = ('msg, 'meta) t val faked_network : ('msg, 'meta) net (** Main network initialisation function *) -val bootstrap : +val create : config:config -> limits:limits -> 'meta meta_config -> 'msg message_config -> ('msg, 'meta) net Lwt.t diff --git a/src/node/net/p2p_connection_pool.ml b/src/node/net/p2p_connection_pool.ml index dc437985a..53826a029 100644 --- a/src/node/net/p2p_connection_pool.ml +++ b/src/node/net/p2p_connection_pool.ml @@ -634,16 +634,16 @@ let create config meta_config message_config io_sched = 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 + Gid_info.File.load config.peers_file meta_config.encoding >>= function + | Ok gids -> + List.iter + (fun gi -> Gid.Table.add pool.known_gids (Gid_info.gid gi) gi) + gids ; + Lwt.return pool + | Error err -> + log_error "@[Failed to parsed peers file:@ %a@]" + pp_print_error err ; + Lwt.return pool let destroy pool = Point.Table.fold (fun _point pi acc -> diff --git a/src/node/net/p2p_connection_pool_types.ml b/src/node/net/p2p_connection_pool_types.ml index 2e2bcd5f9..dabbc5a96 100644 --- a/src/node/net/p2p_connection_pool_types.ml +++ b/src/node/net/p2p_connection_pool_types.ml @@ -449,9 +449,11 @@ module Gid_info = 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 [] + if path <> "/dev/null" && Sys.file_exists path then + Data_encoding_ezjsonm.read_file path >>=? fun json -> + return (Data_encoding.Json.destruct enc json) + else + return [] let save path metadata_encoding peers = let open Data_encoding in diff --git a/src/node/net/p2p_connection_pool_types.mli b/src/node/net/p2p_connection_pool_types.mli index 8c2c3a584..be56dcd56 100644 --- a/src/node/net/p2p_connection_pool_types.mli +++ b/src/node/net/p2p_connection_pool_types.mli @@ -256,10 +256,10 @@ module Gid_info : sig module File : sig val load : string -> 'meta Data_encoding.t -> - ('conn, 'meta) gid_info list Lwt.t + ('conn, 'meta) gid_info list tzresult Lwt.t val save : string -> 'meta Data_encoding.t -> - ('conn, 'meta) gid_info list -> bool Lwt.t + ('conn, 'meta) gid_info list -> unit tzresult Lwt.t end end diff --git a/src/node/net/p2p_io_scheduler.ml b/src/node/net/p2p_io_scheduler.ml index 0a0acb087..14c00b357 100644 --- a/src/node/net/p2p_io_scheduler.ml +++ b/src/node/net/p2p_io_scheduler.ml @@ -147,7 +147,7 @@ module Scheduler(IO : IO) = struct canceler = Canceler.create () ; worker = Lwt.return_unit ; counter = Moving_average.create ~init:0 ~alpha ; - max_speed ; quota = unopt 0 max_speed ; + max_speed ; quota = unopt ~default:0 max_speed ; quota_updated = Lwt_condition.create () ; readys = Lwt_condition.create () ; readys_high = Queue.create () ; @@ -358,9 +358,9 @@ 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 + let pos = unopt ~default:0 pos in assert (0 <= pos && pos < maxlen) ; - let len = unopt (maxlen - pos) len in + let len = unopt ~default:(maxlen - pos) len in assert (len <= maxlen - pos) ; match msg with | Ok msg -> @@ -400,8 +400,8 @@ let read conn ?pos ?len buf = 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 + let pos = unopt ~default:0 pos in + let len = unopt ~default:(maxlen - pos) len in assert (0 <= pos && pos < maxlen) ; assert (len <= maxlen - pos) ; let rec loop pos len = diff --git a/src/node/net/p2p_maintenance.ml b/src/node/net/p2p_maintenance.ml index 2cae195dc..1ff34c9f0 100644 --- a/src/node/net/p2p_maintenance.ml +++ b/src/node/net/p2p_maintenance.ml @@ -79,6 +79,7 @@ let rec try_to_contact let contactable = connectable st start_time max_to_contact in if contactable = [] then + Lwt_unix.yield () >>= fun () -> Lwt.return_false else List.fold_left @@ -111,11 +112,11 @@ let rec maintain st = 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 () -> + lwt_log_notice "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 + try_to_contact st min_to_contact max_to_contact >>= fun success -> + if success then begin maintain st end else begin (* not enough contacts, ask the pals of our pals, diff --git a/src/node/net/p2p_types.ml b/src/node/net/p2p_types.ml index 5ed7ded49..f8b8690fa 100644 --- a/src/node/net/p2p_types.ml +++ b/src/node/net/p2p_types.ml @@ -193,12 +193,55 @@ module Identity = struct (req "secret_key" Crypto_box.secret_key_encoding) (req "proof_of_work_stamp" Crypto_box.nonce_encoding)) - let generate target = + let generate ?max 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 + Crypto_box.generate_proof_of_work ?max public_key target in { gid ; public_key ; secret_key ; proof_of_work_stamp } + let animation = [| + "|.....|" ; + "|o....|" ; + "|oo...|" ; + "|ooo..|" ; + "|.ooo.|" ; + "|..ooo|" ; + "|...oo|" ; + "|....o|" ; + "|.....|" ; + "|.....|" ; + "|.....|" ; + "|.....|" ; + |] + + let init = String.make (String.length animation.(0)) '\ ' + let clean = String.make (String.length animation.(0)) '\b' + let animation = Array.map (fun x -> clean ^ x) animation + let animation_size = Array.length animation + let duration = 1200 / animation_size + + let generate_with_animation ppf target = + Format.fprintf ppf "%s%!" init ; + let count = ref 10000 in + let rec loop n = + let start = Mtime.counter () in + Format.fprintf ppf "%s%!" animation.(n mod animation_size); + try generate ~max:!count target + with Not_found -> + let time = Mtime.to_ms (Mtime.count start) in + count := + if time <= 0. then + !count * 10 + else + !count * duration / int_of_float time ; + loop (n+1) + in + let id = loop 0 in + Format.fprintf ppf "%s%s\n%!" clean init ; + id + + let generate target = generate target + end module Connection_info = struct diff --git a/src/node/net/p2p_types.mli b/src/node/net/p2p_types.mli index f85ed323a..a09283a69 100644 --- a/src/node/net/p2p_types.mli +++ b/src/node/net/p2p_types.mli @@ -94,6 +94,12 @@ module Identity : sig 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]. *) + + val generate_with_animation : + Format.formatter -> Crypto_box.target -> t + (** [generate_with_animation ppf target] is a freshly minted identity + whose proof of work stamp difficulty is at least equal to [target]. *) + end diff --git a/src/node/shell/node.ml b/src/node/shell/node.ml index e54e5d678..6adccc162 100644 --- a/src/node/shell/node.ml +++ b/src/node/shell/node.ml @@ -211,10 +211,21 @@ let init_p2p net_params = Lwt.return Tezos_p2p.faked_network | Some (config, limits) -> lwt_log_notice "bootstraping network..." >>= fun () -> - Tezos_p2p.bootstrap config limits + Tezos_p2p.create config limits >>= fun p2p -> + Lwt.async (fun () -> Tezos_p2p.maintain p2p) ; + Lwt.return p2p -let create - ~genesis ~store_root ~context_root ?test_protocol ?patch_context net_params = +type config = { + genesis: Store.genesis ; + store_root: string ; + context_root: string ; + test_protocol: Protocol_hash.t option ; + patch_context: (Context.t -> Context.t Lwt.t) option ; + p2p: (P2p.config * P2p.limits) option ; +} + +let create { genesis ; store_root ; context_root ; + test_protocol ; patch_context ; p2p = net_params } = lwt_debug "-> Node.create" >>= fun () -> init_p2p net_params >>= fun p2p -> lwt_log_info "reading state..." >>= fun () -> @@ -234,11 +245,12 @@ let create end >>=? fun global_net -> Validator.activate validator global_net >>= fun global_validator -> let cleanup () = + Tezos_p2p.shutdown p2p >>= fun () -> Lwt.join [ Validator.shutdown validator ; Discoverer.shutdown discoverer ] >>= fun () -> State.store state in - + let canceler = Lwt_utils.Canceler.create () in lwt_log_info "starting worker..." >>= fun () -> let worker = let handle_msg peer msg = @@ -249,22 +261,23 @@ let create Lwt.return_unit in let rec worker_loop () = - Tezos_p2p.recv p2p >>= fun (peer, msg) -> + Lwt_utils.protect ~canceler begin fun () -> + Tezos_p2p.recv p2p >>= return + end >>=? fun (peer, msg) -> handle_msg peer msg >>= fun () -> worker_loop () in - Lwt.catch - worker_loop - (function - | Queue.Empty -> cleanup () - | exn -> - lwt_log_error "unexpected exception in worker\n%s" - (Printexc.to_string exn) >>= fun () -> - Tezos_p2p.shutdown p2p >>= fun () -> - cleanup ()) + worker_loop () >>= function + | Error [Lwt_utils.Canceled] | Ok () -> + cleanup () + | Error err -> + lwt_log_error + "@[Unexpected error in worker@ %a@]" + pp_print_error err >>= fun () -> + cleanup () in let shutdown () = lwt_log_info "stopping worker..." >>= fun () -> - Tezos_p2p.shutdown p2p >>= fun () -> + Lwt_utils.Canceler.cancel canceler >>= fun () -> worker >>= fun () -> lwt_log_info "stopped" in diff --git a/src/node/shell/node.mli b/src/node/shell/node.mli index 997b71ca9..c21398043 100644 --- a/src/node/shell/node.mli +++ b/src/node/shell/node.mli @@ -9,14 +9,16 @@ type t -val create: - genesis:Store.genesis -> - store_root:string -> - context_root:string -> - ?test_protocol:Protocol_hash.t -> - ?patch_context:(Context.t -> Context.t Lwt.t) -> - (P2p.config * P2p.limits) option -> - t tzresult Lwt.t +type config = { + genesis: Store.genesis ; + store_root: string ; + context_root: string ; + test_protocol: Protocol_hash.t option ; + patch_context: (Context.t -> Context.t Lwt.t) option ; + p2p: (P2p.config * P2p.limits) option ; +} + +val create: config -> t tzresult Lwt.t module RPC : sig diff --git a/src/node/shell/node_rpc.ml b/src/node/shell/node_rpc.ml index d555bcbdd..6082a6a5a 100644 --- a/src/node/shell/node_rpc.ml +++ b/src/node/shell/node_rpc.ml @@ -394,9 +394,9 @@ let build_rpc_directory node = let dir = let implementation (net_id, pred, time, fitness, operations, header) = Node.RPC.block_info node (`Head 0) >>= fun bi -> - let timestamp = Utils.unopt (Time.now ()) time in - let net_id = Utils.unopt bi.net net_id in - let predecessor = Utils.unopt bi.hash pred in + let timestamp = Utils.unopt ~default:(Time.now ()) time in + let net_id = Utils.unopt ~default:bi.net net_id in + let predecessor = Utils.unopt ~default:bi.hash pred in let res = Store.Block.to_bytes { shell = { net_id ; predecessor ; timestamp ; fitness ; operations } ; diff --git a/src/node/shell/node_rpc_services.ml b/src/node/shell/node_rpc_services.ml index ba6be7dcb..b64dd2540 100644 --- a/src/node/shell/node_rpc_services.ml +++ b/src/node/shell/node_rpc_services.ml @@ -524,7 +524,7 @@ let inject_block = (fun (block, blocking, force) -> (block, Some blocking, force)) (fun (block, blocking, force) -> - (block, Utils.unopt true blocking, force)) + (block, Utils.unopt ~default:true blocking, force)) (obj3 (req "data" bytes) (opt "blocking" @@ -555,25 +555,23 @@ let inject_operation = RPCs ubder /blocks/prevalidation for more details on the \ prevalidation context." ~input: - (conv - (fun (block, blocking, force) -> (block, Some blocking, force)) - (fun (block, blocking, force) -> (block, unopt true blocking, force)) - (obj3 - (req "signedOperationContents" - (describe ~title: "Tezos signed operation (hex encoded)" - bytes)) - (opt "blocking" - (describe - ~description: - "Should the RPC wait for the operation to be \ - (pre-)validated before to answer. (default: true)" - bool)) - (opt "force" - (describe - ~description: - "Should we inject operation that are \"branch_refused\" \ - or \"branch_delayed\". (default: false)" - bool)))) + (obj3 + (req "signedOperationContents" + (describe ~title: "Tezos signed operation (hex encoded)" + bytes)) + (dft "blocking" + (describe + ~description: + "Should the RPC wait for the operation to be \ + (pre-)validated before to answer. (default: true)" + bool) + true) + (opt "force" + (describe + ~description: + "Should we inject operation that are \"branch_refused\" \ + or \"branch_delayed\". (default: false)" + bool))) ~output: (Error.wrap @@ describe @@ -582,21 +580,6 @@ let inject_operation = RPC.Path.(root / "inject_operation") let inject_protocol = - let proto = - (list - (obj3 - (req "name" - (describe ~title:"OCaml module name" - string)) - (opt "interface" - (describe - ~description:"Content of the .mli file" - string)) - (req "implementation" - (describe - ~description:"Content of the .ml file" - string)))) - in let proto_of_rpc = List.map (fun (name, interface, implementation) -> { Tezos_compiler.Protocol.name; interface; implementation }) @@ -605,28 +588,44 @@ let inject_protocol = List.map (fun { Tezos_compiler.Protocol.name; interface; implementation } -> (name, interface, implementation)) in + let proto = + conv + rpc_of_proto + proto_of_rpc + (list + (obj3 + (req "name" + (describe ~title:"OCaml module name" + string)) + (opt "interface" + (describe + ~description:"Content of the .mli file" + string)) + (req "implementation" + (describe + ~description:"Content of the .ml file" + string)))) + in RPC.service ~description: "Inject a protocol in node. Returns the ID of the protocol." ~input: - (conv - (fun (proto, blocking, force) -> (rpc_of_proto proto, Some blocking, force)) - (fun (proto, blocking, force) -> (proto_of_rpc proto, unopt true blocking, force)) - (obj3 - (req "protocol" - (describe ~title: "Tezos protocol" - proto)) - (opt "blocking" - (describe - ~description: - "Should the RPC wait for the protocol to be \ - validated before to answer. (default: true)" - bool)) - (opt "force" - (describe - ~description: - "Should we inject protocol that is invalid. (default: false)" - bool)))) + (obj3 + (req "protocol" + (describe ~title: "Tezos protocol" + proto)) + (dft "blocking" + (describe + ~description: + "Should the RPC wait for the protocol to be \ + validated before to answer. (default: true)" + bool) + true) + (opt "force" + (describe + ~description: + "Should we inject protocol that is invalid. (default: false)" + bool))) ~output: (Error.wrap @@ describe diff --git a/src/node/shell/state.ml b/src/node/shell/state.ml index 2a11aa2a2..584dde856 100644 --- a/src/node/shell/state.ml +++ b/src/node/shell/state.ml @@ -699,7 +699,8 @@ module Valid_block = struct (* TODO check coherency: test_protocol. *) Lwt.return res | None -> - let test_protocol = Utils.unopt genesis.protocol test_protocol in + let test_protocol = + Utils.unopt ~default:genesis.protocol test_protocol in Context.create_genesis_context vstate.index genesis test_protocol >>= fun _context -> Block.db_store vstate.block_db genesis.block { diff --git a/src/node/shell/tezos_p2p.ml b/src/node/shell/tezos_p2p.ml index 0b4ef48d2..26ffe1d3a 100644 --- a/src/node/shell/tezos_p2p.ml +++ b/src/node/shell/tezos_p2p.ml @@ -106,8 +106,8 @@ and msg_cfg : _ P2p.message_config = { type net = (Message.t, Metadata.t) P2p.net -let bootstrap ~config ~limits = - P2p.bootstrap ~config ~limits meta_cfg msg_cfg +let create ~config ~limits = + P2p.create ~config ~limits meta_cfg msg_cfg let broadcast = P2p.broadcast let try_send = P2p.try_send diff --git a/src/node/shell/tezos_p2p.mli b/src/node/shell/tezos_p2p.mli index db1344baa..0f1111e40 100644 --- a/src/node/shell/tezos_p2p.mli +++ b/src/node/shell/tezos_p2p.mli @@ -8,7 +8,7 @@ type net val faked_network : net (** Main network initialisation function *) -val bootstrap : config:config -> limits:limits -> net Lwt.t +val create : config:config -> limits:limits -> net Lwt.t (** A maintenance operation : try and reach the ideal number of peers *) val maintain : net -> unit Lwt.t diff --git a/src/node_main.ml b/src/node_main.ml index 84cfdb75e..8fd695584 100644 --- a/src/node_main.ml +++ b/src/node_main.ml @@ -9,9 +9,18 @@ module V6 = Ipaddr.V6 +open Hash open Error_monad open Logging.Node.Main +let (//) = Filename.concat + +let home = + try Sys.getenv "HOME" + with Not_found -> "/root" + +let default_base_dir = home // ".tezos-node" + let genesis_block = Block_hash.of_b48check "grHGHkVfgJb5gPaRd5AtQsa65g9GyLcXgQsHbSnQ5SD5DEp2ctqck" @@ -33,357 +42,557 @@ let genesis = { protocol = genesis_protocol ; } -let (//) = Filename.concat +module Sockaddr = struct -let home = - try Sys.getenv "HOME" - with Not_found -> "/root" + type t = V6.t * int -let default_base_dir = home // ".tezos-node" + let of_string str = + match String.rindex str ':' with + | exception Not_found -> `Error "not a sockaddr" + | pos -> + let len = String.length str in + 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" + | V4 ipv4, port -> `Ok (Ipaddr.v6_of_v4 ipv4, port) + | V6 ipv6, port -> `Ok (ipv6, port) -type cfg = { - (* cli *) - base_dir : string ; - sandbox : string option ; - sandbox_param : string option ; + let of_string_exn str = + match of_string str with + | `Ok saddr -> saddr + | `Error msg -> invalid_arg msg - (* db *) + let pp fmt (ip, port) = Format.fprintf fmt "%a:%d" V6.pp_hum ip port + let to_string saddr = Format.asprintf "%a" pp saddr + + let encoding = + Data_encoding.conv to_string of_string_exn Data_encoding.string + + let converter : t Cmdliner.Arg.converter = of_string, pp + +end + +module Cfg_file = struct + + open Data_encoding + + type t = { + db : db ; + net : net ; + rpc : rpc ; + log : log ; + } + + and db = { store : string ; context : string ; protocol : string ; - - (* net *) - min_connections : int ; - max_connections : int ; - expected_connections : int ; - net_addr : V6.t ; - net_port : int ; - (* local_discovery : (string * int) option ; *) - peers : (V6.t * int) list ; - peers_cache : string ; - closed : bool ; - - (* rpc *) - rpc_addr : (V6.t * int) option ; - cors_origins : string list ; - cors_headers : string list ; - rpc_crt : string option ; - rpc_key : string option ; - - (* log *) - log_output : [`Stderr | `File of string | `Syslog | `Null] ; - log_level : Lwt_log.level option ; } -let default_cfg_of_base_dir base_dir = { - (* cli *) - base_dir ; - sandbox = None ; - sandbox_param = None ; + and net = { + identity : string ; + expected_pow : float ; + bootstrap_peers : Sockaddr.t list ; + peers_metadata : string ; + listen_addr : Sockaddr.t option ; + closed : bool ; + limits : P2p.limits ; + } - (* db *) - store = base_dir // "store" ; - context = base_dir // "context" ; - protocol = base_dir // "protocol" ; + and rpc = { + listen_addr : Sockaddr.t option ; + cors_origins : string list ; + cors_headers : string list ; + tls : tls option ; + } - (* net *) - min_connections = 4 ; - max_connections = 400 ; - expected_connections = 20 ; - net_addr = V6.unspecified ; - net_port = 9732 ; - (* local_discovery = None ; *) - peers = [] ; - closed = false ; - peers_cache = base_dir // "peers_cache" ; + and tls = { + cert : string ; + key : string ; + } - (* rpc *) - rpc_addr = None ; - cors_origins = [] ; - cors_headers = ["content-type"] ; - rpc_crt = None ; - rpc_key = None ; + and log = { + output : Logging.kind ; + default_level : Logging.level ; + rules : string option ; + template : Logging.template ; + } - (* log *) - log_output = `Stderr ; - log_level = None ; -} + let default_net_limits : P2p.limits = { + authentification_timeout = 5. ; + min_connections = 50 ; + expected_connections = 100 ; + max_connections = 200 ; + backlog = 20 ; + max_incoming_connections = 20 ; + max_download_speed = None ; + max_upload_speed = None ; + read_buffer_size = 1 lsl 14 ; + read_queue_size = None ; + write_queue_size = None ; + incoming_app_message_queue_size = None ; + incoming_message_queue_size = None ; + outgoing_message_queue_size = None ; + } -let default_cfg = default_cfg_of_base_dir default_base_dir + let default_net base_dir = { + identity = base_dir // "identity.json" ; + expected_pow = 24. ; + bootstrap_peers = [] ; + peers_metadata = base_dir // "peers.json" ; + listen_addr = Some (V6.unspecified, 8732) ; + closed = false ; + limits = default_net_limits ; + } -let log_of_string s = match Utils.split ':' ~limit:2 s with - | ["stderr"] -> `Stderr - | ["file"; fn] -> `File fn - | ["syslog"] -> `Syslog - | ["null"] -> `Null - | _ -> invalid_arg "log_of_string" + let default_rpc = { + listen_addr = None ; + cors_origins = [] ; + cors_headers = [] ; + tls = None ; + } -let string_of_log = function - | `Stderr -> "stderr" - | `File fn -> "file:" ^ fn - | `Syslog -> "syslog" - | `Null -> "null" + let default_log = { + output = Stderr ; + default_level = Notice ; + rules = None ; + template = Logging.default_template ; + } -let sockaddr_of_string str = - match String.rindex str ':' with - | exception Not_found -> `Error "not a sockaddr" - | pos -> - let len = String.length str in - 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" - | V4 ipv4, port -> `Ok (Ipaddr.v6_of_v4 ipv4, port) - | V6 ipv6, port -> `Ok (ipv6, port) + let default_db base_dir = { + store = base_dir // "store" ; + context = base_dir // "context" ; + protocol = base_dir // "protocol" ; + } -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" 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 + let default_config base_dir = { + db = default_db base_dir ; + net = default_net base_dir ; + rpc = default_rpc ; + log = default_log ; + } let db = - obj3 - (opt "store" string) - (opt "context" string) - (opt "protocol" string) + let default = default_db default_base_dir in + conv + (fun { store ; context ; protocol } -> + (store, context, protocol)) + (fun (store, context, protocol) -> + { store ; context ; protocol }) + (obj3 + (dft "store" string default.store) + (dft "context" string default.context) + (dft "protocol" string default.protocol)) + + let limit : P2p.limits Data_encoding.t = + conv + (fun { P2p.authentification_timeout ; + min_connections ; expected_connections ; max_connections ; + 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 } -> + ( ( authentification_timeout, min_connections, expected_connections, + max_connections, 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 ))) + (fun ( ( authentification_timeout, min_connections, expected_connections, + max_connections, 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 ) ) -> + { authentification_timeout ; min_connections ; expected_connections ; + max_connections ; 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 }) + (merge_objs + (obj8 + (dft "authentification_timeout" + float default_net_limits.authentification_timeout) + (dft "min_connections" int31 + default_net_limits.min_connections) + (dft "expected_connections" int31 + default_net_limits.expected_connections) + (dft "max_connections" int31 + default_net_limits.max_connections) + (dft "backlog" int31 + default_net_limits.backlog) + (dft "max_incoming_connections" int31 + default_net_limits.max_incoming_connections) + (opt "max_download_speed" int31) + (opt "max_upload_speed" int31)) + (obj6 + (dft "read_buffer_size" int31 + default_net_limits.read_buffer_size) + (opt "read_queue_size" int31) + (opt "write_queue_size" int31) + (opt "incoming_app_message_queue_size" int31) + (opt "incoming_message_queue_size" int31) + (opt "outgoing_message_queue_size" int31))) let net = - obj7 - (opt "min-connections" uint16) - (opt "max-connections" uint16) - (opt "expected-connections" uint16) - (opt "addr" string) - (* (opt "local-discovery" string) *) - (opt "peers" (list string)) - (dft "closed" bool false) - (opt "peers-cache" string) + let default = default_net default_base_dir in + conv + (fun { identity ; expected_pow ; bootstrap_peers ; peers_metadata ; + listen_addr ; closed ; limits } -> + ( identity, expected_pow, bootstrap_peers, peers_metadata, + listen_addr, closed, limits )) + (fun ( identity, expected_pow, bootstrap_peers, peers_metadata, + listen_addr, closed, limits ) -> + { identity ; expected_pow ; bootstrap_peers ; peers_metadata ; + listen_addr ; closed ; limits }) + (obj7 + (dft "identity" string default.identity) + (dft "expected-proof-or-work" float default.expected_pow) + (dft "bootstrap_peers" + (list Sockaddr.encoding) default.bootstrap_peers) + (dft "peers-metadata" string default.peers_metadata) + (opt "listen-addr" Sockaddr.encoding) + (dft "closed" bool false) + (dft "limits" limit default_net_limits)) - let rpc = - obj3 - (opt "addr" string) - (dft "cors-origin" (list string) []) - (dft "cors-header" (list string) []) + let rpc : rpc Data_encoding.t = + conv + (fun { cors_origins ; cors_headers ; listen_addr ; tls } -> + let cert, key = + match tls with + | None -> None, None + | Some { cert ; key } -> Some cert, Some key in + (listen_addr, cors_origins, cors_headers, cert, key )) + (fun (listen_addr, cors_origins, cors_headers, cert, key ) -> + let tls = + match cert, key with + | None, _ | _, None -> None + | Some cert, Some key -> Some { cert ; key } in + { listen_addr ; cors_origins ; cors_headers ; tls }) + (obj5 + (opt "listen-addr" Sockaddr.encoding) + (dft "cors-origin" (list string) default_rpc.cors_origins) + (dft "cors-headers" (list string) default_rpc.cors_headers) + (opt "crt" string) + (opt "key" string)) let log = - obj1 - (opt "output" string) - - let t = conv - (fun { 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 } -> - 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), - (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), - (rpc_addr, cors_origins, cors_headers), - log_output) -> - let open Utils in - let store = unopt default_cfg.store store in - let context = unopt default_cfg.context context in - let protocol = unopt default_cfg.protocol protocol in - let net_addr = map_option sockaddr_of_string_exn net_addr in - let net_addr, net_port = unopt (default_cfg.net_addr, default_cfg.net_port) net_addr in - let rpc_addr = map_option sockaddr_of_string_exn rpc_addr in - let peers = unopt [] peers in - let peers = ListLabels.map peers ~f:sockaddr_of_string_exn in - let peers_cache = unopt default_cfg.peers_cache peers_cache in - let log_output = unopt default_cfg.log_output (map_option log_of_string log_output) in - 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 ; - } - ) + (fun {output ; default_level ; rules ; template } -> + (output, default_level, rules, template)) + (fun (output, default_level, rules, template) -> + { output ; default_level ; rules ; template }) (obj4 - (req "db" db) + (dft "output" Logging.kind_encoding default_log.output) + (dft "level" Logging.level_encoding default_log.default_level) + (opt "rules" string) + (dft "template" string default_log.template)) + + let encoding = + conv + (fun { db ; rpc ; net ; log } -> (db, rpc, net, log)) + (fun (db, rpc, net, log) -> { db ; rpc ; net ; log }) + (obj4 + (dft "db" db (default_db default_base_dir)) + (dft "rpc" rpc default_rpc) (req "net" net) - (req "rpc" rpc) - (req "log" log)) + (dft "log" log default_log)) let read fp = - Data_encoding_ezjsonm.read_file fp >|= function - | None -> None - | Some json -> Some (Data_encoding.Json.destruct t json) + Data_encoding_ezjsonm.read_file fp >>=? fun json -> + try return (Data_encoding.Json.destruct encoding json) + with exn -> fail (Exn exn) + + let write fp cfg = + Data_encoding_ezjsonm.write_file fp + (Data_encoding.Json.construct encoding cfg) - let from_json json = Data_encoding.Json.destruct t json - let write out cfg = - Utils.write_file ~bin:false out - (Data_encoding.Json.construct t cfg |> - Data_encoding_ezjsonm.to_string) end module Cmdline = struct - open Cmdliner - (* custom converters *) - let sockaddr_converter = sockaddr_of_string, pp_sockaddr + type t = { + sandbox : string option option ; + verbosity : Logging.level option ; + generate_identity : bool ; + write_cfg : 'a 'b 'c 'd. (string * (string -> 'a, 'b, 'c, 'a) format4) option ; + } + + open Cmdliner (* cli args *) let misc_sect = "MISC" + let base_dir = - let doc = "The directory where the Tezos node will store all its data." in - Arg.(value & opt (some string) None & info ~docs:"CONFIG" ~doc ~docv:"DIR" ["base-dir"]) + let doc = + "The directory where the Tezos node will store all its data." in + Arg.(value & opt (some string) None & + info ~docs:"CONFIG" ~doc ~docv:"DIR" ["base-dir"]) + let config_file = let doc = "The main configuration file." in - Arg.(value & opt (some string) None & info ~docs:"CONFIG" ~doc ~docv:"FILE" ["config-file"]) + Arg.(value & opt (some string) None & + info ~docs:"CONFIG" ~doc ~docv:"FILE" ["config-file"]) + let sandbox = - let doc = "Run the daemon in a sandbox (P2P is disabled, data is stored in a custom directory)." in - Arg.(value & opt (some string) None & info ~docs:"NETWORK" ~doc ~docv:"DIR" ["sandbox"]) - let sandbox_param = - let doc = "Custom parameter for the economical protocol." in - Arg.(value & opt (some string) None & info ~docs:"NETWORK" ~doc ["sandbox-param"]) - let v = - let doc = "Increase log level. Use several times to increase log level, e.g. `-vv'." in + let doc = + "Run the daemon in a sandbox: P2P is disabled, and constants of \ + the economical protocol might be altered by the optionnal JSON file." + in + Arg.(value & opt ~vopt:(Some None) (some (some string)) None & + info ~docs:"NETWORK" ~doc ~docv:"FILE.json" ["sandbox"]) + + let verbosity = + let doc = + "Increase log level. \ + Use several times to increase log level, e.g. `-vv'." in Arg.(value & flag_all & info ~docs:misc_sect ~doc ["v"]) - (* net args *) - let min_connections = - let doc = "The number of connections below which aggressive peer discovery mode is entered." in - Arg.(value & opt (some int) None & info ~docs:"NETWORK" ~doc ~docv:"NUM" ["min-connections"]) - let max_connections = - let doc = "The number of connections above which some connections will be closed." in - Arg.(value & opt (some int) None & info ~docs:"NETWORK" ~doc ~docv:"NUM" ["max-connections"]) - let expected_connections = - let doc = "The minimum number of connections to be ensured by the cruise control." in - Arg.(value & opt (some int) None & info ~docs:"NETWORK" ~doc ~docv:"NUM" ["expected-connections"]) - 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 @@ 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"]) - let closed = - let doc = "Only accept connections from the bootstrap peers." in - Arg.(value & flag & info ~docs:"NETWORK" ~doc ["closed"]) + let reset_config = let doc = "Overwrite config file with factory defaults." in Arg.(value & flag & info ~docs:"CONFIG" ~doc ["reset-config"]) + let update_config = let doc = "Update config file with values from the command line." in Arg.(value & flag & info ~docs:"CONFIG" ~doc ["update-config"]) + let generate_identity = + let doc = + "Generate a new cryptographic identity for the node. \ + It also generates the associated stamp of proof-of-work. \ + See `--expected-pow` for adjusting the required amount of \ + proof-of-work" in + Arg.(value & flag & info ~docs:"CONFIG" ~doc ["generate-identity"]) + + (* net args *) + let expected_connections = + let doc = + "The number of running connections that we must try to maintain + (approximativaly)." in + Arg.(value & opt (some int) None & + info ~docs:"NETWORK" ~doc ~docv:"NUM" ["expected-connections"]) + + let max_download_speed = + let doc = + "The maximum number of bytes read per second." in + Arg.(value & opt (some int) None & + info ~docs:"NETWORK" ~doc ~docv:"NUM" ["max-download-speed"]) + + let max_upload_speed = + let doc = + "The maximum number of bytes sent per second." in + Arg.(value & opt (some int) None & + info ~docs:"NETWORK" ~doc ~docv:"NUM" ["max-upload-speed"]) + + let listen_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 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"]) + + let expected_pow = + let doc = + "Expected level of proof-of-work for peers identity." in + Arg.(value & opt (some float) None & + info ~docs:"NETWORK" ~doc ~docv:"FLOAT" ["expected-pow"]) + + let closed = + let doc = + "Only accept connections from the configured bootstrap peers." in + Arg.(value & flag & info ~docs:"NETWORK" ~doc ["closed"]) + (* rpc args *) - let rpc_addr = - let doc = "The TCP socket address at which this RPC server instance can be reached." in - Arg.(value & opt (some sockaddr_converter) None & info ~docs:"RPC" ~doc ~docv:"ADDR:PORT" ["rpc-addr"]) + let rpc_listen_addr = + let doc = + "The TCP socket address at which this RPC server \ + instance can be reached." in + Arg.(value & opt (some Sockaddr.converter) None & + info ~docs:"RPC" ~doc ~docv:"ADDR:PORT" ["rpc-addr"]) + let rpc_tls = - let doc = "Enable TLS for this RPC server with the provided certificate and key." in - Arg.(value & opt (some (pair string string)) None & info ~docs:"RPC" ~doc ~docv:"crt,key" ["rpc-tls"]) + let doc = + "Enable TLS for this RPC server \ + with the provided certificate and key." in + Arg.(value & opt (some (pair string string)) None & + info ~docs:"RPC" ~doc ~docv:"crt,key" ["rpc-tls"]) + let cors_origins = - let doc = "CORS origin allowed by the RPC server via Access-Control-Allow-Origin; may be used multiple times" in - Arg.(value & opt_all string [] & info ~docs:"RPC" ~doc ~docv:"ORIGIN" ["cors-origin"]) + let doc = + "CORS origin allowed by the RPC server \ + via Access-Control-Allow-Origin; may be used multiple times" in + Arg.(value & opt_all string [] & + info ~docs:"RPC" ~doc ~docv:"ORIGIN" ["cors-origin"]) + let cors_headers = - let doc = "Header reported by Access-Control-Allow-Headers reported during CORS preflighting; may be used multiple times" in - Arg.(value & opt_all string [] & info ~docs:"RPC" ~doc ~docv:"HEADER" ["cors-header"]) + let doc = + "Header reported by Access-Control-Allow-Headers \ + reported during CORS preflighting; may be used multiple times" in + Arg.(value & opt_all string [] & + info ~docs:"RPC" ~doc ~docv:"HEADER" ["cors-header"]) - 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 = + exception Fail of string + let fail fmt = + Format.kasprintf (fun msg -> Lwt.fail (Fail msg)) fmt - 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 - let no_config () = - warn "Found no config file at %s" config_file; - warn "Using factory defaults"; - default_cfg_of_base_dir base_dir - in - let corrupted_config msg = - log_error "Config file %s corrupted: %s" config_file msg; - warn "Using factory defaults"; - default_cfg_of_base_dir base_dir - in - let cfg = - match Utils.read_file ~bin:false config_file |> Data_encoding_ezjsonm.from_string with - | exception _ -> no_config () - | Error msg -> corrupted_config msg - | Ok cfg -> try Cfg_file.from_json cfg with - | Invalid_argument msg - | Failure msg -> corrupted_config msg - in - let log_level = match List.length log_level with - | 0 -> None - | 1 -> Some Lwt_log.Info - | _ -> Some Lwt_log.Debug - in - let rpc_crt, rpc_key = match tls with - | None -> None, None - | Some (crt, key) -> Some crt, Some key - in - let cfg = - { cfg with - base_dir ; - sandbox = Utils.first_some sandbox cfg.sandbox ; - sandbox_param = Utils.first_some sandbox_param cfg.sandbox_param ; - log_level = Utils.first_some log_level cfg.log_level ; - min_connections = Utils.unopt cfg.min_connections min_connections ; - max_connections = Utils.unopt cfg.max_connections max_connections ; - 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 ; *) - peers = (match peers with [] -> cfg.peers | _ -> peers) ; - closed = closed || cfg.closed ; - rpc_addr = Utils.first_some rpc_addr cfg.rpc_addr ; - cors_origins = (match cors_origins with [] -> cfg.cors_origins | _ -> cors_origins) ; - cors_headers = (match cors_headers with [] -> cfg.cors_headers | _ -> cors_headers) ; - rpc_crt ; - rpc_key ; - log_output = cfg.log_output ; - } - in - if update_cfg then Cfg_file.write config_file cfg; - `Ok (config_file, reset_cfg, update_cfg, cfg) + let parse + base_dir config_file + sandbox verbosity + expected_connections + max_download_speed max_upload_speed + listen_addr bootstrap_peers closed expected_pow + rpc_listen_addr rpc_tls cors_origins cors_headers + reset_cfg update_cfg generate_identity = + + let actual_base_dir = + match base_dir with + | None -> default_base_dir + | Some dir -> dir in + + let config_file = + match config_file with + | None -> actual_base_dir // "config.json" + | Some file -> file in + + (* When --base-dir is provided, we ignore the `db`, `net.identity` + and `net.peers_metadata` of the configuration file. *) + let db = Utils.map_option Cfg_file.default_db base_dir in + let identity, peers_metadata = + let default_net = Utils.map_option Cfg_file.default_net base_dir in + Utils.map_option + ~f:(fun net -> net.Cfg_file.identity) default_net, + Utils.map_option + ~f:(fun net -> net.Cfg_file.peers_metadata) default_net in + + let read () = + if reset_cfg && update_cfg then + fail "The options --reset-config and --update-config \ + cannot be used together" + else if reset_cfg then + Lwt.return + (Cfg_file.default_config actual_base_dir, true) + else if update_cfg && not (Sys.file_exists config_file) then + fail "Cannot update a non-existant configuration file." + else if not (Sys.file_exists config_file) then + Lwt.return + (Cfg_file.default_config actual_base_dir, true) + else + Cfg_file.read config_file >>= function + | Error err -> + fail + "@[Corrupted configuration file, \ + fix it or use --reset-config.@ %a@]" + pp_print_error err + | Ok cfg -> Lwt.return (cfg, update_cfg) + in + + let verbosity = + match verbosity with + | [] -> None + | [_] -> Some Logging.Info + | _ -> Some Logging.Debug + in + + let rpc_tls = + Utils.map_option + (fun (cert, key) -> { Cfg_file.cert ; key }) + rpc_tls in + + let unopt_list ~default = function + | [] -> default + | l -> l in + + (* when `--expected-connections` is used, + override all the bounds defined in the configuration file. *) + let min_connections, expected_connections, max_connections = + match expected_connections with + | None -> None, None, None + | Some x -> Some (x/2), Some x, Some (3*x/2) in + + try + Lwt_main.run begin + Lwt_utils.create_dir ~perm:0o700 actual_base_dir >>= fun () -> + read () >>= fun (cfg, write_cfg) -> + let db = Utils.unopt ~default:cfg.db db in + let limits : P2p.limits = { + cfg.net.limits with + min_connections = + Utils.unopt + ~default:cfg.net.limits.min_connections + min_connections ; + expected_connections = + Utils.unopt + ~default:cfg.net.limits.expected_connections + expected_connections ; + max_connections = + Utils.unopt + ~default:cfg.net.limits.max_connections + max_connections ; + max_download_speed = + Utils.first_some + max_download_speed cfg.net.limits.max_download_speed ; + max_upload_speed = + Utils.first_some + max_upload_speed cfg.net.limits.max_upload_speed ; + } in + let net : Cfg_file.net = { + identity = + Utils.unopt ~default:cfg.net.identity identity ; + expected_pow = + Utils.unopt ~default:cfg.net.expected_pow expected_pow ; + bootstrap_peers = + unopt_list ~default:cfg.net.bootstrap_peers bootstrap_peers ; + peers_metadata = + Utils.unopt ~default:cfg.net.peers_metadata peers_metadata ; + listen_addr = + Utils.first_some listen_addr cfg.net.listen_addr ; + closed = cfg.net.closed || closed ; + limits ; + } + and rpc : Cfg_file.rpc = { + listen_addr = + Utils.first_some rpc_listen_addr cfg.rpc.listen_addr ; + cors_origins = + unopt_list ~default:cfg.rpc.cors_origins cors_origins ; + cors_headers = + unopt_list ~default:cfg.rpc.cors_headers cors_headers ; + tls = + Utils.first_some rpc_tls cfg.rpc.tls ; + } in + let cfg_file = { Cfg_file.db ; net ; rpc ; log = cfg.log } in + let write_cfg : (string * _ format6) option = + if not write_cfg then None + else if reset_cfg then + Some (config_file, "Reseting configuration file '%s'.") + else if update_cfg then + Some (config_file, "Updating configuration file '%s'.") + else + Some (config_file, "Writing initial configuration file '%s'.") + in + let cmdline = + { sandbox ; verbosity ; generate_identity ; write_cfg } in + Lwt.return (`Ok (cfg_file, cmdline)) + end + with Fail msg -> `Error (false, msg) let cmd = let open Term in ret (const parse $ base_dir $ config_file - $ sandbox $ sandbox_param $ v - $ min_connections $ max_connections $ expected_connections - $ net_addr - (* $ local_discovery *) - $ peers $ closed - $ rpc_addr $ rpc_tls $ cors_origins $ cors_headers - $ reset_config $ update_config + $ sandbox $ verbosity + $ expected_connections + $ max_download_speed $ max_upload_speed + $ listen_addr $ peers $ closed $ expected_pow + $ rpc_listen_addr $ rpc_tls $ cors_origins $ cors_headers + $ reset_config $ update_config $ generate_identity ), let doc = "The Tezos daemon" in let man = [ @@ -392,7 +601,9 @@ module Cmdline = struct `S "CONFIG"; `S misc_sect; `S "EXAMPLES" ; - `P "Use `$(mname) --sandbox /path/to/a/custom/data/dir --rpc-addr :::8732' \ + `P "Use `$(mname) --sandbox \ + --base-dir /path/to/a/custom/data/dir \ + --rpc-addr :::8732' \ to run a single instance in sandbox mode, \ listening to RPC commands at localhost port 8732."; `P "Use `$(mname)' for a node that accepts network connections."; @@ -402,172 +613,232 @@ module Cmdline = struct info ~sdocs:misc_sect ~man ~doc "tezos-node" let parse () = Term.eval cmd + end -let init_logger { log_output ; log_level } = +let init_logger ?verbosity (log_config : Cfg_file.log) = let open Logging in - Utils.iter_option log_level ~f:(Lwt_log_core.add_rule "*") ; - match log_output with - | `Stderr -> Logging.init Stderr - | `File fp -> Logging.init (File fp) - | `Null -> Logging.init Null - | `Syslog -> Logging.init Syslog + begin + match verbosity with + | Some level -> + Lwt_log_core.add_rule "*" level + | None -> + Lwt_log_core.add_rule "*" log_config.default_level ; + let rules = + match Sys.getenv "TEZOS_LOG" with + | rules -> Some rules + | exception Not_found -> + match Sys.getenv "LWT_LOG" with + | rules -> Some rules + | exception Not_found -> log_config.rules in + Utils.iter_option Lwt_log_core.load_rules rules + end ; + Logging.init ~template:log_config.template log_config.output -let init_node - { sandbox ; sandbox_param ; - store ; context ; - min_connections ; max_connections ; expected_connections ; - net_port ; peers ; peers_cache ; closed } = +type error += No_identity +type error += Existent_identity_file + +let read_identity target file = + Lwt_unix.file_exists file >>= function + | true -> + Data_encoding_ezjsonm.read_file file >>=? fun json -> + let id = Data_encoding.Json.destruct P2p.Identity.encoding json in + Lwt_utils.unless + (Crypto_box.check_proof_of_work + id.public_key id.proof_of_work_stamp target) + (fun () -> + lwt_warn "The amount of proof-of-work stamp in the node's identity \ + is below your own expectations.") >>= fun () -> + return id + | false -> + fail No_identity + +let init_node ?sandbox (config : Cfg_file.t) = let patch_context json ctxt = let module Proto = (val Updater.get_exn genesis_protocol) in - Lwt.catch - (fun () -> - Proto.configure_sandbox ctxt json >|= function - | Error _ -> - warn "Error while configuring ecoproto for the sandboxed mode." ; - ctxt - | Ok ctxt -> ctxt) - (fun exn -> - warn "Error while configuring ecoproto for the sandboxed mode. (%s)" - (Printexc.to_string exn) ; - Lwt.return ctxt) in + Lwt_utils.protect begin fun () -> + Proto.configure_sandbox ctxt json + end >|= function + | Error err -> + warn + "@[Error while configuring ecoproto for the sandboxed mode:@ %a@]" + pp_print_error err ; + ctxt + | Ok ctxt -> ctxt in begin match sandbox with | None -> Lwt.return_none - | Some _ -> + | Some sandbox_param -> match sandbox_param with | None -> Lwt.return (Some (patch_context None)) | Some file -> Data_encoding_ezjsonm.read_file file >>= function - | None -> + | Error err -> lwt_warn - "Can't parse sandbox parameters. (%s)" file >>= fun () -> + "Can't parse sandbox parameters: %s" file >>= fun () -> + lwt_debug "%a" pp_print_error err >>= fun () -> Lwt.return (Some (patch_context None)) - | Some _ as json -> - Lwt.return (Some (patch_context json)) + | Ok json -> + Lwt.return (Some (patch_context (Some json))) end >>= fun patch_context -> - let net_params = + begin let open P2p in match sandbox with - | Some _ -> None + | Some _ -> return 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 = - { authentification_timeout ; - min_connections ; - expected_connections ; - max_connections ; - 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 = - { listening_port = Some net_port ; - listening_addr ; + let proof_of_work_target = + Crypto_box.make_target config.net.expected_pow in + read_identity + proof_of_work_target config.net.identity >>=? fun identity -> + lwt_log_notice "Peers' id: %a" P2p.Gid.pp identity.gid >>= fun () -> + let p2p_config : P2p.config = + { listening_port = Utils.map_option snd config.net.listen_addr ; + listening_addr = Utils.map_option fst config.net.listen_addr ; + trusted_points = config.net.bootstrap_peers ; + peers_file = config.net.peers_metadata ; + closed_network = config.net.closed ; identity ; - trusted_points = peers ; - peers_file = peers_cache ; - closed_network = closed ; proof_of_work_target ; } in - Some (config, limits) in - Node.create - ~genesis - ~store_root:store - ~context_root:context - ?test_protocol - ?patch_context - net_params + return (Some (p2p_config, config.net.limits)) + end >>=? fun p2p_config -> + let node_config : Node.config = { + genesis ; + test_protocol ; + patch_context ; + store_root = config.db.store ; + context_root = config.db.context ; + p2p = p2p_config ; + } in + Node.create node_config -let init_rpc { rpc_addr ; rpc_crt; rpc_key ; cors_origins ; cors_headers } node = - match rpc_addr, rpc_crt, rpc_key with - | Some (addr, port), Some crt, Some key -> - 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.V6.to_string addr in - let () = - let old_hook = !Lwt.async_exception_hook in - Lwt.async_exception_hook := function - | Ssl.Read_error _ -> () - | exn -> old_hook exn in - RPC_server.launch ~host mode dir cors_origins cors_headers >>= fun server -> - Lwt.return (Some server) - | Some (_addr, port), _, _ -> - lwt_log_notice "Starting the RPC server listening on port %d (TLS disabled)." port >>= fun () -> - let dir = Node_rpc.build_rpc_directory node in - RPC_server.launch (`TCP (`Port port)) dir cors_origins cors_headers >>= fun server -> - Lwt.return (Some server) - | _ -> +let () = + let old_hook = !Lwt.async_exception_hook in + Lwt.async_exception_hook := function + | Ssl.Read_error _ -> () + | exn -> old_hook exn + +let init_rpc (rpc_config: Cfg_file.rpc) node = + match rpc_config.listen_addr with + | None -> lwt_log_notice "Not listening to RPC calls." >>= fun () -> - Lwt.return None + Lwt.return_none + | Some (addr, port) -> + let host = Ipaddr.V6.to_string addr in + let dir = Node_rpc.build_rpc_directory node in + let mode = + match rpc_config.tls with + | None -> `TCP (`Port port) + | Some { cert ; key } -> + `TLS (`Crt_file_path cert, `Key_file_path key, + `No_password, `Port port) in + lwt_log_notice + "Starting the RPC server listening on port %d%s." + port + (if rpc_config.tls = None then "" else " (TLS enabled)") >>= fun () -> + RPC_server.launch ~host mode dir + rpc_config.cors_origins rpc_config.cors_headers >>= fun server -> + Lwt.return (Some server) + let init_signal () = let handler id = try Lwt_exit.exit id with _ -> () in ignore (Lwt_unix.on_signal Sys.sigint handler : Lwt_unix.signal_handler_id) -let main cfg = +module Identity = struct + + let generate (command : Cmdline.t) (config : Cfg_file.t) = + let file = config.net.identity in + if not command.generate_identity then + return () + else if Sys.file_exists file then + fail Existent_identity_file + else + let target = Crypto_box.make_target config.net.expected_pow in + Format.eprintf "Generating a new identity... " ; + let identity = + P2p.Identity.generate_with_animation Format.err_formatter target in + Data_encoding_ezjsonm.write_file file + (Data_encoding.Json.construct P2p.Identity.encoding identity) + >>=? fun () -> + Format.eprintf + "Stored the new identity (%a) into '%s'@." + P2p.Gid.pp identity.gid file ; + return () + +end + +module Node = struct + + let may_write_config (command : Cmdline.t) (config : Cfg_file.t) = + match command.write_cfg with + | None -> return () + | Some (file, fmt) -> + Format.eprintf "%(%s%)@." fmt file ; + Cfg_file.write file config + + let run (command : Cmdline.t) (config : Cfg_file.t) = + may_write_config command config >>=? fun () -> + init_signal () ; + init_logger ?verbosity:command.verbosity config.log >>= fun () -> + Updater.init config.db.protocol ; + lwt_log_notice "Starting the Tezos node..." >>= fun () -> + init_node ?sandbox:command.sandbox config >>=? fun node -> + init_rpc config.rpc node >>= fun rpc -> + lwt_log_notice "The Tezos node is now running!" >>= fun () -> + Lwt_exit.termination_thread >>= fun x -> + lwt_log_notice "Shutting down the Tezos node..." >>= fun () -> + Node.shutdown node >>= fun () -> + lwt_log_notice "Shutting down the RPC server..." >>= fun () -> + Lwt_utils.may RPC_server.shutdown rpc >>= fun () -> + lwt_log_notice "BYE (%d)" x >>= fun () -> + return () + +end + +let main (command : Cmdline.t) (config : Cfg_file.t) = Random.self_init () ; Sodium.Random.stir () ; - init_logger cfg; - Updater.init cfg.protocol; - lwt_log_notice "Starting the Tezos node..." >>= fun () -> - init_node cfg >>=? fun node -> - init_rpc cfg node >>= fun rpc -> - init_signal (); - lwt_log_notice "The Tezos node is now running!" >>= fun () -> - Lwt_exit.termination_thread >>= fun x -> - lwt_log_notice "Shutting down the Tezos node..." >>= fun () -> - Node.shutdown node >>= fun () -> - lwt_log_notice "Shutting down the RPC server..." >>= fun () -> - Lwt_utils.may RPC_server.shutdown rpc >>= fun () -> - lwt_log_notice "BYE (%d)" x >>= fun () -> - return () + Identity.generate command config >>=? fun () -> + Node.run command config let () = match Cmdline.parse () with | `Error _ -> exit 1 | `Help -> exit 1 | `Version -> exit 1 - | `Ok (config_file, was_reset, updated, cfg) -> - if was_reset then log_notice "Overwriting %s with factory defaults." config_file; - if updated then log_notice "Updated %s from command line arguments." config_file; + | `Ok (config, command) -> Lwt_main.run begin - if not @@ Sys.file_exists cfg.base_dir then begin - Unix.mkdir cfg.base_dir 0o700; - log_notice "Created base directory %s." cfg.base_dir - end; - log_notice "Using config file %s." config_file; - if not @@ Sys.file_exists config_file then begin - Cfg_file.write config_file cfg; - log_notice "Created config file %s." config_file - end; - main cfg >>= function + main command config >>= function | Ok () -> Lwt.return_unit + | Error [No_identity] -> + Format.eprintf + "Cannot find the identity file '%s'!\n%a@." + config.net.identity + Utils.display_paragraph + (Format.sprintf + "In order to proceed, Tezos needs a cryptographic identity. \ + You may generate a new identity by running:\n\ + \n\ +    %s --generate-identity --expected-pow %.1f\n\ + where `%.1f` is the expected level of proof-of-work in \ + the stamp associated to the new identity. \ + For quick testing, you may use '--expected-pow 0'." + Sys.argv.(0) + config.net.expected_pow + config.net.expected_pow) ; + exit 2 + | Error [Existent_identity_file] -> + Format.eprintf + "Error: Cannot implicitely overwrite an existing identity.\n\ + \n\ + \ Please remove the old identity file '%s'.@." + config.net.identity ; + exit 2 | Error err -> - lwt_log_error "%a@." Error_monad.pp_print_error err + lwt_log_error + "@[Unexpected error while initializing the node:@ %a@]@." + pp_print_error err >>= fun () -> + exit 1 end diff --git a/src/utils/crypto_box.ml b/src/utils/crypto_box.ml index e8d58a80d..d3d1d4a0a 100644 --- a/src/utils/crypto_box.ml +++ b/src/utils/crypto_box.ml @@ -15,7 +15,7 @@ type secret_key = Sodium.Box.secret_key type public_key = Sodium.Box.public_key type channel_key = Sodium.Box.channel_key type nonce = Sodium.Box.nonce -type target = int64 list (* used as unsigned intergers... *) +type target = Z.t exception TargetNot256Bit module Public_key_hash = Hash.Make_Blake2B (Base48) (struct @@ -44,24 +44,29 @@ 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 - -(* Compare a SHA256 hash to a 256bits-target prefix. - The prefix is a list of "unsigned" int64. *) let compare_target hash target = - let hash = Hash.Generic_hash.to_string hash in - let rec check offset = function - | [] -> true - | x :: xs -> - Compare.Uint64.(EndianString.BigEndian.get_int64 hash offset <= x) - && check (offset + 8) xs in - check 0 target + let hash = Z.of_bits (Hash.Generic_hash.to_string hash) in + Z.compare hash target <= 0 -let default_target = - (* FIXME we use an easy target until we allow custom configuration. *) - [ Int64.shift_left 1L 48 ] +let make_target f = + if f < 0. || 256. < f then invalid_arg "Cryptobox.target_of_float" ; + let frac, shift = modf f in + let shift = int_of_float shift in + let m = + Z.of_int64 @@ + if frac = 0. then + Int64.(pred (shift_left 1L 54)) + else + Int64.of_float (2. ** (54. -. frac)) + in + if shift < 202 then + Z.logor + (Z.shift_left m (202 - shift)) + (Z.pred @@ Z.shift_left Z.one (202 - shift)) + else + Z.shift_right m (shift - 202) + +let default_target = make_target 24. let check_proof_of_work pk nonce target = let hash = @@ -71,11 +76,18 @@ let check_proof_of_work pk nonce target = ] in compare_target hash target -let generate_proof_of_work pk target = - let rec loop nonce = - if check_proof_of_work pk nonce target then nonce - else loop (increment_nonce nonce) in - loop (random_nonce ()) +let generate_proof_of_work ?max pk target = + let may_interupt = + match max with + | None -> (fun _ -> ()) + | Some max -> (fun cpt -> if max < cpt then raise Not_found) in + let rec loop nonce cpt = + may_interupt cpt ; + if check_proof_of_work pk nonce target then + nonce + else + loop (increment_nonce nonce) (cpt + 1) in + loop (random_nonce ()) 0 let public_key_encoding = let open Data_encoding in diff --git a/src/utils/crypto_box.mli b/src/utils/crypto_box.mli index 0ae416919..487f3f56f 100644 --- a/src/utils/crypto_box.mli +++ b/src/utils/crypto_box.mli @@ -16,8 +16,8 @@ val increment_nonce : ?step:int -> nonce -> nonce val nonce_encoding : nonce Data_encoding.t type target -val make_target : (* unsigned *) Int64.t list -> target val default_target : target +val make_target : float -> target type secret_key type public_key @@ -38,5 +38,5 @@ 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 +val generate_proof_of_work : ?max:int -> public_key -> target -> nonce diff --git a/src/utils/data_encoding_ezjsonm.ml b/src/utils/data_encoding_ezjsonm.ml index 0b3c36ebf..8fb4ffcc8 100644 --- a/src/utils/data_encoding_ezjsonm.ml +++ b/src/utils/data_encoding_ezjsonm.ml @@ -7,6 +7,8 @@ (* *) (**************************************************************************) +open Error_monad + let to_root = function | `O ctns -> `O ctns | `A ctns -> `A ctns @@ -35,22 +37,21 @@ let from_stream (stream: string Lwt_stream.t) = let write_file file json = let json = to_root json in - let open Lwt in - catch - (fun () -> - Lwt_io.(with_file ~mode:Output file (fun chan -> - let str = to_string json in - write chan str >>= fun _ -> - return true))) - (fun _ -> return false) + protect begin fun () -> + Lwt_io.with_file ~mode:Output file begin fun chan -> + let str = to_string json in + Lwt_io.write chan str >>= fun _ -> + return () + end + end let read_file file = - let open Lwt in - catch - (fun () -> - Lwt_io.(with_file ~mode:Input file (fun chan -> - read chan >>= fun str -> - return (Some (Ezjsonm.from_string str :> Data_encoding.json))))) - (fun _ -> - (* TODO log error or use Error_monad. *) - return None) + protect begin fun () -> + Lwt_io.with_file ~mode:Input file begin fun chan -> + Lwt_io.read chan >>= fun str -> + return (Ezjsonm.from_string str :> Data_encoding.json) + end + end + +let () = + Error_monad.json_to_string := to_string diff --git a/src/utils/data_encoding_ezjsonm.mli b/src/utils/data_encoding_ezjsonm.mli index a195f10a0..51b41776b 100644 --- a/src/utils/data_encoding_ezjsonm.mli +++ b/src/utils/data_encoding_ezjsonm.mli @@ -7,6 +7,8 @@ (* *) (**************************************************************************) +open Error_monad + (** Read a JSON document from a string. *) val from_string : string -> (Data_encoding.json, string) result @@ -20,7 +22,7 @@ val from_stream : string Lwt_stream.t -> (Data_encoding.json, string) result Lwt val to_string : Data_encoding.json -> string (** Loads a JSON file in memory *) -val read_file : string -> Data_encoding.json option Lwt.t +val read_file : string -> Data_encoding.json tzresult Lwt.t (** (Over)write a JSON file from in memory data *) -val write_file : string -> Data_encoding.json -> bool Lwt.t +val write_file : string -> Data_encoding.json -> unit tzresult Lwt.t diff --git a/src/utils/error_monad.ml b/src/utils/error_monad.ml index 8ff3375ae..e67c27b9c 100644 --- a/src/utils/error_monad.ml +++ b/src/utils/error_monad.ml @@ -16,10 +16,13 @@ type error_category = [ `Branch | `Temporary | `Permanent ] type 'err full_error_category = [ error_category | `Wrapped of 'err -> error_category ] +(* HACK: forward reference from [Data_encoding_ezjsonm] *) +let json_to_string = ref (fun _ -> "") + let json_pp encoding ppf x = Format.pp_print_string ppf @@ - Data_encoding_ezjsonm.to_string @@ - Data_encoding.Json.(construct encoding x) + !json_to_string @@ + Data_encoding.Json.construct encoding x module Make() = struct @@ -74,7 +77,7 @@ module Make() = struct category ; from_error ; encoding_case ; - pp = Utils.unopt (json_pp encoding) pp } :: !error_kinds + pp = Utils.unopt ~default:(json_pp encoding) pp } :: !error_kinds let register_wrapped_error_kind category ~id ~title ~description ?pp @@ -174,11 +177,6 @@ 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 @@ -325,6 +323,11 @@ let () = error_kinds := Error_kind { id; from_error ; category; encoding_case ; pp } :: !error_kinds +let protect ~on_error t = + t >>= function + | Ok res -> return res + | Error err -> on_error err + end include Make() @@ -340,6 +343,14 @@ 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 protect ?on_error t = + Lwt.catch t (fun exn -> fail (Exn exn)) >>= function + | Ok res -> return res + | Error err -> + match on_error with + | Some f -> f err + | None -> Lwt.return (Error err) + let pp_exn ppf exn = pp ppf (Exn exn) let () = diff --git a/src/utils/error_monad.mli b/src/utils/error_monad.mli index 11e607101..141dedd47 100644 --- a/src/utils/error_monad.mli +++ b/src/utils/error_monad.mli @@ -26,6 +26,10 @@ val failwith : ('a, Format.formatter, unit, 'b tzresult Lwt.t) format4 -> 'a +val protect : + ?on_error: (error list -> 'a tzresult Lwt.t) -> + (unit -> 'a tzresult Lwt.t) -> 'a tzresult Lwt.t + 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 @@ -35,3 +39,6 @@ type error += Exn of exn type error += Unclassified of string module Make() : Error_monad_sig.S + +(**/**) +val json_to_string : (Data_encoding.json -> string) ref diff --git a/src/utils/logging.ml b/src/utils/logging.ml index b41340dbf..fe791833d 100644 --- a/src/utils/logging.ml +++ b/src/utils/logging.ml @@ -7,6 +7,8 @@ (* *) (**************************************************************************) +open Lwt.Infix + module type LOG = sig val debug: ('a, Format.formatter, unit, unit) format4 -> 'a @@ -86,32 +88,134 @@ module Client = struct end module Webclient = Make(struct let name = "webclient" end) -let template = "$(date) $(name)[$(pid)]: $(message)" - -let default_logger () = - Lwt_log.channel ~template ~close_mode:`Keep ~channel:Lwt_io.stderr () +type template = Lwt_log.template +let default_template = "$(date) - $(section): $(message)" type kind = | Null | Stdout | Stderr | File of string - | Syslog - | Manual of Lwt_log.logger + | Syslog of Lwt_log.syslog_facility -let init kind = - let logger = +let kind_encoding = + let open Data_encoding in + conv + (function + | Null -> "/dev/null" + | Stdout -> "stdout" + | Stderr -> "stderr" + | File fp -> fp + | Syslog `Auth -> "syslog:auth" + | Syslog `Authpriv -> "syslog:authpriv" + | Syslog `Cron -> "syslog:cron" + | Syslog `Daemon -> "syslog:daemon" + | Syslog `FTP -> "syslog:ftp" + | Syslog `Kernel -> "syslog:kernel" + | Syslog `Local0 -> "syslog:local0" + | Syslog `Local1 -> "syslog:local1" + | Syslog `Local2 -> "syslog:local2" + | Syslog `Local3 -> "syslog:local3" + | Syslog `Local4 -> "syslog:local4" + | Syslog `Local5 -> "syslog:local5" + | Syslog `Local6 -> "syslog:local6" + | Syslog `Local7 -> "syslog:local7" + | Syslog `LPR -> "syslog:lpr" + | Syslog `Mail -> "syslog:mail" + | Syslog `News -> "syslog:news" + | Syslog `Syslog -> "syslog:syslog" + | Syslog `User -> "syslog:user" + | Syslog `UUCP -> "syslog:uucp" + | Syslog `NTP -> "syslog:ntp" + | Syslog `Security -> "syslog:security" + | Syslog `Console -> "syslog:console") + (function + | "/dev/null" | "null" -> Null + | "stdout" -> Stdout + | "stderr" -> Stderr + | "syslog:auth" -> Syslog `Auth + | "syslog:authpriv" -> Syslog `Authpriv + | "syslog:cron" -> Syslog `Cron + | "syslog:daemon" -> Syslog `Daemon + | "syslog:ftp" -> Syslog `FTP + | "syslog:kernel" -> Syslog `Kernel + | "syslog:local0" -> Syslog `Local0 + | "syslog:local1" -> Syslog `Local1 + | "syslog:local2" -> Syslog `Local2 + | "syslog:local3" -> Syslog `Local3 + | "syslog:local4" -> Syslog `Local4 + | "syslog:local5" -> Syslog `Local5 + | "syslog:local6" -> Syslog `Local6 + | "syslog:local7" -> Syslog `Local7 + | "syslog:lpr" -> Syslog `LPR + | "syslog:mail" -> Syslog `Mail + | "syslog:news" -> Syslog `News + | "syslog:syslog" -> Syslog `Syslog + | "syslog:user" -> Syslog `User + | "syslog:uucp" -> Syslog `UUCP + | "syslog:ntp" -> Syslog `NTP + | "syslog:security" -> Syslog `Security + | "syslog:console" -> Syslog `Console + (* | s when start_with "syslog:" FIXME error or warning. *) + | fp -> + (* TODO check absolute path *) + File fp) + string + + +let init ?(template = default_template) kind = + begin match kind with | Stderr -> - default_logger () + Lwt.return @@ + Lwt_log.channel ~template ~close_mode:`Keep ~channel:Lwt_io.stderr () | Stdout -> + Lwt.return @@ Lwt_log.channel ~template ~close_mode:`Keep ~channel:Lwt_io.stdout () | File file_name -> - Lwt_main.run (Lwt_log.file ~file_name ~template ()) + Lwt_log.file ~file_name ~template () | Null -> + Lwt.return @@ Lwt_log.null - | Syslog -> - Printf.eprintf "Warning: log_kind \"syslog\" not yet implemented.\n%!"; - default_logger () - | Manual logger -> logger in - Lwt_log.default := logger + | Syslog facility -> + Lwt.return @@ + Lwt_log.syslog ~template ~facility () + end >>= fun logger -> + Lwt_log.default := logger ; + Lwt.return_unit + +type level = Lwt_log_core.level = + | Debug + (** Debugging message. They can be automatically removed by the + syntax extension. *) + | Info + (** Informational message. Suitable to be displayed when the + program is in verbose mode. *) + | Notice + (** Same as {!Info}, but is displayed by default. *) + | Warning + (** Something strange happend *) + | Error + (** An error message, which should not means the end of the + program. *) + | Fatal + +let level_encoding = + let open Data_encoding in + conv + (function + | Fatal -> "fatal" + | Error -> "error" + | Warning -> "warning" + | Notice -> "notice" + | Info -> "info" + | Debug -> "debug") + (function + | "error" -> Error + | "warn" -> Warning + | "notice" -> Notice + | "info" -> Info + | "debug" -> Debug + | "fatal" -> Fatal + | _ -> invalid_arg "Logging.level") + string diff --git a/src/utils/logging.mli b/src/utils/logging.mli index fb999b7b0..c366f11b9 100644 --- a/src/utils/logging.mli +++ b/src/utils/logging.mli @@ -48,12 +48,34 @@ module Webclient : LOG module Make(S: sig val name: string end) : LOG +type level = Lwt_log_core.level = + | Debug + (** Debugging message. They can be automatically removed by the + syntax extension. *) + | Info + (** Informational message. Suitable to be displayed when the + program is in verbose mode. *) + | Notice + (** Same as {!Info}, but is displayed by default. *) + | Warning + (** Something strange happend *) + | Error + (** An error message, which should not means the end of the + program. *) + | Fatal + +type template = Lwt_log.template +val default_template : template + +val level_encoding : level Data_encoding.t + type kind = | Null | Stdout | Stderr | File of string - | Syslog - | Manual of Lwt_log.logger + | Syslog of Lwt_log.syslog_facility -val init: kind -> unit +val kind_encoding : kind Data_encoding.t + +val init: ?template:template -> kind -> unit Lwt.t diff --git a/src/utils/lwt_utils.ml b/src/utils/lwt_utils.ml index 00f857ab9..ceb472d13 100644 --- a/src/utils/lwt_utils.ml +++ b/src/utils/lwt_utils.ml @@ -346,12 +346,14 @@ let remove_dir dir = Lwt.return () let rec create_dir ?(perm = 0o755) dir = - if Sys.file_exists dir then - Lwt.return () - else begin - create_dir (Filename.dirname dir) >>= fun () -> - Lwt_unix.mkdir dir perm - end + Lwt_unix.file_exists dir >>= function + | false -> + create_dir (Filename.dirname dir) >>= fun () -> + Lwt_unix.mkdir dir perm + | true -> + Lwt_unix.stat dir >>= function + | {st_kind = S_DIR} -> Lwt.return_unit + | _ -> failwith "Not a directory" let create_file ?(perm = 0o644) name content = Lwt_unix.openfile name Unix.([O_TRUNC; O_CREAT; O_WRONLY]) perm >>= fun fd -> @@ -402,4 +404,6 @@ let with_timeout ?(canceler = Canceler.create ()) timeout f = Canceler.cancel canceler >>= fun () -> fail Timeout +let unless cond f = + if cond then Lwt.return () else f () diff --git a/src/utils/lwt_utils.mli b/src/utils/lwt_utils.mli index 78cf995a2..14f48cf90 100644 --- a/src/utils/lwt_utils.mli +++ b/src/utils/lwt_utils.mli @@ -67,3 +67,5 @@ val with_timeout: ?canceler:Canceler.t -> float -> (Canceler.t -> 'a tzresult Lwt.t) -> 'a tzresult Lwt.t +val unless: bool -> (unit -> unit Lwt.t) -> unit Lwt.t + diff --git a/test/lib/assert.ml b/test/lib/assert.ml index 8201fdf82..707179f0f 100644 --- a/test/lib/assert.ml +++ b/test/lib/assert.ml @@ -14,6 +14,16 @@ include Kaputt.Assertion let format_msg = function None -> None | Some msg -> Some (msg ^ "\n") +let is_error ?(msg="") x = + match x with + | Error _ -> () + | Ok _ -> fail "Error _" "Ok _" msg + +let is_ok ?(msg="") x = + match x with + | Ok _ -> () + | Error _ -> fail "Ok _" "Error _" msg + let equal_persist_list ?msg l1 l2 = let msg = format_msg msg in let pr_persist l = diff --git a/test/lib/assert.mli b/test/lib/assert.mli index 28ee6a19f..7c01a393c 100644 --- a/test/lib/assert.mli +++ b/test/lib/assert.mli @@ -8,8 +8,12 @@ (**************************************************************************) open Hash +open Error_monad include (module type of struct include Kaputt.Assertion end) +val is_ok : ?msg:string -> 'a tzresult -> unit +val is_error : ?msg:string -> 'a tzresult -> unit + val fail_msg : ('a, Format.formatter, unit, 'b) format4 -> 'a val fail : string -> string -> ('a, Format.formatter, unit, 'b) format4 -> 'a diff --git a/test/lib/process.ml b/test/lib/process.ml index 2a60b2bbc..5a314237d 100644 --- a/test/lib/process.ml +++ b/test/lib/process.ml @@ -19,11 +19,8 @@ let detach ?(prefix = "") f = | 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 + Logging.init ~template Stderr >>= fun () -> lwt_log_notice "PID: %d" (Unix.getpid ()) >>= fun () -> f () end ; diff --git a/test/test-basic.sh b/test/test-basic.sh index 5ca301f7b..301a1bd49 100755 --- a/test/test-basic.sh +++ b/test/test-basic.sh @@ -5,8 +5,8 @@ set -e DIR=$(dirname "$0") cd "${DIR}" -DATA_DIR=$(mktemp -d /tmp/tezos_node.XXXXXXXXXX) -CLIENT_DIR=$(mktemp -d /tmp/tezos_client.XXXXXXXXXX) +DATA_DIR="$(mktemp -td tezos_node.XXXXXXXXXX)" +CLIENT_DIR="$(mktemp -td tezos_client.XXXXXXXXXX)" cleanup() { rm -fr ${DATA_DIR} ${CLIENT_DIR} @@ -17,8 +17,8 @@ trap cleanup EXIT QUIT INT NODE=../tezos-node CLIENT="../tezos-client -base-dir ${CLIENT_DIR}" -CUSTOM_PARAM="--sandbox-param ./sandbox.json" -${NODE} --sandbox "${DATA_DIR}" ${CUSTOM_PARAM} --rpc-addr :::8732 > LOG 2>&1 & +CUSTOM_PARAM="--sandbox ./sandbox.json" +${NODE} --base-dir "${DATA_DIR}" ${CUSTOM_PARAM} --rpc-addr :::8732 > LOG 2>&1 & NODE_PID="$!" sleep 3 diff --git a/test/test_basic.ml b/test/test_basic.ml index 2337ce546..e4d5895ba 100644 --- a/test/test_basic.ml +++ b/test/test_basic.ml @@ -50,8 +50,8 @@ let fork_node () = Unix.create_process Filename.(concat (dirname (Sys.getcwd ())) "tezos-node") [| "tezos-node" ; - "--sandbox"; data_dir ; - "--sandbox-param"; "./sandbox.json"; + "--base-dir"; data_dir ; + "--sandbox"; "./sandbox.json"; "--rpc-addr"; ":::8732" |] null_fd log_fd log_fd in Printf.printf "Created node, pid: %d, log: %s\n%!" pid log_file_name ; diff --git a/test/test_data_encoding.ml b/test/test_data_encoding.ml index 848419be9..1d264c358 100644 --- a/test/test_data_encoding.ml +++ b/test/test_data_encoding.ml @@ -110,11 +110,11 @@ let test_json testdir = let f_str = to_string v in Assert.equal_string ~msg:__LOC__ f_str "[\n 42\n]"; read_file (testdir // "NONEXISTINGFILE") >>= fun rf -> - Assert.is_none ~msg:__LOC__ rf; + Assert.is_error ~msg:__LOC__ rf ; write_file file v >>= fun success -> - Assert.is_true ~msg:__LOC__ success; + Assert.is_ok ~msg:__LOC__ success ; read_file file >>= fun opt -> - Assert.is_some ~msg:__LOC__ opt; + Assert.is_ok ~msg:__LOC__ opt ; Lwt.return () type t = A of int | B of string | C of int | D of string | E @@ -269,8 +269,8 @@ let test_json_input testdir = |} in Data_encoding_ezjsonm.read_file file >>= function - None -> Assert.fail_msg "Cannot parse \"good.json\"." - | Some json -> + | Error _ -> Assert.fail_msg "Cannot parse \"good.json\"." + | Ok json -> let (id, value, popup) = Json.destruct enc json in Assert.equal_string ~msg:__LOC__ "file" id; Assert.equal_string ~msg:__LOC__ "File" value; @@ -295,8 +295,8 @@ let test_json_input testdir = |} in Data_encoding_ezjsonm.read_file file >>= function - None -> Assert.fail_msg "Cannot parse \"unknown.json\"." - | Some json -> + | Error _ -> Assert.fail_msg "Cannot parse \"unknown.json\"." + | Ok json -> Assert.test_fail ~msg:__LOC__ (fun () -> ignore (Json.destruct enc json)) (function diff --git a/test/test_p2p_connection.ml b/test/test_p2p_connection.ml index 2dda0293a..c0d6dbf19 100644 --- a/test/test_p2p_connection.ml +++ b/test/test_p2p_connection.ml @@ -14,14 +14,13 @@ 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 proof_of_work_target = Crypto_box.make_target 16. 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 []) + Identity.generate (Crypto_box.make_target 0.) let versions = Version.[{ name = "TEST" ; minor = 0 ; major = 0 }] diff --git a/test/test_p2p_connection_pool.ml b/test/test_p2p_connection_pool.ml index bf3e8b20c..4663e9a5e 100644 --- a/test/test_p2p_connection_pool.ml +++ b/test/test_p2p_connection_pool.ml @@ -126,7 +126,7 @@ let run_net config repeat points addr port = 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 proof_of_work_target = Crypto_box.make_target 0. in let identity = Identity.generate proof_of_work_target in let config = P2p_connection_pool.{ identity ; @@ -158,7 +158,7 @@ let make_net points repeat n = let addr = ref Ipaddr.V6.localhost let port = ref (1024 + Random.int 8192) let clients = ref 10 -let repeat = ref 5 +let repeat_connections = ref 5 let spec = Arg.[ @@ -169,7 +169,8 @@ let spec = Arg.[ "--clients", Set_int clients, " Number of concurrent clients." ; - "--repeat", Set_int repeat, " Number of connections/disconnections." ; + "--repeat", Set_int repeat_connections, + " Number of connections/disconnections." ; "-v", Unit (fun () -> Lwt_log_core.(add_rule "p2p.connection-pool" Info)), " Log up to info msgs" ; @@ -181,16 +182,15 @@ let spec = Arg.[ let main () = let open Utils in + Logging.init Stderr >>= fun () -> 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)) + Lwt_list.iter_p (make_net points !repeat_connections) (0 -- (!clients - 1)) let () = Sys.catch_break true ; - try - Logging.init Stderr ; - Lwt_main.run @@ main () + try Lwt_main.run @@ main () with _ -> () diff --git a/test/test_p2p_io_scheduler.ml b/test/test_p2p_io_scheduler.ml index e41fca204..0db147c3d 100644 --- a/test/test_p2p_io_scheduler.ml +++ b/test/test_p2p_io_scheduler.ml @@ -140,7 +140,7 @@ let run ?max_download_speed ?max_upload_speed ~read_buffer_size ?read_queue_size ?write_queue_size addr port time n = - Logging.init Stderr ; + Logging.init Stderr >>= fun () -> listen ?port addr >>= fun (main_socket, port) -> let server = Process.detach ~prefix:"server " begin fun () -> diff --git a/test/test_state.ml b/test/test_state.ml index 4c9c01c2a..c23aab57d 100644 --- a/test/test_state.ml +++ b/test/test_state.ml @@ -39,7 +39,7 @@ let incr_fitness fitness = | [ _ ; fitness ] -> Pervasives.( Data_encoding.Binary.of_bytes Data_encoding.int64 fitness - |> Utils.unopt 0L + |> Utils.unopt ~default:0L |> Int64.succ |> Data_encoding.Binary.to_bytes Data_encoding.int64 )