Source file happy_eyeballs_mirage.ml

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