unikernel/duniverse/happy-eyeballs/.cirrus.yml

@@ -0,0 +1,22 @@
+freebsd_instance:
+  image_family: freebsd-14-2
+
+freebsd_task:
+  env:
+    matrix:
+      - OCAML_VERSION: 4.13.1
+      - OCAML_VERSION: 4.14.2
+
+  pkg_install_script: pkg install -y ocaml-opam gmp gmake pkgconf bash ca_root_nss
+
+  ocaml_script:
+    - opam init -a --comp=$OCAML_VERSION
+    - opam env
+
+  pin_packages_script:
+    - opam pin add -y -t --with-version=dev happy-eyeballs.opam .
+    - opam pin add -y -t --with-version=dev happy-eyeballs-lwt.opam .
+    - opam pin add -y -t --with-version=dev happy-eyeballs-mirage.opam .
+
+  build_script:
+    - opam exec -- dune build -p happy-eyeballs,happy-eyeballs-lwt,happy-eyeballs-mirage

unikernel/duniverse/happy-eyeballs/CHANGES.md

@@ -0,0 +1,153 @@
+## v2.0.1 (2025-05-14)
+
+* mirage & lwt: provide the appropriate event, Resolved_aaaa_failed, when IPv6
+  resolution failed. This fixes happy-eyeballs being stuck trying a connection
+  (#48 @hannesm)
+
+## v2.0.0 (2025-02-05)
+
+* Use mirage-sleep and mirage-mtime (dune variants) instead of functorising
+  over TIME and MCLOCK
+
+## v1.2.2 (2024-10-10)
+
+* Demote log message for Waiting_for_AAAA and Resolve_a (@reynir, #46)
+
+## v1.2.1 (2024-09-04)
+
+* happy-eyeballs-miou-unix: fix AAAA record (@dinosaure, #45)
+* happy-eyeballs-miou-unix: demote log levels (@dinosaure, #45)
+
+## v1.2.0 (2024-08-23)
+
+* Add the miou implementation of happy-eyeballs (@dinosaure, @hannesm, #41)
+* Fix the CirrusCI (@hannesm, #43)
+
+## v1.1.0 (2024-05-27)
+
+* Allow timeouts and delays in `connect`, `connect_ip`, `connect_host` to
+  overwrite the default from `create` (#42 @hannesm)
+
+## v1.0.0 (2024-05-19)
+
+* Reverse dependency between dns-client-lwt and happy-eyeballs-lwt,
+  dns-client-mirage and happy-eyeballs-mirage (#38 @dinosaure)
+  This now has a new function `inject` to put a name resolver `getaddrinfo`
+  into action. The default for happy-eyeballs-lwt is Lwt_unix.getaddrinfo.
+  For happy-eyeballs-mirage, there is no default.
+* Update timestamp when a fresh connection attempt is done (#37 @hannesm)
+* Log message: prepend with counter to distinguish multiple happy-eyeballs
+  instaces (#36 @hannesm)
+
+## v0.6.0 (2023-06-15)
+
+* Fix connection establishment: parallelize connection attempts, deal with
+  servers dropping packets (such as the Azure DNS resolver)
+* Introduce connect_delay (when to start the next connection attempt)
+* Deal with connect_timeout properly
+* Revise log output (IP vs domain name, fewer logs on debug level)
+
+All in #34, @hannesm, reviewed by @reynir -- sponsored by Semgrep Inc
+
+## v0.5.0 (2023-02-16)
+
+* Adapt to dns-client 7.0.0 packaging changes (#31 @dinosaure)
+
+## v0.4.0 (2022-12-02)
+
+* Cancellation of connection attempts (#30 @reynir @hannesm, fixes #27)
+* Make the type id abstract (suggested by @reynir in #30)
+* Add reason for failures to the variants, improves log output (#30, fixes #7, @hannesm @reynir)
+* Remove log messages about DNS resolution success/failure when there is no
+  awaiting connection (#30, @hannesm)
+* Use the domain name of the fist IP address in connect_ip as identifier (this
+  provides more useful information than the hardcoded "host.invalid") (#29, @hannesm)
+
+## v0.3.1 (2022-11-21)
+
+* Improve documentation for `Happy_eyeballs.timer` (#24, #25 @reynir, review by @hannesm and @bikallem)
+* Demote log levels that are (likely) caused by missing cancellation (#26 @reynir)
+
+## v0.3.0 (2022-03-21)
+
+* Happy_eyeballs_mirage.connect_device: remove int64 argument (timestamp), use
+  monotonic clocks `C.elapsed_ns ()` instead (noticed by @dinosaure)
+
+## v0.2.0 (2022-03-16)
+
+* Happy_eyeballs_mirage: add a module type signature to allow creation of
+  a MirageOS device (#22 @dinosaure)
+* happy-eyeballs-lwt: update to cmdliner 1.1.0 (@hannesm)
+
+## v0.1.3 (2022-01-12)
+
+* Happy_eyeballs.create: add v6_connect_timeout parameter - the amount of
+  nanoseconds (default: 200ms) after which to attempt IPv4 connection
+  establishment. (#21 @hannesm, review by @reynir, issue reported at
+  robur-coop/http-lwt-client#8 by @kit-ty-kate)
+* Happy_eyeballs.create: add resolve_retries - the amount of resolve attempts
+  when a (resolve) timeout occurs (default: 3). (#21 @hannesm, review by
+  @reynir, issue reported at robur-coop/http-lwt-client#8 by @kit-ty-kate)
+
+## v0.1.2 (2021-12-17)
+
+* Happy_eyeballs_{lwt,mirage}: update to tcpip 7.0.0, remove mirage-stack
+  dependency (#20 @dinosaure)
+
+## v0.1.1 (2021-11-18)
+
+* Happy_eyeballs_lwt.create and Happy_eyeballs_mirage.create now take an
+  optional ?happy_eyeballs:Happy_eyeballs.t argument, and also an optional
+  ?dns:Dns_client_lwt.t/DNS.t argument. This avoids the need to forward all
+  potential creation arguments of Happy_eyeballs and DNS. (#19 @hannesm)
+* Fix state machine: if Connecting fails, and resolved is not yet both, return
+  to Resolving (instead of Error) (#13 @hannesm,
+  similar to d0d4ef5ea2aaf2de407ba84742c5648489c47e1f #9)
+* Add a state machine diagram (happy_eyeballs.dot) (#13 @hannesm)
+
+## v0.1.0 (2021-10-27)
+
+* Remove assertion in timer, and fix the code (reported by @dinosaure in #17,
+  fix in #18 by @hannesm, reviewed by @reynir)
+* Support OCaml 4.08 (#18 hannesm, requested in #16 by @smorimoto)
+
+## v0.0.8 (2021-10-20)
+
+* Adapt to dns 6.0.0 API (#15 @hannesm)
+* Drop rresult dependency
+* Avoid deprecated fmt functions, require fmt 0.8.7
+
+## v0.0.7 (2021-09-28)
+
+* Document changes of the return value of timer (#11 @reynir)
+* Pass timeouts as duration into the create functions (#12 @hannesm)
+
+## v0.0.6 (2021-09-21)
+
+* return a variant from timer to indicate whether there are connections pending
+  or the timer can be suspended -- this avoids unnecessary busy work (@reynir)
+* connect_ip: take list of Ipaddr.t and int pairs instead of separate lists.
+  The reason for this change is the dns-client. (@hannesm @reynir)
+
+## v0.0.5 (2021-09-13)
+
+* connect_ip: take an optional shuffle argument and an ordered list of ips to
+  attempt connections to. The reason for this change is that /etc/resolv.conf
+  specifies an ordering. (@hannesm)
+
+## v0.0.4 (2021-09-11)
+
+* Use set from ipaddr (>= 5.2.0) instead providing these (@hannesm)
+
+## v0.0.3 (2021-09-07)
+
+* BUGFIX: Avoid exception if expand_list is called with an empty list (@hannesm)
+
+## v0.0.2 (2021-09-06)
+
+* BUGFIX: Delay connect failure if v6 resolution and connection attempt fails
+  before v4 resolution had a chance to succeed or fail (issue #9). (@hannesm)
+
+## v0.0.1 (2021-08-24)
+
+* Initial release (@hannesm)

unikernel/duniverse/happy-eyeballs/LICENSE.md

@@ -0,0 +1,3 @@
+Permission to use, copy, modify, and distribute this software for any purpose with or without fee is hereby granted, provided that the above copyright notice and this permission notice appear in all copies.
+
+THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

unikernel/duniverse/happy-eyeballs/README.md

@@ -0,0 +1,19 @@
+## happy eyeballs -- connecting to a remote host
+
+[RFC 8305](https://datatracker.ietf.org/doc/html/rfc8305) describes how to
+connect to a remote host, given that the host may have multiple addresses (IPv4
+and IPv6, via DNS A and AAAA resource records), and the local host may have
+connectivity via IPv4 only, IPv6 only, or both. The preference is to use IPv6.
+
+This package implements the given RFC in its core (Happy_eyeballs module).
+In addition, the Happy_eyeballs_lwt is a Lwt implementation using Unix.
+
+The implemented [state machine](https://data.robur.coop/happy_eyeballs.pdf) is
+kept in-sync with the code (source: happy_eyeballs.dot at the root of this
+repository).
+
+It is licensed under the ISC license.
+
+### Installation
+
+`opam install happy-eyeballs happy-eyeballs-lwt happy-eyeballs-mirage`

unikernel/duniverse/happy-eyeballs/app/connect.ml

@@ -0,0 +1,113 @@
+let reporter ppf =
+  let report src level ~over k msgf =
+    let k _ =
+      over () ;
+      k () in
+    let with_metadata header _tags k ppf fmt =
+      Format.kfprintf k ppf
+        ("%a[%a][%a]: " ^^ fmt ^^ "\n%!")
+        Logs_fmt.pp_header (level, header)
+        Fmt.(styled `Cyan int) (Stdlib.Domain.self () :> int)
+        Fmt.(styled `Magenta string)
+        (Logs.Src.name src) in
+    msgf @@ fun ?header ?tags fmt -> with_metadata header tags k ppf fmt in
+  { Logs.report }
+
+let () = Logs_threaded.enable ()
+
+let run quiet domains host port =
+  let host, port = match host, port with
+    | `Domain_name (host, Some port), _port' -> Domain_name.to_string host, port
+    | `Domain_name (host, None), port -> Domain_name.to_string host, port
+    | `Ipaddr (ipaddr, Some port), _port' -> Ipaddr.to_string ipaddr, port
+    | `Ipaddr (ipaddr, None), port -> Ipaddr.to_string ipaddr, port in
+  Miou_unix.run ~domains @@ fun () ->
+  let daemon, t = Happy_eyeballs_miou_unix.create () in
+  begin match Happy_eyeballs_miou_unix.connect t host [ port ] with
+    | Ok ((ipaddr, port), fd) ->
+        Logs.info (fun m -> m "Connected to %a:%d" Ipaddr.pp ipaddr port);
+        if not quiet then Fmt.pr "%a:%d\n%!" Ipaddr.pp ipaddr port;
+        Miou_unix.close fd
+    | Error (`Msg err) ->
+        Logs.err (fun m -> m "%s" err)
+  end;
+  Happy_eyeballs_miou_unix.kill daemon;
+  `Ok 0
+
+open Cmdliner
+
+let verbosity =
+  let env = Cmd.Env.info "CONNECT_LOGS" in
+  Logs_cli.level ~env ()
+
+let renderer =
+  let env = Cmd.Env.info "CONNECT_FMT" in
+  Fmt_cli.style_renderer ~env ()
+
+let utf_8 =
+  let doc = "Allow us to emit UTF-8 characters." in
+  let env = Cmd.Env.info "CONNECT_UTF_8" in
+  Arg.(value & opt bool true & info [ "with-utf-8" ] ~doc ~env)
+
+let setup_logs utf_8 style_renderer level =
+  Fmt_tty.setup_std_outputs ~utf_8 ?style_renderer ();
+  Logs.set_level level;
+  let reporter = reporter Fmt.stderr in
+  Logs.set_reporter reporter;
+  Option.is_none level
+
+let term_setup_logs = Term.(const setup_logs $ utf_8 $ renderer $ verbosity)
+
+let is_digit = function '0' .. '9' -> true | _ -> false
+let error_msgf fmt = Fmt.kstr (fun msg -> Error (`Msg msg)) fmt
+
+let host =
+  let doc = "The host (it can be an IP address or a domain name)." in
+  let host str =
+    let ( let* ) = Result.bind in
+    let domain_name =
+      let sstr = String.split_on_char ':' str in
+      match List.rev sstr with
+      | port :: domain_name when String.for_all is_digit port ->
+        let str = String.concat ":" (List.rev domain_name) in
+        let* domain_name = Domain_name.of_string str in
+        let* domain_name = Domain_name.host domain_name in
+        Ok (domain_name, Some (int_of_string port))
+      | _ ->
+        let* domain_name = Domain_name.of_string str in
+        let* domain_name = Domain_name.host domain_name in
+        Ok (domain_name, None) in
+    let ipaddr =
+      let* ipaddr, port = Ipaddr.with_port_of_string ~default:(-1) str in
+      if port = (-1) then Ok (ipaddr, None) else Ok (ipaddr, Some port) in
+    match domain_name, ipaddr with
+    | Ok a, Error _ -> Ok (`Domain_name a)
+    | Error _, Ok a -> Ok (`Ipaddr a)
+    | Ok a, _ -> Ok (`Domain_name a)
+    | Error _, Error _ -> error_msgf "Invalid host: %S" str in
+  let pp ppf = function
+    | `Domain_name (v, None) -> Domain_name.pp ppf v
+    | `Domain_name (v, Some port) -> Fmt.pf ppf "%a:%d" Domain_name.pp v port
+    | `Ipaddr (v, None) -> Ipaddr.pp ppf v
+    | `Ipaddr (v, Some port) -> Fmt.pf ppf "%a:%d" Ipaddr.pp v port in
+  let host = Arg.conv (host, pp) in
+  Arg.(required & pos 0 (some host) None & info [] ~doc ~docv:"<host>")
+
+let domains =
+  let doc = "The number of domains that we can use." in
+  Arg.(value & opt int 1 & info [ "d"; "domains" ] ~doc)
+
+let port =
+  let doc = "The port where we want to connect." in
+  Arg.(value & opt int 80 & info [ "p"; "port" ] ~doc)
+
+let term = Term.(ret (const run $ term_setup_logs $ domains $ host $ port))
+
+let cmd =
+  let doc = "A simple program which try to connect you to the given service." in
+  let man = [] in
+  Cmd.v (Cmd.info "connect" ~doc ~man) term
+
+let () = exit (Cmd.eval' cmd)
+
+

unikernel/duniverse/happy-eyeballs/app/dune

@@ -0,0 +1,13 @@
+(executable
+ (name test)
+ (public_name happy_eyeballs_client)
+ (modules test)
+ (package happy-eyeballs-lwt)
+ (libraries logs.fmt fmt.cli logs.cli fmt.tty cmdliner happy_eyeballs_lwt))
+
+(executable
+ (name connect)
+ (public_name happy-eyeballs-miou-unix.connect)
+ (modules connect)
+ (package happy-eyeballs-miou-unix)
+ (libraries cmdliner logs.fmt fmt.cli logs.cli logs.threaded fmt.tty happy-eyeballs-miou-unix))

unikernel/duniverse/happy-eyeballs/app/test.ml

@@ -0,0 +1,43 @@
+open Lwt.Infix
+
+let jump () host ports =
+  let t = Happy_eyeballs_lwt.create () in
+  Lwt_main.run (
+    Logs.app (fun m -> m "connecting to %s (on ports %a)" host
+                 Fmt.(list ~sep:(any ", ") int) ports);
+    Happy_eyeballs_lwt.connect t host ports >>= function
+    | Ok ((ip, port), fd) ->
+      Logs.app (fun m -> m "connected to %a:%d" Ipaddr.pp ip port);
+      Lwt_unix.close fd >|= fun () ->
+      Ok ()
+    | Error `Msg msg as e ->
+      Logs.app (fun m -> m "failed to connect %s" msg);
+      Lwt.return e)
+
+let setup_log style_renderer level =
+  Fmt_tty.setup_std_outputs ?style_renderer ();
+  Logs.set_level level;
+  Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ())
+
+open Cmdliner
+
+let setup_log =
+  Term.(const setup_log
+        $ Fmt_cli.style_renderer ()
+        $ Logs_cli.level ())
+
+let host =
+  let doc = "Host to connect to" in
+  Arg.(required & pos 0 (some string) None & info [] ~doc ~docv:"HOST")
+
+let port =
+  let doc = "Ports to connect to" in
+  Arg.(value & opt_all int [443;80] & info [ "port" ] ~doc ~docv:"PORT")
+
+let cmd =
+  let term = Term.(term_result (const jump $ setup_log $ host $ port))
+  and info = Cmd.info "test" ~version:"2.0.1"
+  in
+  Cmd.v info term
+
+let () = exit (Cmd.eval cmd)

unikernel/duniverse/happy-eyeballs/dune-project

@@ -0,0 +1,4 @@
+(lang dune 2.0)
+(name happy-eyeballs)
+(version v2.0.1)
+(formatting disabled)

unikernel/duniverse/happy-eyeballs/happy-eyeballs-lwt.opam

@@ -0,0 +1,36 @@
+version: "2.0.1"
+opam-version: "2.0"
+maintainer: "Robur <team@robur.coop>"
+authors: ["Robur <team@robur.coop>"]
+homepage: "https://github.com/robur-coop/happy-eyeballs"
+dev-repo: "git+https://github.com/robur-coop/happy-eyeballs.git"
+bug-reports: "https://github.com/robur-coop/happy-eyeballs/issues"
+doc: "https://robur-coop.github.io/happy-eyeballs/"
+license: "ISC"
+
+depends: [
+  "ocaml" {>= "4.08.0"}
+  "dune" {>= "2.0.0"}
+  "happy-eyeballs" {=version}
+  "cmdliner" {>= "1.1.0"}
+  "duration"
+  "dns" {>= "7.0.0"}
+  "domain-name"
+  "ipaddr"
+  "fmt"
+  "logs"
+  "lwt"
+  "mtime" {>= "1.0.0"}
+]
+build: [
+  ["dune" "subst"] {dev}
+  ["dune" "build" "-p" name "-j" jobs]
+]
+
+synopsis: "Connecting to a remote host via IP version 4 or 6 using Lwt_unix"
+description: """
+Happy eyeballs is an implementation of RFC 8305 which specifies how to connect
+to a remote host using either IP protocol version 4 or IP protocol version 6.
+This uses Lwt and Lwt_unix for side effects.
+"""
+x-maintenance-intent: [ "(latest)" ]

unikernel/duniverse/happy-eyeballs/happy-eyeballs-miou-unix.opam

@@ -0,0 +1,35 @@
+version: "2.0.1"
+opam-version: "2.0"
+maintainer: "Robur <team@robur.coop>"
+authors: ["Robur <team@robur.coop>"]
+homepage: "https://github.com/robur-coop/happy-eyeballs"
+dev-repo: "git+https://github.com/robur-coop/happy-eyeballs.git"
+bug-reports: "https://github.com/robur-coop/happy-eyeballs/issues"
+doc: "https://robur-coop.github.io/happy-eyeballs/"
+license: "ISC"
+
+depends: [
+  "ocaml" {>= "5.0.0"}
+  "dune" {>= "2.0.0"}
+  "happy-eyeballs" {= version}
+  "miou" {>= "0.2.0"}
+  "mtime" {>= "2.0.0"}
+  "duration"
+  "domain-name"
+  "ipaddr" {>= "5.6.0"}
+  "fmt"
+  "logs" {>= "0.7.0"}
+  "cmdliner" {>= "1.3.0"}
+]
+build: [
+  ["dune" "subst"] {dev}
+  ["dune" "build" "-p" name "-j" jobs]
+]
+
+synopsis: "Connecting to a remote host via IP version 4 or 6 using Miou"
+description: """
+Happy eyeballs is an implementation of RFC 8305 which specifies how to connect
+to a remote host using either IP protocol version 4 or IP protocol version 6.
+This uses Miou for side effects.
+"""
+x-maintenance-intent: [ "(latest)" ]

unikernel/duniverse/happy-eyeballs/happy-eyeballs-mirage.opam

@@ -0,0 +1,36 @@
+version: "2.0.1"
+opam-version: "2.0"
+maintainer: "Robur <team@robur.coop>"
+authors: ["Robur <team@robur.coop>"]
+homepage: "https://github.com/robur-coop/happy-eyeballs"
+dev-repo: "git+https://github.com/robur-coop/happy-eyeballs.git"
+bug-reports: "https://github.com/robur-coop/happy-eyeballs/issues"
+doc: "https://robur-coop.github.io/happy-eyeballs/"
+license: "ISC"
+
+depends: [
+  "ocaml" {>= "4.08.0"}
+  "dune" {>= "2.0.0"}
+  "happy-eyeballs" {=version}
+  "duration"
+  "domain-name"
+  "ipaddr"
+  "fmt"
+  "logs"
+  "lwt"
+  "mirage-mtime" {>= "4.0.0"}
+  "tcpip" {>= "7.0.0"}
+  "mirage-sleep" {>= "4.0.0"}
+]
+build: [
+  ["dune" "subst"] {dev}
+  ["dune" "build" "-p" name "-j" jobs]
+]
+
+synopsis: "Connecting to a remote host via IP version 4 or 6 using Mirage"
+description: """
+Happy eyeballs is an implementation of RFC 8305 which specifies how to connect
+to a remote host using either IP protocol version 4 or IP protocol version 6.
+This uses Lwt and Mirage for side effects.
+"""
+x-maintenance-intent: [ "(latest)" ]

unikernel/duniverse/happy-eyeballs/happy-eyeballs.opam

@@ -0,0 +1,33 @@
+version: "2.0.1"
+opam-version: "2.0"
+maintainer: "Robur <team@robur.coop>"
+authors: ["Robur <team@robur.coop>"]
+homepage: "https://github.com/robur-coop/happy-eyeballs"
+dev-repo: "git+https://github.com/robur-coop/happy-eyeballs.git"
+bug-reports: "https://github.com/robur-coop/happy-eyeballs/issues"
+doc: "https://robur-coop.github.io/happy-eyeballs/"
+license: "ISC"
+
+depends: [
+  "ocaml" {>= "4.08.0"}
+  "dune" {>= "2.0.0"}
+  "duration"
+  "domain-name" {>= "0.2.0"}
+  "ipaddr" {>= "5.2.0"}
+  "fmt" {>= "0.8.7"}
+  "logs"
+]
+build: [
+  ["dune" "subst"] {dev}
+  ["dune" "build" "-p" name "-j" jobs]
+]
+
+synopsis: "Connecting to a remote host via IP version 4 or 6"
+description: """
+Happy eyeballs is an implementation of
+[RFC 8305](https://datatracker.ietf.org/doc/html/rfc8305) which specifies how
+to connect to a remote host using either IP protocol version 4 or IP protocol
+version 6. This is the core of the algorithm in value passing style, with a
+slick dependency cone.
+"""
+x-maintenance-intent: [ "(latest)" ]

unikernel/duniverse/happy-eyeballs/happy_eyeballs.dot

@@ -0,0 +1,35 @@
+digraph G {
+RESOLVING;
+
+WAITING_FOR_AAAA;
+
+CONNECTING;
+
+FAILED;
+SUCCESS;
+
+RESOLVING_none -> WAITING_FOR_AAAA [label="resolved_a"];
+RESOLVING_none -> RESOLVING_v4 [label="resolved_a_failed"];
+RESOLVING_v6 -> CONNECTING [label="resolved_a"];
+
+RESOLVING_none -> CONNECTING [label="resolved_aaaa"];
+RESOLVING_v4 -> CONNECTING [label="resolved_aaaa"];
+RESOLVING_none -> RESOLVING_v6 [label="resolved_aaaa_failed"];
+
+RESOLVING -> FAILED [label="resolve_timeout"];
+RESOLVING_v4 -> FAILED [label="resolved_aaaa_failed, resolve_timeout"];
+RESOLVING_v6 -> FAILED [label="resolved_a_failed, resolve_timeout"];
+
+WAITING_FOR_AAAA -> CONNECTING [label="resolved_aaaa"];
+WAITING_FOR_AAAA -> CONNECTING [label="resolved_aaaa_failed"];
+WAITING_FOR_AAAA -> CONNECTING [label="aaaa_timeout"];
+WAITING_FOR_AAAA -> WAITING_FOR_AAAA [label="resolved_a"];
+WAITING_FOR_AAAA -> WAITING_FOR_AAAA [label="resolved_a_failed"];
+
+CONNECTING -> CONNECTING [label="resolved_a, resolved_a_failed, resolved_aaaa, resolved_aaaa_failed"];
+CONNECTING -> CONNECTING [label="connection_failed, connect_timeout\nmore options available"];
+CONNECTING -> RESOLVING_v6 [label="connection_failed, connect_timeout\nresolving was not both"];
+CONNECTING -> FAILED [label="connection_failed, connect_timeout\nno more options"];
+
+CONNECTING -> SUCCESS [label="connected"];
+}

unikernel/duniverse/happy-eyeballs/lwt/dune

@@ -0,0 +1,4 @@
+(library
+ (name happy_eyeballs_lwt)
+ (public_name happy-eyeballs-lwt)
+ (libraries logs lwt mtime.clock.os ipaddr.unix lwt.unix happy-eyeballs))

unikernel/duniverse/happy-eyeballs/lwt/happy_eyeballs_lwt.ml

@@ -0,0 +1,273 @@
+(* Lwt tasks are spawned:
+ - create starts an asynchronous timer task
+ - the actions resulting from timer are scheduled in one separate task
+ - the actions returned from Happy_eyeballs.connect/event are scheduled in
+   respective separate tasks
+*)
+
+let src = Logs.Src.create "happy-eyeballs.lwt" ~doc:"Happy Eyeballs Lwt"
+module Log = (val Logs.src_log src : Logs.LOG)
+
+let now = Mtime_clock.elapsed_ns
+
+type getaddrinfo = [ `A | `AAAA ] -> [ `host ] Domain_name.t -> (Ipaddr.Set.t, [ `Msg of string ]) result Lwt.t
+
+type t = {
+  mutable waiters : ((Ipaddr.t * int) * Lwt_unix.file_descr, [ `Msg of string ]) result Lwt.u Happy_eyeballs.Waiter_map.t ;
+  mutable cancel_connecting : (int * unit Lwt.u) list Happy_eyeballs.Waiter_map.t;
+  mutable he : Happy_eyeballs.t ;
+  timer_interval : float ;
+  timer_condition : unit Lwt_condition.t ;
+  counter : int ;
+  mutable getaddrinfo : getaddrinfo ;
+}
+
+let _cnt = ref 0
+
+let inject t getaddrinfo =
+  incr _cnt;
+  t.getaddrinfo <- getaddrinfo;
+  if !_cnt > 1 then
+    Log.warn (fun m -> m "inject was called the %u times" !_cnt)
+
+let safe_close fd =
+  if Lwt_unix.state fd = Lwt_unix.Closed then
+    Lwt.return_unit
+  else
+    Lwt_unix.close fd
+
+let try_connect ip port =
+  let open Lwt_result.Infix in
+  let fd =
+    let fam = match ip with
+      | Ipaddr.V4 _ -> Lwt_unix.PF_INET
+      | Ipaddr.V6 _ -> Lwt_unix.PF_INET6
+    in
+    Lwt_unix.(socket fam SOCK_STREAM 0)
+  in
+  Lwt.catch
+    (fun () ->
+       let addr = Lwt_unix.ADDR_INET (Ipaddr_unix.to_inet_addr ip, port) in
+       Lwt_result.ok (Lwt_unix.connect fd addr) >|= fun () ->
+       fd)
+    (fun e ->
+       Lwt_result.ok (safe_close fd) >>= fun () ->
+       Lwt_result.fail (`Msg ("connect failure: " ^ Printexc.to_string e)))
+
+let rec act t action =
+  let open Lwt.Infix in
+  Log.debug (fun m -> m "[%u] action %a" t.counter
+                Happy_eyeballs.pp_action action);
+  begin
+    match action with
+    | Happy_eyeballs.Resolve_a host | Happy_eyeballs.Resolve_aaaa host ->
+      begin
+        let record = match action with
+          | Happy_eyeballs.Resolve_a _ -> `A
+          | Happy_eyeballs.Resolve_aaaa _ -> `AAAA
+          | _ -> assert false (* never occur! *)
+        in
+        t.getaddrinfo record host >|= fun res ->
+        match res, record with
+        | Ok set, `A ->
+          let fold ip set = match ip with
+            | Ipaddr.V4 ipv4 -> Ipaddr.V4.Set.add ipv4 set
+            | Ipaddr.V6 ipv6 ->
+              Log.warn (fun m -> m "received the IPv6 address %a querying A of %a (ignoring)"
+                           Ipaddr.V6.pp ipv6 Domain_name.pp host);
+              set
+          in
+          Ok (Happy_eyeballs.Resolved_a (host, Ipaddr.Set.fold fold set Ipaddr.V4.Set.empty))
+        | Ok set, `AAAA ->
+          let fold ip set = match ip with
+            | Ipaddr.V6 ipv6 -> Ipaddr.V6.Set.add ipv6 set
+            | Ipaddr.V4 ipv4 ->
+              Log.warn (fun m -> m "received the IPv4 address %a querying AAAA of %a (ignoring)"
+                           Ipaddr.V4.pp ipv4 Domain_name.pp host);
+              set
+          in
+          Ok (Happy_eyeballs.Resolved_aaaa (host, Ipaddr.Set.fold fold set Ipaddr.V6.Set.empty))
+        | Error `Msg msg, `A ->
+          Ok (Happy_eyeballs.Resolved_a_failed (host, msg))
+        | Error `Msg msg, `AAAA ->
+          Ok (Happy_eyeballs.Resolved_aaaa_failed (host, msg))
+      end
+    | Happy_eyeballs.Connect (host, id, attempt, (ip, port)) ->
+      begin
+        let cancelled, cancel = Lwt.task () in
+        let entry = attempt, cancel in
+        t.cancel_connecting <-
+          Happy_eyeballs.Waiter_map.update id
+            (function None -> Some [ entry ] | Some c -> Some (entry :: c))
+            t.cancel_connecting;
+        let conn =
+          try_connect ip port >>= function
+          | Ok fd ->
+            let cancel_connecting, others =
+              Happy_eyeballs.Waiter_map.find_and_remove id t.cancel_connecting
+            in
+            t.cancel_connecting <- cancel_connecting;
+            List.iter (fun (att, w) -> if att <> attempt then Lwt.wakeup_later w ())
+              (Option.value ~default:[] others);
+            let waiters, r = Happy_eyeballs.Waiter_map.find_and_remove id t.waiters in
+            t.waiters <- waiters;
+            begin match r with
+              | Some waiter ->
+                Lwt.wakeup_later waiter (Ok ((ip, port), fd));
+                Lwt.return (Ok (Happy_eyeballs.Connected (host, id, (ip, port))))
+              | None ->
+                (* waiter already vanished *)
+                safe_close fd >>= fun () ->
+                Lwt.return (Error ())
+            end
+          | Error `Msg msg ->
+            t.cancel_connecting <-
+              Happy_eyeballs.Waiter_map.update id
+                (function None -> None | Some c ->
+                  match List.filter (fun (att, _) -> not (att = attempt)) c with
+                  | [] -> None
+                  | c -> Some c)
+                t.cancel_connecting;
+            Lwt.return (Ok (Happy_eyeballs.Connection_failed (host, id, (ip, port), msg)))
+        in
+        Lwt.pick [ conn; (cancelled >|= fun () -> Error ()); ]
+      end
+    | Happy_eyeballs.Connect_failed (host, id, msg) ->
+      let cancel_connecting, others =
+        Happy_eyeballs.Waiter_map.find_and_remove id t.cancel_connecting
+      in
+      t.cancel_connecting <- cancel_connecting;
+      List.iter (fun (_, w) -> Lwt.wakeup_later w ()) (Option.value ~default:[] others);
+      let waiters, r = Happy_eyeballs.Waiter_map.find_and_remove id t.waiters in
+      t.waiters <- waiters;
+      begin match r with
+        | Some waiter ->
+          let err =
+            Fmt.str "connection to %s failed: %s"
+              (match Ipaddr.of_domain_name host with
+               | None -> Domain_name.to_string host
+               | Some ip -> Ipaddr.to_string ip)
+              msg
+          in
+          Lwt.wakeup_later waiter (Error (`Msg err));
+          Lwt.return (Error ())
+        | None ->
+          (* waiter already vanished *)
+          Lwt.return (Error ())
+      end
+  end >>= function
+  | Error () -> Lwt.return_unit
+  | Ok ev ->
+    let he, actions = Happy_eyeballs.event t.he (now ()) ev in
+    t.he <- he;
+    Lwt_list.iter_p (act t) actions
+
+let handle_timer_actions t actions =
+  Lwt.async (fun () -> Lwt_list.iter_p (fun a -> act t a) actions)
+
+let rec timer t =
+  let open Lwt.Infix in
+  let rec loop () =
+    let he, cont, actions = Happy_eyeballs.timer t.he (now ()) in
+    t.he <- he ;
+    handle_timer_actions t actions ;
+    match cont with
+    | `Suspend ->
+      timer t
+    | `Act ->
+      Lwt_unix.sleep t.timer_interval >>= fun () ->
+      loop ()
+  in
+  Lwt_condition.wait t.timer_condition >>= fun () ->
+  loop ()
+
+let ctr = ref 0
+let error_msgf fmt = Fmt.kstr (fun msg -> Error (`Msg msg)) fmt
+
+let getaddrinfo record domain_name =
+  let open Lwt.Infix in
+  let getaddrinfo_option = match record with
+    | `A -> [ Unix.AI_FAMILY Unix.PF_INET ]
+    | `AAAA -> [ Unix.AI_FAMILY Unix.PF_INET6 ] in
+  let getaddrinfo_option = Unix.AI_SOCKTYPE Unix.SOCK_STREAM :: getaddrinfo_option in
+  Lwt.catch
+    (fun () -> Lwt_unix.getaddrinfo (Domain_name.to_string domain_name) "" getaddrinfo_option >|= fun r -> Ok r)
+    (fun exn -> Lwt.return (Error exn)) >|= function
+  | Error exn -> error_msgf "while resolving %a, ran into exception %s" Domain_name.pp domain_name
+                   (Printexc.to_string exn)
+  | Ok [] -> error_msgf "%a not found" Domain_name.pp domain_name
+  | Ok addrs ->
+    let set = List.fold_left (fun set { Unix.ai_addr; _ } -> match ai_addr with
+      | Unix.ADDR_INET (inet_addr, _) -> Ipaddr.Set.add (Ipaddr_unix.of_inet_addr inet_addr) set
+      | Unix.ADDR_UNIX _ -> set)
+      Ipaddr.Set.empty addrs in
+    Ok set
+
+let create ?(happy_eyeballs = Happy_eyeballs.create (now ())) ?(getaddrinfo= getaddrinfo)
+  ?(timer_interval = Duration.of_ms 10) () =
+  let waiters = Happy_eyeballs.Waiter_map.empty
+  and cancel_connecting = Happy_eyeballs.Waiter_map.empty
+  and timer_condition = Lwt_condition.create ()
+  in
+  let timer_interval = Duration.to_f timer_interval in
+  incr ctr;
+  let t = { waiters ; cancel_connecting ; he = happy_eyeballs ; getaddrinfo ; timer_interval ; timer_condition ; counter = !ctr } in
+  Lwt.async (fun () -> timer t);
+  t
+
+let handle_actions t actions =
+  List.iter (fun a -> Lwt.async (fun () -> act t a)) actions
+
+let connect_host t ?aaaa_timeout ?connect_delay ?connect_timeout
+    ?resolve_timeout ?resolve_retries host ports =
+  let waiter, notify = Lwt.task () in
+  let waiters, id = Happy_eyeballs.Waiter_map.register notify t.waiters in
+  t.waiters <- waiters;
+  let ts = now () in
+  let he, actions =
+    Happy_eyeballs.connect t.he ts ?aaaa_timeout ?connect_delay ?connect_timeout
+      ?resolve_timeout ?resolve_retries ~id host ports
+  in
+  t.he <- he;
+  Lwt_condition.signal t.timer_condition ();
+  handle_actions t actions;
+  let open Lwt.Infix in
+  waiter >|= fun r ->
+  Log.debug (fun m -> m "[%u] connection %s to %a after %a"
+                t.counter (match r with Ok _ -> "ok" | Error _ -> "failed")
+                Domain_name.pp host Duration.pp (Int64.sub (now ()) ts));
+  r
+
+let connect_ip t ?aaaa_timeout ?connect_delay ?connect_timeout addresses =
+  let waiter, notify = Lwt.task () in
+  let waiters, id = Happy_eyeballs.Waiter_map.register notify t.waiters in
+  t.waiters <- waiters;
+  let ts = now () in
+  let he, actions =
+    Happy_eyeballs.connect_ip t.he ts ?aaaa_timeout ?connect_delay
+      ?connect_timeout ~id addresses
+  in
+  t.he <- he;
+  Lwt_condition.signal t.timer_condition ();
+  handle_actions t actions;
+  let open Lwt.Infix in
+  waiter >|= fun r ->
+  Log.debug (fun m -> m "[%u] connection %s to %a after %a"
+                t.counter (match r with Ok _ -> "ok" | Error _ -> "failed")
+                Fmt.(list ~sep:(any ", ") (pair ~sep:(any ":") Ipaddr.pp int))
+                addresses
+                Duration.pp (Int64.sub (now ()) ts));
+  r
+
+let connect t ?aaaa_timeout ?connect_delay ?connect_timeout
+    ?resolve_timeout ?resolve_retries host ports =
+  match Ipaddr.of_string host with
+  | Ok ip ->
+    connect_ip t ?aaaa_timeout ?connect_delay ?connect_timeout
+      (List.map (fun p -> (ip, p)) ports)
+  | Error _ ->
+    let open Lwt_result.Infix in
+    Lwt_result.lift
+      (Result.bind (Domain_name.of_string host) Domain_name.host) >>= fun h ->
+    connect_host t ?aaaa_timeout ?connect_delay ?connect_timeout
+      ?resolve_timeout ?resolve_retries h ports

unikernel/duniverse/happy-eyeballs/lwt/happy_eyeballs_lwt.mli

@@ -0,0 +1,62 @@
+(** The type of the abstract state of happy eyeballs. *)
+type t
+
+type getaddrinfo = [ `A | `AAAA ] -> [ `host ] Domain_name.t -> (Ipaddr.Set.t, [ `Msg of string ]) result Lwt.t
+
+val create : ?happy_eyeballs:Happy_eyeballs.t ->
+  ?getaddrinfo:getaddrinfo ->
+  ?timer_interval:int64 -> unit -> t
+(** [create ~happy_eyeballs ~getaddrinfo ~timer_interval ()] creates an initial
+    state of happy eyeballs with the specified timeouts in nanoseconds - the
+    default for [timer_interval] is [Duration.of_ms 10]. *)
+
+val connect_host : t -> ?aaaa_timeout:int64 -> ?connect_delay:int64 ->
+  ?connect_timeout:int64 -> ?resolve_timeout:int64 -> ?resolve_retries:int ->
+  [`host] Domain_name.t -> int list ->
+  ((Ipaddr.t * int) * Lwt_unix.file_descr, [ `Msg of string ]) result Lwt.t
+(** [connect_host t host ports] establishes a connection to [host] on [ports]
+    (tried in sequence). The timeouts and delays are specified in nanoseconds,
+    and are by default the values defined when constructing [t].
+
+    @raise Failure if [ports] is empty. *)
+
+val connect_ip : t -> ?aaaa_timeout:int64 -> ?connect_delay:int64 ->
+  ?connect_timeout:int64 -> (Ipaddr.t * int) list ->
+  ((Ipaddr.t * int) * Lwt_unix.file_descr, [ `Msg of string ]) result Lwt.t
+(** [connect_ip t addresses] establishes a connection to [addresses]. The
+    timeouts and delays are specified in nanoseconds, and are by default the
+    values defined when constructing [t].
+
+    @raise Failure if [addresses] is the empty list. *)
+
+val connect : t -> ?aaaa_timeout:int64 -> ?connect_delay:int64 ->
+  ?connect_timeout:int64 -> ?resolve_timeout:int64 -> ?resolve_retries:int ->
+  string -> int list ->
+  ((Ipaddr.t * int) * Lwt_unix.file_descr, [ `Msg of string ]) result Lwt.t
+(** [connect t host ports] establishes a connection to [host] on [ports], which
+    may be a host name, or an IP address. The timeouts and delays are specified
+    in nanoseconds, and are by default the values defined when constructing [t].
+
+    @raise Failure if [ports] is the empty list. *)
+
+val inject : t -> getaddrinfo -> unit
+(** [inject t getaddrinfo] injects a {i new} domain-name resolver into the given
+    happy-eyeballs instance. By default, the happy-eyeballs instance use
+    {!val:Lwt_unix.getaddrinfo} to be able to resolve domain-name. However, the
+    user can choose to use its own implementation of a DNS resolver (like
+    [ocaml-dns]).
+
+    So, the {i ceremony} for using happy-eyeballs with your own DNS resolver is
+    to create a happy-eyeballs instance, obtain an instance that can resolve
+    domain names (such as [ocaml-dns]) and inject the latter's implementation
+    into our first happy-eyeballs instance:
+
+    {[
+      let _ =
+        let dns = Dns_client_lwt.create () in
+        let happy_eyeballs = Dns_client_lwt.create_happy_eyeballs dns in
+        Happy_eyeballs_lwt.connect happy_eyeballs "robur.coop" [ 443 ]
+        >>= function
+        | Ok (_, fd) -> ...
+        | Error _ -> ...
+    ]} *)

unikernel/duniverse/happy-eyeballs/miou/dune

@@ -0,0 +1,9 @@
+(library
+ (name happy_eyeballs_miou_unix)
+ (modules happy_eyeballs_miou_unix)
+ (public_name happy-eyeballs-miou-unix)
+ (libraries
+  miou.unix
+  mtime.clock.os
+  ipaddr.unix
+  happy-eyeballs))

unikernel/duniverse/happy-eyeballs/miou/happy_eyeballs_miou_unix.ml

@@ -0,0 +1,455 @@
+let src_daemon = Logs.Src.create "happy-daemon"
+
+module Logd = (val Logs.src_log src_daemon : Logs.LOG)
+
+let src_client = Logs.Src.create "happy"
+
+module Logc = (val Logs.src_log src_client : Logs.LOG)
+
+let error_msgf fmt = Format.kasprintf (fun msg -> Error (`Msg msg)) fmt
+
+let pp_sockaddr ppf = function
+  | Unix.ADDR_UNIX str -> Format.fprintf ppf "<%s>" str
+  | Unix.ADDR_INET (inet_addr, port) ->
+      Format.fprintf ppf "%s:%u" (Unix.string_of_inet_addr inet_addr) port
+
+let to_sockaddr (ipaddr, port) =
+  Unix.ADDR_INET (Ipaddr_unix.to_inet_addr ipaddr, port)
+
+let clock = Mtime_clock.elapsed_ns
+
+[@@@warning "-30"]
+
+type state = ((Ipaddr.t * int) * Unix.file_descr) Miou.Computation.t
+
+and entry = Happy_eyeballs.id * attempt * [ `host ] Domain_name.t * addr
+and attempt = int
+and addr = Ipaddr.t * int
+and cancel = attempt * unit Miou.t
+and connect_ip =
+  { aaaa_timeout : int64 option
+  ; connect_delay : int64 option
+  ; connect_timeout : int64 option
+  ; state : state
+  ; addrs : addr list }
+and connect =
+  { aaaa_timeout : int64 option
+  ; connect_delay : int64 option
+  ; connect_timeout : int64 option
+  ; resolve_timeout : int64 option
+  ; resolve_retries : int option
+  ; state : state
+  ; host : [ `host ] Domain_name.t
+  ; ports : int list }
+and action =
+  [ `Connect_ip of connect_ip
+  | `Connect of connect ]
+and connected = [ `Connected of entry * Miou_unix.Ownership.file_descr ]
+
+type event =
+  [ connected
+  | `Connection_failed of entry * string
+  | `Resolution_v4 of
+    [ `host ] Domain_name.t * (Ipaddr.V4.Set.t, [ `Msg of string ]) result
+  | `Resolution_v6 of
+    [ `host ] Domain_name.t * (Ipaddr.V6.Set.t, [ `Msg of string ]) result ]
+and getaddrinfo = [ `A | `AAAA ] -> [ `host ] Domain_name.t -> (Ipaddr.Set.t, [ `Msg of string ]) result
+
+[@@@warning "+30"]
+
+let getaddrinfo record domain_name =
+  Logd.debug (fun m -> m "Resolve %a via the system's resolver" Domain_name.pp domain_name);
+  let opt = match record with
+    | `A -> [ Unix.AI_FAMILY Unix.PF_INET ]
+    | `AAAA -> [ Unix.AI_FAMILY Unix.PF_INET6 ] in
+  let opt = Unix.AI_SOCKTYPE Unix.SOCK_STREAM :: opt in
+  match Unix.getaddrinfo (Domain_name.to_string domain_name) "" opt with
+  | [] -> error_msgf "%a not found" Domain_name.pp domain_name
+  | addrs ->
+    let set = List.fold_left (fun set { Unix.ai_addr; _ } -> match ai_addr with
+      | Unix.ADDR_INET (inet_addr, _) -> Ipaddr.Set.add (Ipaddr_unix.of_inet_addr inet_addr) set
+      | Unix.ADDR_UNIX _ -> set) Ipaddr.Set.empty addrs in
+    if Ipaddr.Set.is_empty set
+    then error_msgf "%a not found as an inet service" Domain_name.pp domain_name
+    else Ok set
+
+type t = {
+    mutable cancel_connecting: cancel list Happy_eyeballs.Waiter_map.t
+  ; mutable waiters: state Happy_eyeballs.Waiter_map.t
+  ; condition: Miou.Condition.t
+  ; mutex: Miou.Mutex.t
+  ; queue: [ action | event ] Miou.Queue.t
+  ; mutable set : bool
+  ; mutable getaddrinfo: getaddrinfo
+  ; timer_interval : float
+}
+
+let create timer_interval getaddrinfo =
+  {
+    cancel_connecting= Happy_eyeballs.Waiter_map.empty
+  ; waiters= Happy_eyeballs.Waiter_map.empty
+  ; condition= Miou.Condition.create ()
+  ; mutex= Miou.Mutex.create ()
+  ; queue= Miou.Queue.create ()
+  ; set= false
+  ; getaddrinfo
+  ; timer_interval
+  }
+
+let try_connect t ~meta addr () =
+  let id, attempt, _, _ = meta in
+  let addr = to_sockaddr addr in
+  Logd.debug (fun m ->
+      m "connect to %a (%d:%d)" pp_sockaddr addr (Obj.magic id) attempt);
+  let socket =
+    match Unix.domain_of_sockaddr addr with
+    | Unix.PF_UNIX ->
+      let socket = Unix.socket ~cloexec:true Unix.PF_UNIX Unix.SOCK_STREAM 0 in
+      Miou_unix.Ownership.of_file_descr socket
+    | Unix.PF_INET -> Miou_unix.Ownership.tcpv4 ()
+    | Unix.PF_INET6 -> Miou_unix.Ownership.tcpv6 ()
+  in
+  try
+    Miou_unix.Ownership.connect socket addr;
+    Logd.debug (fun m ->
+        m "connected to %a (%d:%d)" pp_sockaddr addr (Obj.magic id) attempt);
+    Miou.Ownership.transfer (Miou_unix.Ownership.resource socket);
+    Miou.Mutex.protect t.mutex @@ fun () ->
+    Miou.Queue.enqueue t.queue (`Connected (meta, socket));
+    Miou.Condition.signal t.condition
+  with Unix.Unix_error (err, _, _) ->
+    Logd.debug (fun m ->
+        m "error connecting to %a: %s" pp_sockaddr addr (Unix.error_message err));
+    Miou_unix.Ownership.close socket;
+    let msg =
+      Fmt.str "error connecting to %a: %s" pp_sockaddr addr
+        (Unix.error_message err)
+    in
+    Miou.Mutex.protect t.mutex @@ fun () ->
+    Miou.Queue.enqueue t.queue (`Connection_failed (meta, msg));
+    Miou.Condition.signal t.condition
+
+let connect t ~prms:orphans host id attempt addr =
+  let meta = (id, attempt, host, addr) in
+  Logd.debug (fun m ->
+      m "connect to %a (%d:%d)" Domain_name.pp host (Obj.magic id) attempt);
+  let prm : unit Miou.t = Miou.async ~orphans (try_connect t ~meta addr) in
+  let entry = (attempt, prm) in
+  t.cancel_connecting <-
+    Happy_eyeballs.Waiter_map.update id
+      (function None -> Some [ entry ] | Some cs -> Some (entry :: cs))
+      t.cancel_connecting
+
+exception Connection_failed of [ `host ] Domain_name.t * string
+
+let empty_bt = Printexc.get_callstack 0
+let connection_failed host reason =
+  Connection_failed (host, reason), empty_bt
+
+let handle_one_action t ~prms action =
+  match action with
+  | Happy_eyeballs.Connect (host, id, attempt, addr) ->
+      connect t ~prms host id attempt addr
+  | Happy_eyeballs.Connect_failed (host, id, reason) ->
+      Logd.debug (fun m ->
+          m "connection to %a failed: %s" Domain_name.pp host reason);
+      let cancel_connecting, others =
+        Happy_eyeballs.Waiter_map.find_and_remove id t.cancel_connecting
+      in
+      t.cancel_connecting <- cancel_connecting;
+      List.iter
+        (fun (_, prm) -> Miou.cancel prm)
+        (Option.value ~default:[] others);
+      (* clean waiter *)
+      let waiters, waiter =
+        Happy_eyeballs.Waiter_map.find_and_remove id t.waiters
+      in
+      t.waiters <- waiters;
+      let trans waiter =
+        let err = connection_failed host reason in
+        ignore (Miou.Computation.try_cancel waiter err) in
+      Option.iter trans waiter
+  | Happy_eyeballs.(Resolve_a host | Resolve_aaaa host) ->
+      let record = match action with
+        | Happy_eyeballs.Resolve_a _ -> `A
+        | Happy_eyeballs.Resolve_aaaa _ -> `AAAA
+        | _ -> assert false in
+      let _ =
+        Miou.async ~orphans:prms @@ fun () ->
+        match t.getaddrinfo record host with
+        | Ok result ->
+          let ipv4, ipv6 = Ipaddr.Set.fold (fun ip (ipv4, ipv6) -> match ip with
+            | Ipaddr.V4 v -> Ipaddr.V4.Set.add v ipv4, ipv6
+            | Ipaddr.V6 v -> ipv4, Ipaddr.V6.Set.add v ipv6)
+            result Ipaddr.(V4.Set.empty, V6.Set.empty) in
+          let result = match record with
+            | `A ->
+                if Ipaddr.V4.Set.is_empty ipv4
+                then `Resolution_v4 (host, error_msgf "%a unreachable via IPv4" Domain_name.pp host)
+                else `Resolution_v4 (host, Ok ipv4)
+            | `AAAA ->
+                if Ipaddr.V6.Set.is_empty ipv6
+                then `Resolution_v6 (host, error_msgf "%a unreachable via IPv6" Domain_name.pp host)
+                else `Resolution_v6 (host, Ok ipv6) in
+          Miou.Mutex.protect t.mutex @@ fun () ->
+          Miou.Queue.enqueue t.queue result;
+          Miou.Condition.signal t.condition
+        | Error err ->
+          let result = match record with
+            | `A -> `Resolution_v4 (host, Error err)
+            | `AAAA -> `Resolution_v6 (host, Error err) in
+          Miou.Mutex.protect t.mutex @@ fun () ->
+          Miou.Queue.enqueue t.queue result;
+          Miou.Condition.signal t.condition
+      in
+      ()
+
+let to_event t = function
+  | `Connection_failed ((id, attempt, host, addr), msg) ->
+      let fold = function
+        | None -> None
+        | Some cs -> (
+            match List.filter (fun (att, _) -> not (att = attempt)) cs with
+            | [] -> None
+            | cs -> Some cs)
+      in
+      t.cancel_connecting <-
+        Happy_eyeballs.Waiter_map.update id fold t.cancel_connecting;
+      Happy_eyeballs.Connection_failed (host, id, addr, msg)
+  | `Connected ((id, attempt, host, addr), fd) ->
+      let cancel_connecting, others =
+        Happy_eyeballs.Waiter_map.find_and_remove id t.cancel_connecting
+      in
+      t.cancel_connecting <- cancel_connecting;
+      List.iter
+        (fun (att, prm) -> if att <> attempt then Miou.cancel prm)
+        (Option.value ~default:[] others);
+      let waiters, waiter = Happy_eyeballs.Waiter_map.find_and_remove id t.waiters in
+      t.waiters <- waiters;
+      let () =
+        match waiter with
+        | None ->
+            Logd.debug (fun m -> m "Loose a connected socket to %a (%a) (%d:%d)" Domain_name.pp host
+              pp_sockaddr (to_sockaddr addr) (Obj.magic id) attempt);
+            Miou_unix.Ownership.close fd
+        | Some waiter ->
+            (* NOTE(dinosaure): the task is suspended **before** [disown]. If a
+               cancellation appear, [disown] is **not** executed and Miou
+               properly close [fd]. If we are able to [disown], the
+               responsability to close the [fd] falls to the person who
+               requested the socket if we are able to transfer it. Otherwise,
+               we just [Unix.close]. *)
+            Miou.Ownership.disown (Miou_unix.Ownership.resource fd);
+            let fd = Miou_unix.Ownership.to_file_descr fd in
+            let set = Miou.Computation.try_return waiter (addr, fd) in
+            Logd.debug (fun m -> m "file-descr transmitted? %b" set);
+            if not set then Unix.close fd
+      in
+      Logd.debug (fun m ->
+          m "connected to %a (%a) (%d:%d)" Domain_name.pp host pp_sockaddr
+            (to_sockaddr addr) (Obj.magic id) attempt);
+      Happy_eyeballs.Connected (host, id, addr)
+  | `Resolution_v4 (host, Ok ips) ->
+      Logd.debug (fun m -> m "%a resolved" Domain_name.pp host);
+      Happy_eyeballs.Resolved_a (host, ips)
+  | `Resolution_v4 (host, Error (`Msg msg)) ->
+      Logd.debug (fun m ->
+          m "impossible to resolve %a: %s" Domain_name.pp host msg);
+      Happy_eyeballs.Resolved_a_failed (host, msg)
+  | `Resolution_v6 (host, Ok ips) ->
+      Logd.debug (fun m -> m "%a resolved" Domain_name.pp host);
+      Happy_eyeballs.Resolved_aaaa (host, ips)
+  | `Resolution_v6 (host, Error (`Msg msg)) ->
+      Logd.debug (fun m ->
+          m "impossible to resolve %a: %s" Domain_name.pp host msg);
+      Happy_eyeballs.Resolved_aaaa_failed (host, msg)
+
+let to_actions t he user's_actions =
+  let fold (he, actions) = function
+    | `Connect_ip { aaaa_timeout
+                  ; connect_delay
+                  ; connect_timeout
+                  ; state
+                  ; addrs } ->
+        let waiters, id = Happy_eyeballs.Waiter_map.register state t.waiters in
+        t.waiters <- waiters;
+        let he, actions' = Happy_eyeballs.connect_ip he (clock ())
+          ?aaaa_timeout ?connect_delay ?connect_timeout ~id addrs in
+        (he, actions @ actions')
+    | `Connect { aaaa_timeout
+               ; connect_delay
+               ; connect_timeout
+               ; resolve_timeout
+               ; resolve_retries
+               ; state
+               ; host
+               ; ports } ->
+        let waiters, id = Happy_eyeballs.Waiter_map.register state t.waiters in
+        t.waiters <- waiters;
+        let he, actions' = Happy_eyeballs.connect he (clock ())
+          ?aaaa_timeout ?connect_delay ?connect_timeout ?resolve_timeout ?resolve_retries
+          ~id host ports
+        in
+        (he, actions @ actions')
+  in
+  List.fold_left fold (he, []) user's_actions
+
+let await_actions_or_events t () =
+  Miou.Mutex.protect t.mutex @@ fun () ->
+  while Miou.Queue.is_empty t.queue do
+    Miou.Condition.wait t.condition t.mutex
+  done
+
+exception Timeout
+
+let with_timeout ~timeout:ts fn =
+  let timeout () = Miou_unix.sleep ts; raise Timeout in
+  let prm1 = Miou.async timeout in
+  let prm0 = Miou.async fn in
+  Miou.await_first [ prm0; prm1 ]
+
+let continue t cont he =
+  let fn () = match cont with
+    | `Act -> with_timeout ~timeout:t.timer_interval  (await_actions_or_events t)
+    | `Suspend ->
+      try Ok (await_actions_or_events t ())
+      with exn -> Error exn in
+  match fn () with
+  | Error Timeout -> (he, [], [])
+  | Ok () ->
+      let user's_actions_and_events = Miou.Queue.(to_list (transfer t.queue)) in
+      Logd.debug (fun m ->
+          m "got %d actions or events" (List.length user's_actions_and_events));
+      let user's_actions, events =
+        List.partition_map
+          (function
+            | #action as action -> Either.Left action
+            | #event as event -> Either.Right event)
+          user's_actions_and_events
+      in
+      Logd.debug (fun m ->
+          m "got %d actions and %d events"
+            (List.length user's_actions)
+            (List.length events));
+      let he, actions = to_actions t he user's_actions in
+      (he, actions, events)
+  | Error Miou.Cancelled -> (he, [], [])
+  | Error exn ->
+      Logd.err (fun m ->
+          m "Got an unexpected exception (suspend): %s" (Printexc.to_string exn));
+      raise exn
+
+let rec clean_up prms =
+  match Miou.care prms with
+  | Some (Some prm) ->
+      let _ = Miou.await prm in
+      clean_up prms
+  | Some None | None -> Miou.yield ()
+
+let rec go t ~prms he () =
+  Logd.debug (fun m -> m "daemon tick");
+  clean_up prms;
+  let he, cont, actions = Happy_eyeballs.timer he (clock ()) in
+  List.iter (handle_one_action ~prms t) actions;
+  let he, actions, events = continue t cont he in
+  Logd.debug (fun m ->
+      m "got %d action(s) and %d event(s)" (List.length actions)
+        (List.length events));
+  let he, actions =
+    List.fold_left
+      (fun (he, actions) event ->
+        let he, actions' = Happy_eyeballs.event he (clock ()) (to_event t event) in
+        (he, List.rev_append actions actions'))
+      (he, actions) events
+  in
+  Logd.debug (fun m -> m "daemon handles %d action(s)" (List.length actions));
+  List.iter (handle_one_action ~prms t) actions;
+  go t ~prms he ()
+
+let launch_daemon t he () =
+  let prms = Miou.orphans () in
+  if Miou.Domain.available () > 0
+  then Miou.call (go t ~prms he)
+  else Miou.async (go t ~prms he)
+
+let connect_ip ?aaaa_timeout ?connect_delay ?connect_timeout t addrs =
+  let state = Miou.Computation.create () in
+  Miou.Mutex.protect t.mutex @@ fun () ->
+  let connect_ip =
+    { aaaa_timeout
+    ; connect_delay
+    ; connect_timeout
+    ; state
+    ; addrs } in
+  Miou.Queue.enqueue t.queue (`Connect_ip connect_ip);
+  Miou.Condition.signal t.condition;
+  state
+
+let connect_ip ?aaaa_timeout ?connect_delay ?connect_timeout t ips =
+  try connect_ip ?aaaa_timeout ?connect_delay ?connect_timeout t ips
+  with exn ->
+    Logc.err (fun m ->
+        m "Got an unexpected exception: %S" (Printexc.to_string exn));
+    raise exn
+
+type daemon = unit Miou.t
+
+let create ?happy_eyeballs:(he= Happy_eyeballs.create (clock ())) ?(getaddrinfo= getaddrinfo)
+  ?(timer_interval= Duration.of_ms 10) () =
+  let t = create (Duration.to_f timer_interval) getaddrinfo in
+  launch_daemon t he (), t
+
+let error_injection =
+  {text|
+It's impossible to hot-load a new getaddrinfo into the happy-eyeballs instance.
+|text}
+
+let inject t getaddrinfo =
+  if t.set
+  then invalid_arg error_injection;
+  t.getaddrinfo <- getaddrinfo;
+  t.set <- true
+
+let kill = Miou.cancel
+
+let connect_ip ?aaaa_timeout ?connect_delay ?connect_timeout t ips =
+  let state = connect_ip ?aaaa_timeout ?connect_delay ?connect_timeout t ips in
+  match Miou.Computation.await state with
+  | Ok (addr, fd) -> Ok (addr, Miou_unix.of_file_descr fd)
+  | Error (Connection_failed (host, reason), _) ->
+      error_msgf "Impossible to connect to %a: %s" Domain_name.pp host reason
+  | Error (exn, bt) -> Printexc.raise_with_backtrace exn bt
+
+let connect_host ?aaaa_timeout ?connect_delay ?connect_timeout ?resolve_timeout ?resolve_retries t host ports =
+  let state = Miou.Computation.create () in
+  let () =
+    Miou.Mutex.protect t.mutex @@ fun () ->
+    let connect =
+      { aaaa_timeout
+      ; connect_delay
+      ; connect_timeout
+      ; resolve_timeout
+      ; resolve_retries
+      ; state
+      ; host
+      ; ports } in
+    Miou.Queue.enqueue t.queue (`Connect connect);
+    Miou.Condition.signal t.condition
+  in
+  match Miou.Computation.await state with
+  | Ok (addr, fd) -> Ok (addr, Miou_unix.of_file_descr fd)
+  | Error (Connection_failed (host, reason), _) ->
+      error_msgf "Impossible to connect to %a: %s" Domain_name.pp host reason
+  | Error (exn, bt) -> Printexc.raise_with_backtrace exn bt
+
+let connect ?aaaa_timeout ?connect_delay ?connect_timeout ?resolve_timeout ?resolve_retries t str ports =
+  match Ipaddr.of_string str with
+  | Ok ipaddr ->
+    connect_ip ?aaaa_timeout ?connect_delay ?connect_timeout t
+      (List.map (fun port -> (ipaddr, port)) ports)
+  | Error _ -> (
+      match Result.bind (Domain_name.of_string str) Domain_name.host with
+      | Ok domain_name ->
+        connect_host ?aaaa_timeout ?connect_delay ?connect_timeout ?resolve_timeout ?resolve_retries
+          t domain_name ports
+      | Error _ -> error_msgf "Invalid endpoint: %S" str)

unikernel/duniverse/happy-eyeballs/miou/happy_eyeballs_miou_unix.mli

@@ -0,0 +1,76 @@
+type daemon
+type t
+
+type getaddrinfo = [ `A | `AAAA ] -> [ `host ] Domain_name.t -> (Ipaddr.Set.t, [ `Msg of string ]) result
+
+val create :
+     ?happy_eyeballs:Happy_eyeballs.t
+  -> ?getaddrinfo:getaddrinfo
+  -> ?timer_interval:int64
+  -> unit
+  -> daemon * t
+(** [make ()] allocates a new happy-eyeballs {i daemon} in parallel which must
+    be de-allocated with {!val:kill} at the end of your whole process.
+    Otherwise, Miou will complain that some tasks still exist. You can check
+    {!val:Happy_eyeballs.create} for more informations about optional arguments.
+
+    The happy-eyeball stack is able to give a connected socket only from IP
+    addresses. It does not (yet) resolve domain-names. Only {!val:connect_ip} is
+    usable. If you have a [getaddrinfo] function, you can then inject it into
+    the happy-eyeball daemon to enable it to resolve domain names. *)
+
+val inject : t -> getaddrinfo -> unit
+(** [inject t getaddrinfo] injects a DNS resolver into the given
+    {i happy-eyeballs} [t] instance. Initially, the {i happy-eyeballs} instance
+    (created by {!val:create}) can not resolve domain-name. When the user is
+    able to resolve a domain-name (via the DNS protocol for example), he/she can
+    {i inject} its resolver into the {i happy-eyeballs} instance.
+
+    Only after injection the user can use {!val:connect_host} and
+    {!val:connect}.
+
+    @raise Invalid_argument if you try to use more than once this function. *)
+
+val kill : daemon -> unit
+(** [kill daemon] kills properly the happy-eyeball daemon. *)
+
+val connect_ip :
+     ?aaaa_timeout:int64
+  -> ?connect_delay:int64
+  -> ?connect_timeout:int64
+  -> t
+  -> (Ipaddr.t * int) list
+  -> ((Ipaddr.t * int) * Miou_unix.file_descr, [> `Msg of string ]) result
+(** [connect_ip t addresses] establishes a connection to [addresses]. The
+    timeouts and delays are specified in nanoseconds, and are by default the
+    value defined when constructing [t]. *)
+
+val connect_host :
+     ?aaaa_timeout:int64
+  -> ?connect_delay:int64
+  -> ?connect_timeout:int64
+  -> ?resolve_timeout:int64
+  -> ?resolve_retries:int
+  -> t
+  -> [ `host ] Domain_name.t
+  -> int list
+  -> ((Ipaddr.t * int) * Miou_unix.file_descr, [> `Msg of string ]) result
+(** [connect_host t host ports] establishes a connection to [host] on [ports]
+    (tried in sequence).
+
+    @raise Failure if [ports] is an empty list. *)
+
+val connect :
+     ?aaaa_timeout:int64
+  -> ?connect_delay:int64
+  -> ?connect_timeout:int64
+  -> ?resolve_timeout:int64
+  -> ?resolve_retries:int
+  -> t
+  -> string
+  -> int list
+  -> ((Ipaddr.t * int) * Miou_unix.file_descr, [> `Msg of string ]) result
+(** [connect t host ports] establishes a connection to [host] on [ports], which
+    may be a host name or an IP address.
+
+    @raise Failure if [ports] is an empty list. *)

unikernel/duniverse/happy-eyeballs/mirage/dune

@@ -0,0 +1,4 @@
+(library
+ (name happy_eyeballs_mirage)
+ (public_name happy-eyeballs-mirage)
+ (libraries logs duration domain-name ipaddr lwt fmt tcpip happy-eyeballs mirage-mtime mirage-sleep))

unikernel/duniverse/happy-eyeballs/mirage/happy_eyeballs_mirage.ml

@@ -0,0 +1,293 @@
+module type S = sig
+  type t
+  type stack
+  type flow
+
+  type getaddrinfo = [ `A | `AAAA ] -> [ `host ] Domain_name.t -> (Ipaddr.Set.t, [ `Msg of string ]) result Lwt.t
+
+  val create : ?happy_eyeballs:Happy_eyeballs.t ->
+    ?getaddrinfo:getaddrinfo -> ?timer_interval:int64 -> stack -> t
+
+  val inject : t -> getaddrinfo -> unit
+
+  val connect_host : t -> ?aaaa_timeout:int64 -> ?connect_delay:int64 ->
+    ?connect_timeout:int64 -> ?resolve_timeout:int64 -> ?resolve_retries:int ->
+    [`host] Domain_name.t -> int list ->
+    ((Ipaddr.t * int) * flow, [> `Msg of string ]) result Lwt.t
+
+  val connect_ip : t -> ?aaaa_timeout:int64 -> ?connect_delay:int64 ->
+    ?connect_timeout:int64 -> (Ipaddr.t * int) list ->
+    ((Ipaddr.t * int) * flow, [> `Msg of string ]) result Lwt.t
+
+  val connect : t -> ?aaaa_timeout:int64 -> ?connect_delay:int64 ->
+    ?connect_timeout:int64 -> ?resolve_timeout:int64 -> ?resolve_retries:int ->
+    string -> int list ->
+    ((Ipaddr.t * int) * flow, [> `Msg of string ]) result Lwt.t
+end
+
+(* Lwt tasks are spawned:
+ - create starts an asynchronous timer task
+ - the actions resulting from timer are scheduled in one separate task
+ - the actions returned from Happy_eyeballs.connect/event are scheduled in
+   respective separate tasks
+*)
+
+let src = Logs.Src.create "happy-eyeballs.mirage" ~doc:"Happy Eyeballs Mirage"
+module Log = (val Logs.src_log src : Logs.LOG)
+
+let ctr = ref 0
+
+module Make (S : Tcpip.Stack.V4V6) : sig
+  include S
+    with type flow = S.TCP.flow
+     and type stack = S.t
+
+  val connect_device : ?aaaa_timeout:int64 -> ?connect_delay:int64 ->
+    ?connect_timeout:int64 -> ?resolve_timeout:int64 -> ?resolve_retries:int ->
+    ?timer_interval:int64 -> ?getaddrinfo:getaddrinfo -> stack -> t Lwt.t
+end = struct
+  type stack = S.t
+
+  type flow = S.TCP.flow
+
+  type getaddrinfo = [ `A | `AAAA ] -> [ `host ] Domain_name.t -> (Ipaddr.Set.t, [ `Msg of string ]) result Lwt.t
+
+  type t = {
+    stack : S.t ;
+    mutable waiters : ((Ipaddr.t * int) * S.TCP.flow, [ `Msg of string ]) result Lwt.u Happy_eyeballs.Waiter_map.t ;
+    mutable cancel_connecting : (int * unit Lwt.u) list Happy_eyeballs.Waiter_map.t;
+    mutable he : Happy_eyeballs.t ;
+    timer_interval : int64 ;
+    timer_condition : unit Lwt_condition.t ;
+    counter : int ;
+    mutable getaddrinfo : getaddrinfo option ;
+  }
+
+  let _cnt = ref 0
+
+  let inject t getaddrinfo =
+    incr _cnt;
+    t.getaddrinfo <- Some getaddrinfo;
+    if !_cnt > 1 then
+      Log.warn (fun m -> m "inject was called the %u times" !_cnt)
+
+  let try_connect stack addr =
+    let open Lwt.Infix in
+    S.TCP.create_connection (S.tcp stack) addr >|= fun r ->
+    Result.map_error
+      (fun err -> `Msg (Fmt.to_to_string S.TCP.pp_error err)) r
+
+  let rec act t action =
+    let open Lwt.Infix in
+    Log.debug (fun m -> m "[%u] action %a" t.counter
+                  Happy_eyeballs.pp_action action);
+    begin
+      match action with
+      | Happy_eyeballs.Resolve_a host | Happy_eyeballs.Resolve_aaaa host ->
+        begin
+          let record = match action with
+            | Happy_eyeballs.Resolve_a _ -> `A
+            | Happy_eyeballs.Resolve_aaaa _ -> `AAAA
+            | _ -> assert false (* never occur! *)
+          in
+          match t.getaddrinfo with
+          | None ->
+            Log.err (fun m -> m "trying to lookup %a, but there's no getaddrinfo"
+                        Domain_name.pp host);
+            Lwt.return (Error ())
+          | Some getaddrinfo ->
+            getaddrinfo record host >|= fun res ->
+            match res, record with
+            | Ok set, `A ->
+              let fold ip set = match ip with
+                | Ipaddr.V4 ipv4 -> Ipaddr.V4.Set.add ipv4 set
+                | Ipaddr.V6 ipv6 ->
+                  Log.warn (fun m -> m "received the IPv6 address %a querying A of %a (ignoring)"
+                               Ipaddr.V6.pp ipv6 Domain_name.pp host);
+                  set
+              in
+              Ok (Happy_eyeballs.Resolved_a (host, Ipaddr.Set.fold fold set Ipaddr.V4.Set.empty))
+            | Ok set, `AAAA ->
+              let fold ip set = match ip with
+                | Ipaddr.V6 ipv6 -> Ipaddr.V6.Set.add ipv6 set
+                | Ipaddr.V4 ipv4 ->
+                  Log.warn (fun m -> m "received the IPv4 address %a querying AAAA of %a (ignoring)"
+                               Ipaddr.V4.pp ipv4 Domain_name.pp host);
+                  set
+              in
+              Ok (Happy_eyeballs.Resolved_aaaa (host, Ipaddr.Set.fold fold set Ipaddr.V6.Set.empty))
+            | Error `Msg msg, `A ->
+              Ok (Happy_eyeballs.Resolved_a_failed (host, msg))
+            | Error `Msg msg, `AAAA ->
+              Ok (Happy_eyeballs.Resolved_aaaa_failed (host, msg))
+        end
+      | Happy_eyeballs.Connect (host, id, attempt, addr) ->
+        begin
+          let cancelled, cancel = Lwt.task () in
+          let entry = attempt, cancel in
+          t.cancel_connecting <-
+            Happy_eyeballs.Waiter_map.update id
+              (function None -> Some [ entry ] | Some c -> Some (entry :: c))
+              t.cancel_connecting;
+          let conn =
+            try_connect t.stack addr >>= function
+            | Ok flow ->
+              let cancel_connecting, others =
+                Happy_eyeballs.Waiter_map.find_and_remove id t.cancel_connecting
+              in
+              t.cancel_connecting <- cancel_connecting;
+              List.iter (fun (att, u) -> if att <> attempt then Lwt.wakeup_later u ())
+                (Option.value ~default:[] others);
+              let waiters, r = Happy_eyeballs.Waiter_map.find_and_remove id t.waiters in
+              t.waiters <- waiters;
+              begin match r with
+                | Some waiter ->
+                  Lwt.wakeup_later waiter (Ok (addr, flow));
+                  Lwt.return (Ok (Happy_eyeballs.Connected (host, id, addr)))
+                | None ->
+                  (* waiter already vanished *)
+                  S.TCP.close flow >>= fun () ->
+                  Lwt.return (Error ())
+              end
+            | Error `Msg msg ->
+              t.cancel_connecting <-
+                Happy_eyeballs.Waiter_map.update id
+                  (function None -> None | Some c ->
+                    match List.filter (fun (att, _) -> not (att = attempt)) c with
+                    | [] -> None
+                    | c -> Some c)
+                  t.cancel_connecting;
+              Lwt.return (Ok (Happy_eyeballs.Connection_failed (host, id, addr, msg)))
+          in
+          Lwt.pick [ conn ; (cancelled >|= fun () -> Error ()); ]
+        end
+      | Happy_eyeballs.Connect_failed (host, id, msg) ->
+        let cancel_connecting, others =
+          Happy_eyeballs.Waiter_map.find_and_remove id t.cancel_connecting
+        in
+        t.cancel_connecting <- cancel_connecting;
+        List.iter (fun (_, u) -> Lwt.wakeup_later u ()) (Option.value ~default:[] others);
+        let waiters, r = Happy_eyeballs.Waiter_map.find_and_remove id t.waiters in
+        t.waiters <- waiters;
+        begin match r with
+          | Some waiter ->
+            let err =
+              Fmt.str "connection to %s failed: %s"
+                (match Ipaddr.of_domain_name host with
+                 | None -> Domain_name.to_string host
+                 | Some ip -> Ipaddr.to_string ip)
+                msg
+            in
+            Lwt.wakeup_later waiter (Error (`Msg err));
+            Lwt.return (Error ())
+          | None ->
+            (* waiter already vanished *)
+            Lwt.return (Error ())
+        end
+    end >>= function
+    | Error _ -> Lwt.return_unit
+    | Ok ev ->
+      let he, actions = Happy_eyeballs.event t.he (Mirage_mtime.elapsed_ns ()) ev in
+      t.he <- he;
+      Lwt_list.iter_p (act t) actions
+
+  let handle_timer_actions t actions =
+    Lwt.async (fun () -> Lwt_list.iter_p (fun a -> act t a) actions)
+
+  let rec timer t =
+    let open Lwt.Infix in
+    let rec loop () =
+      let he, cont, actions = Happy_eyeballs.timer t.he (Mirage_mtime.elapsed_ns ()) in
+      t.he <- he ;
+      handle_timer_actions t actions ;
+      match cont with
+      | `Suspend ->
+        timer t
+      | `Act ->
+        Mirage_sleep.ns t.timer_interval >>= fun () ->
+        loop ()
+    in
+    Lwt_condition.wait t.timer_condition >>= fun () ->
+    loop ()
+
+  let create ?(happy_eyeballs = Happy_eyeballs.create (Mirage_mtime.elapsed_ns ())) ?getaddrinfo ?(timer_interval = Duration.of_ms 10) stack =
+    let waiters = Happy_eyeballs.Waiter_map.empty
+    and cancel_connecting = Happy_eyeballs.Waiter_map.empty
+    and timer_condition = Lwt_condition.create ()
+    in
+    incr ctr;
+    let t = { stack ; waiters ; cancel_connecting ; he = happy_eyeballs ; timer_interval ; timer_condition ; counter = !ctr ; getaddrinfo } in
+    Lwt.async (fun () -> timer t);
+    t
+
+  let handle_actions t actions =
+    List.iter (fun a -> Lwt.async (fun () -> act t a)) actions
+
+  let open_msg_error = function
+    | Ok _ as r -> r
+    | Error (`Msg _) as r -> r
+
+  let connect_host t ?aaaa_timeout ?connect_delay ?connect_timeout
+    ?resolve_timeout ?resolve_retries host ports =
+    let waiter, notify = Lwt.task () in
+    let waiters, id = Happy_eyeballs.Waiter_map.register notify t.waiters in
+    t.waiters <- waiters;
+    let ts = Mirage_mtime.elapsed_ns () in
+    let he, actions =
+      Happy_eyeballs.connect t.he ts ?aaaa_timeout ?connect_delay
+        ?connect_timeout ?resolve_timeout ?resolve_retries ~id host ports
+    in
+    t.he <- he;
+    Lwt_condition.signal t.timer_condition ();
+    handle_actions t actions;
+    let open Lwt.Infix in
+    waiter >|= fun r ->
+    Log.debug (fun m -> m "[%u] connection %s to %a after %a"
+                  t.counter (match r with Ok _ -> "ok" | Error _ -> "failed")
+                  Domain_name.pp host
+                  Duration.pp (Int64.sub (Mirage_mtime.elapsed_ns ()) ts));
+    open_msg_error r
+
+  let connect_ip t ?aaaa_timeout ?connect_delay ?connect_timeout addresses =
+    let waiter, notify = Lwt.task () in
+    let waiters, id = Happy_eyeballs.Waiter_map.register notify t.waiters in
+    t.waiters <- waiters;
+    let ts = Mirage_mtime.elapsed_ns () in
+    let he, actions =
+      Happy_eyeballs.connect_ip t.he ts ?aaaa_timeout ?connect_delay
+        ?connect_timeout ~id addresses
+    in
+    t.he <- he;
+    Lwt_condition.signal t.timer_condition ();
+    handle_actions t actions;
+    let open Lwt.Infix in
+    waiter >|= fun r ->
+    Log.debug (fun m -> m "[%u] connection %s to %a after %a"
+                  t.counter (match r with Ok _ -> "ok" | Error _ -> "failed")
+                  Fmt.(list ~sep:(any ", ") (pair ~sep:(any ":") Ipaddr.pp int))
+                  addresses
+                  Duration.pp (Int64.sub (Mirage_mtime.elapsed_ns ()) ts));
+    open_msg_error r
+
+  let connect t ?aaaa_timeout ?connect_delay ?connect_timeout
+    ?resolve_timeout ?resolve_retries host ports =
+    match Ipaddr.of_string host with
+    | Ok ip ->
+      connect_ip t ?aaaa_timeout ?connect_delay ?connect_timeout
+        (List.map (fun p -> (ip, p)) ports)
+    | Error _ ->
+      let open Lwt_result.Infix in
+      Lwt_result.lift
+        (Result.bind (Domain_name.of_string host) Domain_name.host) >>= fun h ->
+      connect_host t ?aaaa_timeout ?connect_delay ?connect_timeout
+        ?resolve_timeout ?resolve_retries h ports
+
+  let connect_device ?aaaa_timeout ?connect_delay ?connect_timeout
+    ?resolve_timeout ?resolve_retries ?timer_interval ?getaddrinfo stack =
+    let happy_eyeballs =
+      Happy_eyeballs.create ?aaaa_timeout ?connect_delay ?connect_timeout
+        ?resolve_timeout ?resolve_retries (Mirage_mtime.elapsed_ns ())
+    in
+    let happy_eyeballs = create ~happy_eyeballs ?getaddrinfo ?timer_interval stack in
+    Lwt.return happy_eyeballs
+end

unikernel/duniverse/happy-eyeballs/mirage/happy_eyeballs_mirage.mli

@@ -0,0 +1,58 @@
+module type S = sig
+  type t
+
+  type stack
+
+  type flow
+
+  type getaddrinfo = [ `A | `AAAA ] -> [ `host ] Domain_name.t -> (Ipaddr.Set.t, [ `Msg of string ]) result Lwt.t
+
+  val create : ?happy_eyeballs:Happy_eyeballs.t ->
+    ?getaddrinfo:getaddrinfo -> ?timer_interval:int64 -> stack -> t
+
+  val inject : t -> getaddrinfo -> unit
+  (** [inject t getaddrinfo] injects a {i new} domain-name resolver into the
+      given happy-eyeballs instance. By default, the happy-eyeballs instance is
+      not able to resolve hostnames. Use a [dns-client-mirage] instance at your
+      convenience. *)
+
+  val connect_host : t -> ?aaaa_timeout:int64 -> ?connect_delay:int64 ->
+    ?connect_timeout:int64 -> ?resolve_timeout:int64 -> ?resolve_retries:int ->
+    [`host] Domain_name.t -> int list ->
+    ((Ipaddr.t * int) * flow, [> `Msg of string ]) result Lwt.t
+  (** [connect_host t host ports] establishes a connection to [host] on [ports]
+      (tried in sequence). The timeouts and delays are specified in nanoseconds,
+      and are by default the values defined when constructing [t].
+
+      @raise Failure if [ports] is empty. *)
+
+  val connect_ip : t -> ?aaaa_timeout:int64 -> ?connect_delay:int64 ->
+    ?connect_timeout:int64 -> (Ipaddr.t * int) list ->
+    ((Ipaddr.t * int) * flow, [> `Msg of string ]) result Lwt.t
+  (** [connect_ip t addresses] establishes a connection to [addresses]. The
+      timeouts and delays are specified in nanoseconds, and are by default the
+      values defined when constructing [t].
+
+      @raise Failure if [addresses] is the empty list. *)
+
+  val connect : t -> ?aaaa_timeout:int64 -> ?connect_delay:int64 ->
+    ?connect_timeout:int64 -> ?resolve_timeout:int64 -> ?resolve_retries:int ->
+    string -> int list ->
+    ((Ipaddr.t * int) * flow, [> `Msg of string ]) result Lwt.t
+    (** [connect t host ports] establishes a connection to [host] on [ports],
+        which may be a host name, or an IP address. The timeouts and delays are
+        specified in nanoseconds, and are by default the values defined when
+        constructing [t].
+
+        @raise Failure if [ports] is the empty list. *)
+end
+
+module Make (S : Tcpip.Stack.V4V6) : sig
+  include S
+    with type flow = S.TCP.flow
+     and type stack = S.t
+
+  val connect_device : ?aaaa_timeout:int64 -> ?connect_delay:int64 ->
+    ?connect_timeout:int64 -> ?resolve_timeout:int64 -> ?resolve_retries:int ->
+    ?timer_interval:int64 -> ?getaddrinfo:getaddrinfo -> stack -> t Lwt.t
+end

unikernel/duniverse/happy-eyeballs/src/dune

@@ -0,0 +1,4 @@
+(library
+ (name happy_eyeballs)
+ (public_name happy-eyeballs)
+ (libraries domain-name ipaddr fmt duration logs))

unikernel/duniverse/happy-eyeballs/src/happy_eyeballs.ml

@@ -0,0 +1,497 @@
+let src = Logs.Src.create "happy-eyeballs" ~doc:"Happy Eyeballs"
+module Log = (val Logs.src_log src : Logs.LOG)
+
+type conn_state =
+  | Resolving of int64
+  | Waiting_for_aaaa of int64 * Ipaddr.V4.Set.t (* TODO ensure non-empty set *)
+  | Connecting of int64 * (Ipaddr.t * int) list * (Ipaddr.t * int) list
+
+type timeouts = {
+  created : int64 ;
+  aaaa_timeout : int64 ;
+  connect_delay : int64 ;
+  connect_timeout : int64 ;
+  resolve_timeout : int64 ;
+}
+
+type connection = {
+  state : conn_state ;
+  ports : int list ;
+  resolved : [ `none | `v4 | `v6 | `both ] ;
+  resolve_left : int ;
+  attempt : int ;
+  time : timeouts ;
+}
+
+let resolve st ev = match st, ev with
+  | `none, `v4 -> `v4
+  | `none, `v6 -> `v6
+  | `v6, `v4 -> `both
+  | `v4, `v6 -> `both
+  | x, _ -> x
+
+module IM = Map.Make(Int)
+
+type t = {
+  resolve_retries : int ;
+  counter : int ;
+  conns : connection IM.t Domain_name.Host_map.t ;
+  time : timeouts ;
+}
+
+let resolve_timeout t = t.time.resolve_timeout
+
+type id = int
+
+type action =
+  | Resolve_a of [`host] Domain_name.t
+  | Resolve_aaaa of [`host] Domain_name.t
+  | Connect of [`host] Domain_name.t * id * int * (Ipaddr.t * int)
+  | Connect_failed of [`host] Domain_name.t * id * string
+
+let host_or_ip v =
+  match Ipaddr.of_domain_name v with
+  | None -> Domain_name.to_string v
+  | Some ip -> Ipaddr.to_string ip
+
+let pp_action ppf = function
+  | Resolve_a host -> Fmt.pf ppf "resolve A %a" Domain_name.pp host
+  | Resolve_aaaa host -> Fmt.pf ppf "resolve AAAA %a" Domain_name.pp host
+  | Connect (host, id, attempt, (ip, port)) ->
+    Fmt.pf ppf "%u connect %s (using %a:%u), attempt %u" id (host_or_ip host)
+         Ipaddr.pp ip port attempt
+  | Connect_failed (host, id, reason) ->
+    Fmt.pf ppf "%u connect failed %s: %s" id (host_or_ip host) reason
+
+type event =
+  | Resolved_a of [`host] Domain_name.t * Ipaddr.V4.Set.t
+  | Resolved_aaaa of [`host] Domain_name.t * Ipaddr.V6.Set.t
+  | Resolved_a_failed of [`host] Domain_name.t * string
+  | Resolved_aaaa_failed of [`host] Domain_name.t * string
+  | Connection_failed of [`host] Domain_name.t * id * (Ipaddr.t * int) * string
+  | Connected of [`host] Domain_name.t * id * (Ipaddr.t * int)
+
+let pp_event ppf = function
+  | Resolved_a (host, ips) ->
+    Fmt.pf ppf "resolved A %a: %a" Domain_name.pp host
+      Fmt.(list ~sep:(any ", ") Ipaddr.V4.pp)
+      (Ipaddr.V4.Set.elements ips)
+  | Resolved_aaaa (host, ips) ->
+    Fmt.pf ppf "resolved AAAA %a: %a" Domain_name.pp host
+      Fmt.(list ~sep:(any ", ") Ipaddr.V6.pp)
+      (Ipaddr.V6.Set.elements ips)
+  | Resolved_a_failed (host, reason) ->
+    Fmt.pf ppf "resolve A failed for %a: %s" Domain_name.pp host reason
+  | Resolved_aaaa_failed (host, reason) ->
+    Fmt.pf ppf "resolve AAAA failed for %a: %s" Domain_name.pp host reason
+  | Connection_failed (host, id, (ip, port), reason) ->
+    Fmt.pf ppf "%u connection to %s failed %a:%d: %s" id (host_or_ip host)
+      Ipaddr.pp ip port reason
+  | Connected (host, id, (ip, port)) ->
+    Fmt.pf ppf "%u connected to %s (using %a:%d)" id (host_or_ip host)
+      Ipaddr.pp ip port
+
+let ctr = ref 0
+
+let create
+    ?(aaaa_timeout = Duration.of_ms 50)
+    ?(connect_delay = Duration.of_ms 50)
+    ?(connect_timeout = Duration.of_sec 10)
+    ?(resolve_timeout = Duration.of_sec 1)
+    ?(resolve_retries = 3)
+    created =
+  incr ctr;
+  let time = {
+    aaaa_timeout ;
+    connect_delay ;
+    connect_timeout ;
+    resolve_timeout ;
+    created ;
+  } in
+  {
+    resolve_retries ;
+    counter = !ctr ;
+    conns = Domain_name.Host_map.empty ;
+    time ;
+  }
+
+let add_conn host id conn c =
+  Domain_name.Host_map.update host
+    (function
+      | None -> Some (IM.singleton id conn)
+      | Some cs -> Some (IM.add id conn cs))
+    c
+
+let expand_list ips ports =
+  List.flatten (List.map (fun ip -> List.map (fun p -> (ip, p)) ports) ips)
+
+(* all input has been verified that ips and ports are non-empty. *)
+let expand_list_split ips ports =
+  match expand_list ips ports with
+  | hd :: tl -> hd, tl
+  | _ -> failwith "ips or ports are empty"
+
+let tick now host id conn =
+  match conn.state with
+  | Resolving ts when Int64.sub now ts > conn.time.resolve_timeout ->
+    begin
+      let ok actions =
+        Ok ({ conn with resolve_left = conn.resolve_left - 1 },
+            actions)
+      in
+      match conn.resolve_left <= 1, conn.resolved with
+      | true, _ | _, `both -> Error ()
+      | false, `none -> ok [ Resolve_a host ; Resolve_aaaa host ]
+      | false, `v4 -> ok [ Resolve_aaaa host ]
+      | false, `v6 -> ok [ Resolve_a host ]
+    end
+  | Waiting_for_aaaa (started, ips) when Int64.sub now started > conn.time.aaaa_timeout ->
+    let ips = List.map (fun ip -> Ipaddr.V4 ip) (Ipaddr.V4.Set.elements ips) in
+    let dst, dsts = expand_list_split ips conn.ports in
+    let state = Connecting (now, [ dst ], dsts)
+    and attempt = conn.attempt + 1
+    in
+    Ok ({ conn with state ; attempt }, [ Connect (host, id, conn.attempt, dst) ])
+  | Connecting (last_conn, active_conns, dsts) ->
+    (* if there are further IP addresses, and there was no activity within
+       connect_delay, start the next connection. *)
+    if Int64.sub now conn.time.created > conn.time.connect_timeout then
+      Error ()
+    else if Int64.sub now last_conn > conn.time.connect_delay then
+      (match dsts with
+       | [] -> Ok (conn, [])
+       | dst :: dsts ->
+         let state = Connecting (now, dst :: active_conns, dsts)
+         and attempt = conn.attempt + 1
+         in
+         Ok ({ conn with state ; attempt }, [ Connect (host, id, conn.attempt, dst) ]))
+    else
+      Ok (conn, [])
+  | _ -> Ok (conn, [])
+
+let timer (t : t) now =
+  let conns, actions =
+    Domain_name.Host_map.fold (fun host v (dm, actions) ->
+        let v, actions = IM.fold (fun id conn (acc, actions) ->
+            match tick now host id conn with
+            | Ok (conn, action) -> IM.add id conn acc, action @ actions
+            | Error () -> acc, Connect_failed (host, id, "timeout") :: actions)
+            v (IM.empty, actions)
+        in
+        let dm =
+          if IM.cardinal v = 0 then dm else Domain_name.Host_map.add host v dm
+        in
+        dm, actions) t.conns (Domain_name.Host_map.empty, [])
+  in
+  (match actions with
+   | [] when not (Domain_name.Host_map.is_empty conns) -> ()
+   | _ ->
+     Log.debug (fun m -> m "[%u] timer continue %B, %d actions: %a"
+                   t.counter (not (Domain_name.Host_map.is_empty conns))
+                   (List.length actions)
+                   Fmt.(list ~sep:(any "@.") pp_action) actions));
+  { t with conns },
+  (if Domain_name.Host_map.is_empty conns then `Suspend else `Act),
+  actions
+
+let connect t now ?aaaa_timeout ?connect_delay ?connect_timeout ?resolve_timeout ?resolve_retries ~id host ports =
+  Log.debug (fun m -> m "[%u] connect: id %d host %a" t.counter id
+                Domain_name.pp host);
+  if ports = [] then failwith "empty port list not supported";
+  let tt = t.time in
+  let time = {
+    created = now ;
+    aaaa_timeout = Option.value ~default:tt.aaaa_timeout aaaa_timeout ;
+    connect_delay = Option.value ~default:tt.connect_delay connect_delay ;
+    connect_timeout = Option.value ~default:tt.connect_timeout connect_timeout ;
+    resolve_timeout = Option.value ~default:tt.resolve_timeout resolve_timeout ;
+  }
+  in
+  let resolve_left = Option.value ~default:t.resolve_retries resolve_retries in
+  let conn = {
+    ports ;
+    state = Resolving now ;
+    resolved = `none ;
+    resolve_left ;
+    attempt = 0 ;
+    time ;
+  } in
+  let actions = [ Resolve_aaaa host ; Resolve_a host ] in
+  Log.debug (fun m -> m "[%u] actions: %a" t.counter
+                Fmt.(list ~sep:(any "@.") pp_action) actions);
+  { t with conns = add_conn host id conn t.conns }, actions
+
+let merge ?(ipv4 = Ipaddr.V4.Set.empty) ?(ipv6 = Ipaddr.V6.Set.empty) ips =
+  List.fold_left (fun (ipv4, ipv6) -> function
+      | Ipaddr.V4 ip -> Ipaddr.V4.Set.add ip ipv4, ipv6
+      | Ipaddr.V6 ip -> ipv4, Ipaddr.V6.Set.add ip ipv6)
+    (ipv4, ipv6) ips
+
+let shuffle ?first v4 v6 =
+  match List.length v4, List.length v6 with
+  | 0, _ -> v6
+  | _, 0 -> v4
+  | v4l, v6l ->
+    let rec shuffle a b = function
+      | 0 -> []
+      | n -> match a, b with
+        | [], _ -> shuffle v4 b n
+        | _, [] -> shuffle a v6 n
+        | hd :: tl, hd' :: tl' ->
+          match first with
+          | Some Ipaddr.V6 _ -> hd :: hd' :: shuffle tl tl' (pred n)
+          | None | Some Ipaddr.V4 _ -> hd' :: hd :: shuffle tl tl' (pred n)
+    in
+    shuffle v4 v6 (max v4l v6l)
+
+(* the idea is to first separate into V4 and V6 addresses, and then mix them *)
+let mix ?first ?ipv4 ?ipv6 ips =
+  let ipv4, ipv6 = merge ?ipv4 ?ipv6 ips in
+  let v4, v6 =
+    Ipaddr.V4.Set.fold (fun ip acc -> Ipaddr.V4 ip :: acc) ipv4 [],
+    Ipaddr.V6.Set.fold (fun ip acc -> Ipaddr.V6 ip :: acc) ipv6 []
+  in
+  shuffle ?first v4 v6
+
+let mix_dsts ?(ipv4 = Ipaddr.V4.Set.empty) ?(ipv6 = Ipaddr.V6.Set.empty) ports dst dsts =
+  let v4_present, v6_present = merge (List.map fst (dst @ dsts)) in
+  let ipv4 = Ipaddr.V4.Set.diff ipv4 v4_present
+  and ipv6 = Ipaddr.V6.Set.diff ipv6 v6_present
+  in
+  let v4_dsts, v6_dsts =
+    List.fold_left (fun (ipv4, ipv6) -> function
+        | Ipaddr.V4 _, _ as a -> a :: ipv4, ipv6
+        | Ipaddr.V6 _, _ as a -> ipv4, a :: ipv6)
+      ([], []) dsts
+  in
+  let v4s =
+    expand_list
+      (Ipaddr.V4.Set.fold (fun ip acc -> Ipaddr.V4 ip :: acc) ipv4 [])
+      ports
+  and v6s =
+    expand_list
+      (Ipaddr.V6.Set.fold (fun ip acc -> Ipaddr.V6 ip :: acc) ipv6 [])
+      ports
+  in
+  let first = match dst with [] -> None | (ip, _) :: _ -> Some ip in
+  shuffle ?first (List.rev v4_dsts @ v4s) (List.rev v6_dsts @ v6s)
+
+let connect_ip t now ?aaaa_timeout ?connect_delay ?connect_timeout ~id dsts =
+  Log.debug (fun m -> m "[%u] connect_ip id %d dsts %a" t.counter id
+                Fmt.(list ~sep:(any ", ") (pair ~sep:(any ":") Ipaddr.pp int))
+                dsts);
+  let dst, dsts = match dsts with
+    | dst :: dsts -> dst, dsts
+    | [] -> failwith "addresses are empty"
+  in
+  let state = Connecting (now, [ dst ], dsts) in
+  let tt = t.time in
+  let time = {
+    created = now ;
+    aaaa_timeout = Option.value ~default:tt.aaaa_timeout aaaa_timeout ;
+    connect_delay = Option.value ~default:tt.connect_delay connect_delay ;
+    connect_timeout = Option.value ~default:tt.connect_timeout connect_timeout ;
+    resolve_timeout = 0L
+  }
+  in
+  let conn = {
+    ports = [] ;
+    state ;
+    resolved = `both ;
+    resolve_left = 0 ;
+    attempt = 1 ;
+    time ;
+  } in
+  let host = Ipaddr.to_domain_name (fst dst) in
+  let actions = [ Connect (host, id, 0, dst) ] in
+  Log.debug (fun m -> m "[%u] actions: %a" t.counter
+                Fmt.(list ~sep:(any "@.") pp_action) actions);
+  { t with conns = add_conn host id conn t.conns }, actions
+
+let event t now e =
+  Log.debug (fun m -> m "[%u] received event %a" t.counter pp_event e);
+  let t, actions =
+    match e with
+    | Resolved_a (name, ips) ->
+      let conns, actions =
+        match Domain_name.Host_map.find name t.conns with
+        | None -> t.conns, []
+        | Some cs ->
+          let cs, actions = IM.fold (fun id c (cs, actions) ->
+              let resolved = resolve c.resolved `v4 in
+              let state, attempt, actions = match c.state with
+                | Resolving _ts when resolved = `both ->
+                  let ips =
+                    List.map (fun ip -> Ipaddr.V4 ip) (Ipaddr.V4.Set.elements ips)
+                  in
+                  let dst, dsts = expand_list_split ips c.ports in
+                  Connecting (now, [ dst ], dsts), c.attempt + 1,
+                  Connect (name, id, c.attempt, dst) :: actions
+                | Resolving _ts -> Waiting_for_aaaa (now, ips), c.attempt, actions
+                | Waiting_for_aaaa (ts, ips') ->
+                  Log.debug (fun m -> m "%a already waiting for AAAA with %a"
+                               Domain_name.pp name
+                               Fmt.(list ~sep:(any ", ") Ipaddr.V4.pp)
+                               (Ipaddr.V4.Set.elements ips'));
+                  Waiting_for_aaaa (ts, Ipaddr.V4.Set.union ips' ips), c.attempt,
+                  actions
+                | Connecting (ts, dst, dsts) ->
+                  let dsts = mix_dsts ~ipv4:ips c.ports dst dsts in
+                  Connecting (ts, dst, dsts), c.attempt, actions
+              in
+              IM.add id { c with state ; resolved ; attempt } cs, actions)
+              cs (IM.empty, [])
+          in
+          Domain_name.Host_map.add name cs t.conns, actions
+      in
+      { t with conns }, actions
+    | Resolved_a_failed (name, reason) ->
+      let conns, actions =
+        match Domain_name.Host_map.find name t.conns with
+        | None -> t.conns, []
+        | Some cs ->
+          let cs, actions = IM.fold (fun id c (cs, actions) ->
+              let resolved = resolve c.resolved `v4 in
+              match c.state with
+              | Resolving _ts when resolved = `both ->
+                cs, Connect_failed (name, id, reason) :: actions
+              | _ -> IM.add id { c with resolved } cs, actions)
+              cs (IM.empty, [])
+          in
+          (if IM.is_empty cs then
+             Domain_name.Host_map.remove name t.conns
+           else
+             Domain_name.Host_map.add name cs t.conns), actions
+      in
+      { t with conns }, actions
+    | Resolved_aaaa (name, ips) ->
+      let conns, actions =
+        match Domain_name.Host_map.find name t.conns with
+        | None -> t.conns, []
+        | Some cs ->
+          let cs, actions = IM.fold (fun id c (cs, actions) ->
+              let resolved = resolve c.resolved `v6 in
+              let state, attempt, actions' = match c.state with
+                | Resolving _ts ->
+                  let ips = mix ~ipv6:ips [] in
+                  let dst, dsts = expand_list_split ips c.ports in
+                  Connecting (now, [ dst ], dsts), c.attempt + 1,
+                  [ Connect (name, id, c.attempt, dst) ]
+                | Waiting_for_aaaa (_ts, ips') ->
+                  let ips = mix ~ipv4:ips' ~ipv6:ips [] in
+                  let dst, dsts = expand_list_split ips c.ports in
+                  Connecting (now, [ dst ], dsts), c.attempt + 1,
+                  [ Connect (name, id, c.attempt, dst) ]
+                | Connecting (ts, dst, dsts) ->
+                  let dsts = mix_dsts ~ipv6:ips c.ports dst dsts in
+                  Connecting (ts, dst, dsts), c.attempt, []
+              in
+              IM.add id { c with state ; resolved ; attempt } cs, actions @ actions')
+              cs (IM.empty, [])
+          in
+          Domain_name.Host_map.add name cs t.conns, actions
+      in
+      { t with conns }, actions
+    | Resolved_aaaa_failed (name, reason) ->
+      let conns, actions =
+        match Domain_name.Host_map.find name t.conns with
+        | None -> t.conns, []
+        | Some cs ->
+          let cs, actions = IM.fold (fun id c (cs, actions) ->
+              let resolved = resolve c.resolved `v6 in
+              match c.state with
+              | Resolving _ts when resolved = `both ->
+                cs, Connect_failed (name, id, reason) :: actions
+              | Waiting_for_aaaa (_ts, ips) ->
+                let ips =
+                  List.map (fun ip -> Ipaddr.V4 ip) (Ipaddr.V4.Set.elements ips)
+                in
+                let dst, dsts = expand_list_split ips c.ports in
+                let state = Connecting (now, [ dst ], dsts) in
+                let attempt = c.attempt + 1 in
+                IM.add id { c with state ; resolved ; attempt } cs,
+                Connect (name, id, c.attempt, dst) :: actions
+              | _ -> IM.add id { c with resolved } cs, actions)
+              cs (IM.empty, [])
+          in
+          (if IM.is_empty cs then
+             Domain_name.Host_map.remove name t.conns
+           else
+             Domain_name.Host_map.add name cs t.conns), actions
+      in
+      { t with conns }, actions
+    | Connection_failed (name, id, (ip, port), reason) ->
+      let conns, actions =
+        match Domain_name.Host_map.find name t.conns with
+        | None ->
+          Log.warn (fun m -> m "[%u] connection failed to %s: %s; no entry in conns"
+                       t.counter (host_or_ip name) reason);
+          t.conns, []
+        | Some cs ->
+          match IM.find_opt id cs with
+          | None ->
+            Log.warn (fun m -> m "[%u] %u connection failed to %s: %s; no entry in IM"
+                         t.counter id (host_or_ip name) reason);
+            t.conns, []
+          | Some c ->
+            let not_failed (ip', port') = not (Ipaddr.compare ip ip' = 0 && port = port') in
+            match c.state with
+            | Connecting (ts, dst, []) ->
+              let dst' = List.filter not_failed dst in
+              begin match dst', c.resolved with
+                | [], `both ->
+                  let cs = IM.remove id cs in
+                  Domain_name.Host_map.add name cs t.conns,
+                  [ Connect_failed (name, id, reason) ]
+                | [], _ ->
+                  let state = Resolving now in
+                  let cs = IM.add id { c with state } cs in
+                  Domain_name.Host_map.add name cs t.conns, []
+                | dst', _ ->
+                  let state = Connecting (ts, dst', []) in
+                  let cs = IM.add id { c with state } cs in
+                  Domain_name.Host_map.add name cs t.conns, []
+              end
+            | Connecting (_ts, dst, ndst :: dsts) ->
+              let dst' = List.filter not_failed dst in
+              let state = Connecting (now, ndst :: dst', dsts) in
+              let attempt = c.attempt + 1 in
+              let cs = IM.add id { c with state ; attempt } cs in
+              Domain_name.Host_map.add name cs t.conns,
+              [ Connect (name, id, c.attempt, ndst) ]
+            | _ -> t.conns, []
+      in
+      { t with conns }, actions
+    | Connected (name, id, (_ip, _port)) ->
+      let conns =
+        Domain_name.Host_map.update name (function
+            | None ->
+              Log.warn (fun m -> m "[%u] connected to an unexpected domain: %a"
+                           t.counter Domain_name.pp name);
+              None
+            | Some xs ->
+              let m = IM.remove id xs in
+              if IM.cardinal m = 0 then None else Some m)
+          t.conns
+      in
+      { t with conns }, []
+  in
+  Log.debug (fun m -> m "[%u] actions: %a" t.counter
+                Fmt.(list ~sep:(any "@.") pp_action) actions);
+  t, actions
+
+module Waiter_map = struct
+  include Map.Make(Int)
+
+  let _id = ref 0
+
+  let register v t =
+    incr _id;
+    let id = !_id in
+    add id v t, id
+
+  let find_and_remove id t =
+    match find_opt id t with
+    | None -> t, None
+    | Some x -> remove id t, Some x
+end

unikernel/duniverse/happy-eyeballs/src/happy_eyeballs.mli

@@ -0,0 +1,91 @@
+(** The internal state of happy eyeballs. *)
+type t
+
+(** The type for a connection identifier. *)
+type id
+
+(** The variant of actions to be performed by the effectful layer. *)
+type action =
+  | Resolve_a of [`host] Domain_name.t
+  | Resolve_aaaa of [`host] Domain_name.t
+  | Connect of [`host] Domain_name.t * id * int * (Ipaddr.t * int)
+  | Connect_failed of [`host] Domain_name.t * id * string
+
+val pp_action : action Fmt.t
+(** [pp_action ppf a] pretty-prints the action [a] on [ppf]. *)
+
+(** The variant of events. *)
+type event =
+  | Resolved_a of [`host] Domain_name.t * Ipaddr.V4.Set.t
+  | Resolved_aaaa of [`host] Domain_name.t * Ipaddr.V6.Set.t
+  | Resolved_a_failed of [`host] Domain_name.t * string
+  | Resolved_aaaa_failed of [`host] Domain_name.t * string
+  | Connection_failed of [`host] Domain_name.t * id * (Ipaddr.t * int) * string
+  | Connected of [`host] Domain_name.t * id * (Ipaddr.t * int)
+
+val pp_event : event Fmt.t
+(** [pp_event ppf e] pretty-prints event [e] on [ppf]. *)
+
+val create : ?aaaa_timeout:int64 -> ?connect_delay:int64 ->
+  ?connect_timeout:int64 -> ?resolve_timeout:int64 -> ?resolve_retries:int ->
+  int64 -> t
+(** [create ~aaaa_timeout ~connect_delay ~connect_timeout ~resolve_timeout ~resolve_retries ts]
+    creates the internal state, initialized with the timestamp [ts] (an
+    arbitrary number that must be monotonically increasing). The timeouts are
+    specified in nanoseconds: the default of [aaaa_timeout] is
+    [Duration.of_ms 50], [connect_delay] is [Duration.of_ms 50],
+    [connect_timeout] is [Duration.of_sec 10], and [resolve_timeout] is
+    [Duration.of_sec 1]. The [resolve_retries] defaults to 3. *)
+
+val timer : t -> int64 -> t * [ `Suspend | `Act ] * action list
+(** [timer t ts] is a timer function that results in an updated [t] and either
+    [`Suspend] signalling that there are no pending connection establishments
+    and the timer thread can suspend, or [`Act] that the timer should be called
+    again after sleeping. In addition, a list of actions that need to be
+    performed (connection establishment to be retried, connection failures to
+    be reported, ...) is provided.
+    If the timer thread has been suspended it should be signalled to resume
+    after calling [connect] or [connect_ip]. *)
+
+val connect : t -> int64 -> ?aaaa_timeout:int64 -> ?connect_delay:int64 ->
+  ?connect_timeout:int64 -> ?resolve_timeout:int64 -> ?resolve_retries:int ->
+  id:id -> [`host] Domain_name.t -> int list -> t * action list
+(** [connect t ts ~aaaa_timeout ~connect_delay ~connect_timeout ~resolve_timeout ~resolve_retries ~id host ports]
+    attempts a connection to [host], where the [ports] are attempted in
+    sequence. It results in an updated [t] and a list of actions to be
+    performed. The timeouts and delays are specified in nanoseconds, and default
+    to the value provided when {!create} was executed.
+
+    @raise Failure if [ports] is the empty list. *)
+
+val connect_ip : t -> int64 -> ?aaaa_timeout:int64 -> ?connect_delay:int64 ->
+  ?connect_timeout:int64 -> id:id -> (Ipaddr.t * int) list -> t * action list
+(** [connect_ip t ts ~aaaa_timeout ~connect_delay ~connect_timeout ~id addresses]
+    attempts a connection to
+    [addresses]. By default, the list will be tried in sequence. The ports will
+    be tried in sequence. The result is an updated [t] and a list of actions to
+    be performed. The timeouts and delays are specified in nanoseconds, and
+    default to the values provided when {!create} was executed.
+
+    @raise Failure if [addresses] is the empty list. *)
+
+val event : t -> int64 -> event -> t * action list
+(** [event t ts ev] results in an updated [t] and a list of actions to be
+    performed.
+
+    @raise Failure if [ev] contains an empty set of IP addresses. *)
+
+val resolve_timeout : t -> int64
+(** [resolve_timeout t] is the timeout for the resolver in nanoseconds. *)
+
+(** A map for waiters and internal id. *)
+module Waiter_map : sig
+  include Map.S with type key = id
+
+  val register : 'a -> 'a t -> 'a t * id
+  (** [register v t] registers [v] in [t], and returns the updated map and
+      the key that was used. *)
+
+  val find_and_remove : id -> 'a t -> 'a t * 'a option
+  (** [find_and_remove id t] looks up [id] in [t], and removes [id] from [t]. *)
+end