Add a helper for cmdliner and happy-eyeballs

Author: dinosaure

mnet-cli.opam

@@ -11,6 +11,7 @@ depends: [
   "utcp"
   "dune" {>= "2.7.0"}
   "mnet" {= version}
+  "duration"
   "dns"
   "tls"
   "cmdliner"

src/dune

@@ -8,7 +8,7 @@
  (name mnet_cli)
  (public_name mnet-cli)
  (modules mnet_cli)
- (libraries ca-certs-nss mirage-ptime.solo5 dns tls cmdliner mnet))
+ (libraries duration ca-certs-nss mirage-ptime.solo5 dns tls cmdliner mnet))
 
 (library
  (name ethernet)

src/mnet_cli.ml

@@ -149,3 +149,97 @@ let setup_nameservers nameservers =
 let setup_nameservers ?default () =
   let open Term in
   const setup_nameservers $ nameservers ?default ()
+
+let error_msgf fmt = Fmt.kstr (fun msg -> Error (`Msg msg)) fmt
+
+let timeout =
+  let is_digit = function '0' .. '9' -> true | _ -> false in
+  let parser str =
+    let len =
+      let len = ref 0 in
+      while !len < String.length str && is_digit str.[!len] do
+        incr len
+      done;
+      !len
+    in
+    let meter = String.sub str len (String.length str - len) in
+    let value = String.sub str 0 len in
+    match meter with
+    | "ns" -> Ok (Int64.of_string value)
+    | "us" -> Ok (Duration.of_us (int_of_string value))
+    | "ms" -> Ok (Duration.of_ms (int_of_string value))
+    | "sec" | "s" -> Ok (Duration.of_sec (int_of_string value))
+    | "min" | "m" -> Ok (Duration.of_min (int_of_string value))
+    | "hour" | "h" -> Ok (Duration.of_hour (int_of_string value))
+    | _ -> error_msgf "Invalid time: %S" str
+  in
+  let parser str =
+    try parser str with _exn -> error_msgf "Invalid time: %S" str
+  in
+  Arg.conv ~docv:"TIME" (parser, Duration.pp)
+
+let s_happy_eyeballs = "HAPPY EYEBALLS"
+
+let aaaa_timeout =
+  let doc = "The timeout applied to the IPv6 resolution." in
+  let open Arg in
+  value
+  & opt timeout (Duration.of_ms 50)
+  & info [ "aaaa-timeout" ] ~doc ~docv:"TIME" ~docs:s_happy_eyeballs
+
+let connect_delay =
+  let doc =
+    "Time to repeat another connection attempt if the others don't respond."
+  in
+  let open Arg in
+  value
+  & opt timeout (Duration.of_ms 50)
+  & info [ "connect-delay" ] ~doc ~docv:"TIME" ~docs:s_happy_eyeballs
+
+let connect_timeout =
+  let doc = "The timeout applied top $(b,connect())." in
+  let open Arg in
+  value
+  & opt timeout (Duration.of_sec 10)
+  & info [ "connect-timeout" ] ~doc ~docv:"TIME" ~docs:s_happy_eyeballs
+
+let resolve_timeout =
+  let doc = "The timeout applied to the domain-name resolution." in
+  let open Arg in
+  value
+  & opt timeout (Duration.of_sec 1)
+  & info [ "resolve-timeout" ] ~doc ~docv:"TIME" ~docs:s_happy_eyeballs
+
+let resolve_retries =
+  let doc = "The number $(i,N) of attempts to make a connection." in
+  let open Arg in
+  value
+  & opt int 3
+  & info [ "resolve-retries" ] ~doc ~docv:"NUMBER" ~docs:s_happy_eyeballs
+
+type happy_eyeballs = {
+    aaaa_timeout: int64
+  ; connect_delay: int64
+  ; connect_timeout: int64
+  ; resolve_timeout: int64
+  ; resolve_retries: int
+}
+
+let setup_happy_eyeballs aaaa_timeout connect_delay connect_timeout
+    resolve_timeout resolve_retries =
+  {
+    aaaa_timeout
+  ; connect_delay
+  ; connect_timeout
+  ; resolve_timeout
+  ; resolve_retries
+  }
+
+let setup_happy_eyeballs =
+  let open Term in
+  const setup_happy_eyeballs
+  $ aaaa_timeout
+  $ connect_delay
+  $ connect_timeout
+  $ resolve_timeout
+  $ resolve_retries

src/mnet_cli.mli

@@ -5,6 +5,7 @@ open Cmdliner
 
 val s_network : Cmdliner.Manpage.section_name
 val s_dns : Cmdliner.Manpage.section_name
+val s_happy_eyeballs : Cmdliner.Manpage.section_name
 
 val ipv4 : Ipaddr.V4.Prefix.t Term.t
 (** [ipv4] defines the [--ipv4] option. This option is required and allows you
@@ -39,3 +40,15 @@ val setup_nameservers :
 (** [setup_nameservers] aggregates {!val:nameservers} and verify if all of them
     use the same protocol (see {!type:Dns.proto}) or not. It fails if one of the
     given nameserver uses a different protocol from the others. *)
+
+type happy_eyeballs = {
+    aaaa_timeout: int64
+  ; connect_delay: int64
+  ; connect_timeout: int64
+  ; resolve_timeout: int64
+  ; resolve_retries: int
+}
+
+val setup_happy_eyeballs : happy_eyeballs Term.t
+(** [setup_happy_eyeballs] aggregates options to configure an Happy Eyeballs
+    instance. *)