Implement a missing TODO

lib/mirage/impl/mirage_impl_happy_eyeballs.ml

@@ -3,12 +3,13 @@ open Mirage_impl_time
 open Mirage_impl_mclock
 open Mirage_impl_stack
 open Mirage_impl_dns
+open Mirage_impl_misc
 
 type happy_eyeballs = Happy_eyeballs
 
 let happy_eyeballs = Type.v Happy_eyeballs
 
-let generic_happy_eyeballs aaaa_timeout connect_delay _connect_timeout
+let generic_happy_eyeballs aaaa_timeout connect_delay connect_timeout
     resolve_timeout resolve_retries timer_interval =
   let packages =
     [ package "happy-eyeballs-mirage" ~min:"0.6.0" ~max:"1.0.0" ]
@@ -22,28 +23,40 @@ let generic_happy_eyeballs aaaa_timeout connect_delay _connect_timeout
     |> cons_if_some timer_interval
     |> List.map Runtime_key.v
   in
-  let connect _info _modname = function
-    | [ _time; _mclock; _stack; _dns ] ->
-        (* let pp_optional_argument ~name ppf = function
-             | None -> ()
-             | Some key -> Fmt.pf ppf "?%s:%a " name Runtime_key.call key
-           in
-           Fmt.str {ocaml|%s.connect_device %a%a%a%a%a%a %s %s|ocaml} modname
-             (pp_optional_argument ~name:"aaaa_timeout")
-             aaaa_timeout
-             (pp_optional_argument ~name:"connect_delay")
-             connect_delay
-             (pp_optional_argument ~name:"connect_timeout")
-             connect_timeout
-             (pp_optional_argument ~name:"resolve_timeout")
-             resolve_timeout
-             (pp_optional_argument ~name:"resolve_retries")
-             resolve_retries
-             (pp_optional_argument ~name:"timer_interval")
-             timer_interval dns stack
-        *)
-        failwith "TODO"
-    | _ -> assert false
+  let pp_optional_argument ~name ppf = function
+    | None -> ()
+    | Some key -> Fmt.pf ppf "?%s:%s " name key
+  in
+  let err () = connect_err "generic_happy_eyeballs" 5 ~max:11 in
+  let pop x rest =
+    match (rest, x) with
+    | h :: t, Some _ -> (Some h, t)
+    | _, None -> (None, rest)
+    | _ -> err ()
+  in
+  let connect _info modname = function
+    | _time :: _mclock :: stack :: dns :: rest ->
+        let aaaa_timeout, rest = pop aaaa_timeout rest in
+        let connect_delay, rest = pop connect_delay rest in
+        let connect_timeout, rest = pop connect_timeout rest in
+        let resolve_timeout, rest = pop resolve_timeout rest in
+        let resolve_retries, rest = pop resolve_retries rest in
+        let timer_interval, rest = pop timer_interval rest in
+        let () = match rest with [] -> () | _ -> err () in
+        Fmt.str {ocaml|%s.connect_device %a%a%a%a%a%a %s %s|ocaml} modname
+          (pp_optional_argument ~name:"aaaa_timeout")
+          aaaa_timeout
+          (pp_optional_argument ~name:"connect_delay")
+          connect_delay
+          (pp_optional_argument ~name:"connect_timeout")
+          connect_timeout
+          (pp_optional_argument ~name:"resolve_timeout")
+          resolve_timeout
+          (pp_optional_argument ~name:"resolve_retries")
+          resolve_retries
+          (pp_optional_argument ~name:"timer_interval")
+          timer_interval dns stack
+    | _ -> err ()
   in
   impl ~runtime_keys ~packages ~connect "Happy_eyeballs_mirage.Make"
     (time @-> mclock @-> stackv4v6 @-> dns_client @-> happy_eyeballs)