proxy_server_config.ml
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2021 Nomadic Labs. <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type t = {
endpoint : Uri.t option;
rpc_addr : Uri.t option;
rpc_tls : string option;
sym_block_caching_time : Ptime.span option;
data_dir : string option;
}
let pp ppf {endpoint; rpc_addr; rpc_tls; sym_block_caching_time; data_dir} =
let pp_uri_opt = Format.pp_print_option Uri.pp in
Format.fprintf
ppf
"@[<v>endpoint=%a@,\
rpc_addr=%a@,\
rpc_tls=%a@,\
sym_block_caching_time=%a@,\
data_dir=%a@]"
pp_uri_opt
endpoint
pp_uri_opt
rpc_addr
(Format.pp_print_option Format.pp_print_string)
rpc_tls
(Format.pp_print_option Ptime.Span.pp)
sym_block_caching_time
(Format.pp_print_option Format.pp_print_string)
data_dir
let example_config =
{|{"endpoint": "http://127.0.0.1:18731", "rpc_addr": "http://127.0.0.1:18732", "sym_block_caching_time": 60}|}
let encoding : t Data_encoding.t =
let open Data_encoding in
let of_span s = Option.bind s Ptime.Span.to_int_s in
conv
(fun t ->
( Option.map Uri.to_string t.endpoint,
Option.map Uri.to_string t.rpc_addr,
t.rpc_tls,
Option.map Int32.of_int @@ of_span t.sym_block_caching_time,
t.data_dir ))
(fun (endpoint, rpc_addr, rpc_tls, sym_block_caching_time, data_dir) ->
{
endpoint = Option.map Uri.of_string endpoint;
rpc_addr = Option.map Uri.of_string rpc_addr;
rpc_tls;
sym_block_caching_time =
Option.map
(fun x -> Ptime.Span.of_int_s @@ Int32.to_int x)
sym_block_caching_time;
data_dir;
})
(obj5
(opt "endpoint" string)
(opt "rpc_addr" string)
(opt "rpc_tls" string)
(opt "sym_block_caching_time" int32)
(opt "data_dir" string))
let make ~endpoint ~rpc_addr ~rpc_tls ~sym_block_caching_time ~data_dir : t =
{endpoint; rpc_addr; rpc_tls; sym_block_caching_time; data_dir}
let sym_block_caching_time_error sym_block_caching_time =
match sym_block_caching_time with
| Some sym_block_caching_time
when Ptime.Span.(compare sym_block_caching_time zero <= 0) ->
Some
(Format.asprintf
{|--sym-block-caching-time argument and sym_block_caching_time field must be strictly positive, but found %a|}
Ptime.Span.pp
sym_block_caching_time)
| _ -> None
type 'a destructed = Valid of 'a | Invalid of string | CannotDeserialize
let destruct_config json =
match Data_encoding.Json.destruct encoding json with
| cfg -> (
match sym_block_caching_time_error cfg.sym_block_caching_time with
| Some err -> Invalid err
| None -> Valid cfg)
| exception _ -> CannotDeserialize
let union_right_bias (t1 : t) (t2 : t) =
{
endpoint = Option.either t2.endpoint t1.endpoint;
rpc_addr = Option.either t2.rpc_addr t1.rpc_addr;
rpc_tls = Option.either t2.rpc_tls t1.rpc_tls;
sym_block_caching_time =
Option.either t2.sym_block_caching_time t1.sym_block_caching_time;
data_dir = Option.either t2.data_dir t1.data_dir;
}
type runtime = {
endpoint : Uri.t;
rpc_server_address : P2p_addr.t;
rpc_server_port : int;
rpc_server_tls : (string * string) option;
sym_block_caching_time : Ptime.span option;
data_dir : string option;
}
(** Given the value of the [--rpc-addr] argument (or the [rpc_addr] CONFIG field),
return the address and the port of the server that should be spawned. *)
let address_and_port_for_runtime rpc_addr =
let open Result in
let wrong_rpc_addr looked_for =
error
@@ Format.asprintf
{|Wrong "--rpc-addr" argument or "rpc_addr" field: %a. %s cannot be determined|}
Uri.pp
rpc_addr
looked_for
in
match (Uri.host rpc_addr, Uri.port rpc_addr) with
| None, _ -> wrong_rpc_addr "Hostname"
| _, None -> wrong_rpc_addr "Port"
| Some rpc_server_address, Some rpc_server_port -> (
match P2p_addr.of_string_opt rpc_server_address with
| Some rpc_server_address -> Ok (rpc_server_address, rpc_server_port)
| None ->
error
@@ Format.asprintf
{|Cannot convert hostname of "--rpc-addr" argument or "rpc_addr" field to P2p_addr: %s|}
rpc_server_address)
(** Given the value of the [--rpc-tls] argument (or the [rpc_tls] CONFIG field),
return the paths to the certificate and the key for use by TLS *)
let tls_for_runtime =
let open Result in
let regexp_str = "(.*),(.*)" in
let regexp = Re.compile (Re.Perl.re regexp_str) in
fun rpc_tls ->
match Re.exec_opt regexp rpc_tls with
| None ->
error
@@ Format.asprintf
{|Value of "--rpc-tls" argument or "rpc_tls" field cannot be parsed: %s doesn't match regexp %s|}
rpc_tls
regexp_str
| Some group -> ok (Re.Group.get group 1, Re.Group.get group 2)
(** Helper to lift a validation function [f : 'a -> ('b * _) result] over
an optional value. *)
let opt_res_to_res_opt = function
| None ->
(* No data to validate: no error, no data. *)
Ok None
| Some (Ok x) ->
(* Data was successfully validated: no error, some data. *)
Ok (Some x)
| Some (Error x) ->
(* Data could not be successfully validated: an error and no data *)
Error x
let to_runtime
({endpoint; rpc_addr; rpc_tls; sym_block_caching_time; data_dir} : t) :
(runtime, string) result =
(* Validating sym_block_caching_time is required if it was specified
on the command line. In this case it wasn't validated yet. *)
let open Result_syntax in
match
(endpoint, rpc_addr, sym_block_caching_time_error sym_block_caching_time)
with
| None, _, _ ->
fail
{|Endpoint not specified: pass argument --endpoint or specify "endpoint" field in CONFIG file|}
| _, None, _ ->
fail
{|RPC address not specified: pass argument --rpc-addr or specify "rpc_addr" field in CONFIG file|}
| _, _, Some err -> fail err
| Some endpoint, Some rpc_addr, None ->
let* rpc_server_address, rpc_server_port =
address_and_port_for_runtime rpc_addr
in
let* rpc_server_tls =
Option.map tls_for_runtime rpc_tls |> opt_res_to_res_opt
in
Ok
{
endpoint;
rpc_server_address;
rpc_server_port;
rpc_server_tls;
sym_block_caching_time;
data_dir;
}