From 2fc6e1f81a21fb86f338792fd20530eeb35c8f33 Mon Sep 17 00:00:00 2001 From: Bikal Lem Date: Mon, 13 Jun 2022 16:35:54 +0100 Subject: [PATCH 1/5] dns-client(eio): new dns-client backend - dns-client-eio Add `dns-client-eio` opam package - an eio backe-end for dns-client. It is compatible with OCaml version 5.0 and above. --- dns-client-eio.opam | 32 ++++ eio/client/dns_client_eio.ml | 290 ++++++++++++++++++++++++++++++++++ eio/client/dns_client_eio.mli | 37 +++++ eio/client/dune | 23 +++ eio/client/ohost.ml | 67 ++++++++ 5 files changed, 449 insertions(+) create mode 100644 dns-client-eio.opam create mode 100644 eio/client/dns_client_eio.ml create mode 100644 eio/client/dns_client_eio.mli create mode 100644 eio/client/dune create mode 100644 eio/client/ohost.ml diff --git a/dns-client-eio.opam b/dns-client-eio.opam new file mode 100644 index 000000000..c6739fa21 --- /dev/null +++ b/dns-client-eio.opam @@ -0,0 +1,32 @@ +opam-version: "2.0" +maintainer: "Bikal Gurung " +authors: ["Bikal Gurung "] +homepage: "https://github.com/mirage/ocaml-dns" +bug-reports: "https://github.com/mirage/ocaml-dns/issues" +dev-repo: "git+https://github.com/mirage/ocaml-dns.git" +license: "BSD-2-Clause" + +build: [ + [ "dune" "subst"] {dev} + [ "dune" "build" "-p" name "-j" jobs ] + [ "dune" "runtest" "-p" name "-j" jobs ] {with-test} +] + +depends: [ + "dune" {>="3.2"} + "cstruct" {>= "6.0.0"} + "base-domains" + "ipaddr" {>= "5.3.0"} + "dns-client" {>= version} + "mirage-clock" {>= "3.0.0"} + "mtime" {>= "1.2.0"} + "mirage-crypto-rng-eio" {>= "0.10.7"} + "domain-name" {>= "0.4.0"} + "mtime" {>= "1.2.0"} + "fmt" {>= "0.8.8"} + "eio_main" {>= "0.5"} +] +synopsis: "DNS client for eio" +description: """ +A resolver implementation using uDNS and eio. +""" diff --git a/eio/client/dns_client_eio.ml b/eio/client/dns_client_eio.ml new file mode 100644 index 000000000..b634b2eb8 --- /dev/null +++ b/eio/client/dns_client_eio.ml @@ -0,0 +1,290 @@ +type 'a env = < + clock : Eio.Time.clock ; + mono_clock : Eio.Time.Mono.t ; + net : Eio.Net.t ; + fs : Eio.Fs.dir Eio.Path.t ; + secure_random : Eio.Flow.source; + .. +> as 'a + +type io_addr = Ipaddr.t * int +type stack = { + sw : Eio.Switch.t; + mono_clock : Eio.Time.Mono.t; + net : Eio.Net.t; + resolv_conf : Eio.Fs.dir Eio.Path.t +} + +module IM = Map.Make(Int) + +let src = Logs.Src.create "dns_client_eio" ~doc:"eio backend for DNS client" +module Log = (val Logs.src_log src: Logs.LOG) + +module Transport : Dns_client.S + with type io_addr = io_addr + and type stack = stack + and type +'a io = 'a += struct + type nonrec io_addr = io_addr + type nonrec stack = stack + type +'a io = 'a + + type t = + { nameservers : nameservers + ; stack : stack + ; timeout : Eio.Time.Timeout.t + ; mutable ns_connection_condition : Eio.Condition.t option + ; mutable ctx : (Dns.proto * context) option + } + + and context = + { t : t + ; mutable requests : Cstruct.t Eio.Promise.u IM.t + ; mutable ns_connection: + ; mutable buf : Cstruct.t + } + + (* DNS nameservers. *) + and nameservers = + | Static of io_addr list + | Resolv_conf of resolv_conf + + (* /etc/resolv.conf *) + and resolv_conf = { + mutable ips : io_addr list ; + mutable digest : Digest.t option ; + } + + let read_file file = + match Eio.Path.load file with + | content -> Ok content + | exception e -> + Fmt.error_msg "Error while reading file %a: %a" Eio.Path.pp file Fmt.exn e + + let ( let* ) = Result.bind + let ( let+ ) r f = Result.map f r + + let decode_resolv_conf data = + let* ips = Dns_resolvconf.parse data in + match ips with + | [] -> Error (`Msg "empty nameservers from resolv.conf") + | ips -> Ok (List.map (function `Nameserver ip -> (ip, 53)) ips) + + let default_resolvers = + List.(map + (fun ip -> (ip, 53)) + ((::) (Ipaddr.of_string_exn "1.1.1.1", Dns_client.default_resolvers))) + + let rng = Mirage_crypto_rng.generate ?g:None + let clock = Mtime_clock.elapsed_ns + + let create ?nameservers ~timeout stack = + { nameservers = + (match nameservers with + | Some (`Udp,_) -> invalid_arg "UDP is not supported" + | Some (`Tcp, []) -> Static default_resolvers + | Some (`Tcp, ns) -> Static ns + | None -> + (let* data = read_file stack.resolv_conf in + let+ ips = decode_resolv_conf data in + (ips, Some (Digest.string data))) + |> function + | Error _ -> Resolv_conf { ips = default_resolvers; digest = None} + | Ok(ips, digest) -> Resolv_conf {ips; digest}) + ; stack + ; timeout = Eio.Time.Timeout.v stack.mono_clock @@ Mtime.Span.of_uint64_ns timeout + ; ns_connection_condition = None + ; ctx = None + } + + let nameserver_ips t = + match t.nameservers with + | Static ips -> ips + | Resolv_conf{ ips;_ } -> ips + + let nameservers t = (`Tcp, nameserver_ips t) + + let maybe_update_nameservers t = + let update_resolv_conf resolv_conf data dgst = + match decode_resolv_conf data with + | Ok ips -> + resolv_conf.digest <- Some dgst; + resolv_conf.ips <- ips; + | Error _ -> + resolv_conf.digest <- None; + resolv_conf.ips <- default_resolvers + in + match t.nameservers with + | Static _ -> () + | Resolv_conf resolv_conf -> + (match read_file t.stack.resolv_conf, resolv_conf.digest with + | Ok data, Some d -> + let digest = Digest.string data in + if Digest.equal digest d then () else update_resolv_conf resolv_conf data digest + | Ok data, None -> update_resolv_conf resolv_conf data (Digest.string data) + | Error _, None -> () + | Error _, Some _ -> + resolv_conf.digest <- None; + resolv_conf.ips <- default_resolvers) + + let rec he_handle_actions t he actions = + let fiber_of_action = function + | Happy_eyeballs.Connect (host, id, (ip, port)) -> + fun () -> + let ip' = + begin match ip with + | Ipaddr.V4 ip -> Ipaddr.V4.to_octets ip + | Ipaddr.V6 ip -> Ipaddr.V6.to_octets ip + end + |> Eio.Net.Ipaddr.of_raw + in + let stream = `Tcp (ip', port) in + begin try + Eio.Time.Timeout.run_exn t.timeout (fun () -> + let flow = Eio.Net.connect ~sw:t.stack.sw t.stack.net stream in + Log.debug (fun m -> m "he_handle_actions: connected to nameserver (%a)" + Fmt.(pair ~sep:comma Ipaddr.pp int) (ip, port)); + Some flow) + with Eio.Time.Timeout -> + Log.debug (fun m -> m "he_handle_actions: connection to nameserver (%a) timed out" + Fmt.(pair ~sep:comma Ipaddr.pp int) (ip, port)); + let event = Happy_eyeballs.Connection_failed (host, id, (ip, port)) in + let he, actions = Happy_eyeballs.event he (clock ()) event in + he_handle_actions t he actions + end + | Happy_eyeballs.Connect_failed (_host, id) -> + fun () -> + Logs.debug (fun m -> m "he_handle_actions: connection failed %d" id); + None + | a -> + fun () -> + Log.warn (fun m -> m "he_handle_actions: ignoring action %a" Happy_eyeballs.pp_action a); + None + in + Eio.Fiber.any (List.map fiber_of_action actions) + + let rec connect t = + Log.debug (fun m -> m "connect : establishing connection to nameservers"); + match t.ctx, t.ns_connection_condition with + | Some ctx, _ -> Ok ctx + | None, Some condition -> + Eio.Condition.await_no_mutex condition; + connect t + | None, None -> + let ns_connection_condition = Eio.Condition.create () in + t.ns_connection_condition <- Some ns_connection_condition; + maybe_update_nameservers t; + let ns = nameserver_ips t in + let he = Happy_eyeballs.create (clock ()) in + let he, actions = Happy_eyeballs.connect_ip he (clock ()) ~id:1 ns in + begin match he_handle_actions t he actions with + | Some ns_connection -> + let context = + { t = t + ; requests = IM.empty + ; ns_connection + ; buf = Cstruct.empty + } + in + t.ctx <- Some (`Tcp, context); + Eio.Condition.broadcast ns_connection_condition; + Ok (`Tcp, context) + | None -> + t.ns_connection_condition <- None; + Eio.Condition.broadcast ns_connection_condition; + let error_msg = + Fmt.str "unable to connect to nameservers %a" + Fmt.(list ~sep:(any ", ") (pair ~sep:(any ":") Ipaddr.pp int)) + (nameserver_ips t) + in + Logs.debug (fun m -> m "connect : %s" error_msg); + Error (`Msg error_msg) + end + + let rec recv_data ?(min=2) t fd id : unit = + let buf = Cstruct.create 512 in + Logs.debug (fun m -> m "recv_data (%d): t.buf.len %d" id (Cstruct.length t.buf)); + let got = Eio.Flow.single_read fd buf in + Logs.debug (fun m -> m "recv_data (%d): got %d" id got); + let buf = Cstruct.sub buf 0 got in + t.buf <- if Cstruct.length t.buf = 0 then buf else Cstruct.append t.buf buf; + Logs.debug (fun m -> m "recv_data (%d): t.buf.len %d" id (Cstruct.length t.buf)); + if got < min then recv_data ~min t fd id + + let rec recv_packet t ns_connection request_id = + Logs.debug (fun m -> m "recv_packet (%d): recv_packet" request_id); + let buf_len = Cstruct.length t.buf in + if buf_len > 2 then ( + let packet_len = Cstruct.BE.get_uint16 t.buf 0 in + Logs.debug (fun m -> m "recv_packet (%d): packet_len %d" request_id (Cstruct.length t.buf)); + if buf_len - 2 >= packet_len then + let packet, rest = + if buf_len - 2 = packet_len + then t.buf, Cstruct.empty + else Cstruct.split t.buf (packet_len + 2) + in + t.buf <- rest; + let response_id = Cstruct.BE.get_uint16 packet 2 in + Logs.debug (fun m -> m "recv_packet (%d): response %d" request_id response_id); + if response_id = request_id + then packet + else begin + (match IM.find response_id t.requests with + | r -> Eio.Promise.resolve r packet + | exception Not_found -> ()); + recv_packet t ns_connection request_id + end + else begin + recv_data ~min:packet_len t ns_connection request_id; + recv_packet t ns_connection request_id + end + ) + else begin + recv_data t ns_connection request_id; + recv_packet t ns_connection request_id + end + + let validate_query_packet tx = + if Cstruct.length tx > 4 then Ok () else + Error (`Msg "Invalid DNS query packet (data length <= 4)") + + let send_recv ctx packet = + let* () = validate_query_packet packet in + try + let request_id = Cstruct.BE.get_uint16 packet 2 in + Eio.Time.Timeout.run_exn ctx.t.timeout (fun () -> + Eio.Flow.write ctx.ns_connection [packet]; + Logs.debug (fun m -> m "send_recv (%d): request" request_id); + let response_p, response_r = Eio.Promise.create () in + ctx.requests <- IM.add request_id response_r ctx.requests; + let response = + Eio.Fiber.first + (fun () -> recv_packet ctx ctx.ns_connection request_id) + (fun () -> Eio.Promise.await response_p) + in + Logs.debug (fun m -> m "send_recv (%d): got response" request_id); + Ok response + ) + with + | Eio.Time.Timeout -> Error (`Msg "DNS request timeout") + | exn -> Error (`Msg (Printexc.to_string_default exn)) + + let close _ = () + let bind a f = f a + let lift v = v +end + +include Dns_client.Make(Transport) + +let run ?(resolv_conf = "/etc/resolv.conf") (env: _ env) f = + Mirage_crypto_rng_eio.run (module Mirage_crypto_rng.Fortuna) env (fun () -> + Eio.Switch.run (fun sw -> + let stack = { + sw; + mono_clock = env#mono_clock; + net = env#net; + resolv_conf = Eio.Path.(env#fs / resolv_conf) } + in + f stack + ) + ) diff --git a/eio/client/dns_client_eio.mli b/eio/client/dns_client_eio.mli new file mode 100644 index 000000000..bc6a6f738 --- /dev/null +++ b/eio/client/dns_client_eio.mli @@ -0,0 +1,37 @@ +type 'a env = < + clock : Eio.Time.clock ; + mono_clock : Eio.Time.Mono.t ; + net : Eio.Net.t ; + fs : Eio.Fs.dir Eio.Path.t ; + secure_random : Eio.Flow.source ; + .. +> as 'a + +module Transport : Dns_client.S + with type io_addr = Ipaddr.t * int + and type +'a io = 'a + +include module type of Dns_client.Make(Transport) + +val run : + ?resolv_conf:string + -> _ env + -> (Transport.stack -> 'a) + -> 'a +(** [run env f] executes [f] which can call various dns client functions defined in + [Dns_client.S]. + + @param resolv_conf is the local path to [resolv_conf] file. It is by default set to + [/etc/resolv.conf]. + + Example: + {[ + let () = + Eio_main.run @@ fun env -> + Dns_client_eio.run @@ fun stack -> + let t = Dns_client_eio.create stack in + let dn = Domain_name.(host_exn (of_string_exn "tarides.com")) in + match Dns_client_eio.gethostbyname t dn with + | OK addr -> Fmt.pr "%a has IPv4 address %a\n" Domain_name.pp Ipaddr.V4.pp addr + | Error (`Msg e) -> Fmt.pr "Error %s" e + ]} *) diff --git a/eio/client/dune b/eio/client/dune new file mode 100644 index 000000000..f00d05ed8 --- /dev/null +++ b/eio/client/dune @@ -0,0 +1,23 @@ +(library + (name dns_client_eio) + (modules dns_client_eio) + (public_name dns-client-eio) + (libraries + cstruct + duration + ipaddr + dns-client + dns-client.resolvconf + happy-eyeballs + mtime + mtime.clock.os + mirage-crypto-rng + mirage-crypto-rng-eio)) + +(executable + (name ohost) + (modules ohost) + (public_name dns-client-eio.ohost) + (package dns-client-eio) + (libraries dns-client-eio mtime.clock.os eio_main domain-name fmt + cmdliner fmt.cli logs.cli logs.fmt fmt.tty)) diff --git a/eio/client/ohost.ml b/eio/client/ohost.ml new file mode 100644 index 000000000..d449e4114 --- /dev/null +++ b/eio/client/ohost.ml @@ -0,0 +1,67 @@ +open Cmdliner + +let (let+) r f = Result.map f r + +(* Retrieve IPv4 address for domain name [dn] if any. *) +let ipv4 t dn () = + match Dns_client_eio.gethostbyname t dn with + | Ok addr -> Ok ("IPv4", Fmt.str "%a has IPv4 address %a\n" Domain_name.pp dn Ipaddr.V4.pp addr) + | Error (`Msg m) -> Error ("IPv4", m) + +let ipv6 t dn () = + match Dns_client_eio.gethostbyname6 t dn with + | Ok addr -> Ok ("IPv6", Fmt.str "%a has IPv6 address %a\n" Domain_name.pp dn Ipaddr.V6.pp addr) + | Error (`Msg m) -> Error ("IPv6", m) + +let mx t dn () = + match Dns_client_eio.getaddrinfo t Mx dn with + | Ok (_ttl, resp) -> Ok + ("MX", Fmt.str "%a\n" + (Fmt.list (fun ppf -> Fmt.pf ppf "%a mail is handled by %a" Domain_name.pp dn Dns.Mx.pp)) + (Dns.Rr_map.Mx_set.elements resp)) + | Error (`Msg m) -> Error ("MX", m) + +let is_error = (function Error _ -> true | Ok _ -> false) + +let display_host_ips h_name style_renderer level = + Fmt_tty.setup_std_outputs ?style_renderer () ; + Logs.set_level level; + Logs.set_reporter (Logs_fmt.reporter ()); + + Eio_main.run @@ fun env -> + Dns_client_eio.run env @@ fun stack -> + let t = Dns_client_eio.create ~timeout:1_000_000_000L stack in + let dn = Domain_name.(host_exn (of_string_exn h_name)) in + let tasks = [ipv4 t dn; ipv6 t dn; mx t dn] in + let results = Eio.Fiber.List.map (fun f -> f ()) tasks in + + List.iter + (function + | Ok (nm, s) -> Fmt.pr "[Ok] %4s: %s\n" nm s + | Error (nm, msg) -> Fmt.pr "[Err] %4s: %s\n" nm msg + ) + results + +let cmd = + let host_arg = + let doc = "host/domain name, e.g. www.tarides.com" in + Arg.(required & pos 0 (some' string) None & info [] ~docv:"HOST" ~doc) + in + let ohost_t = + Term.(const + display_host_ips + $ host_arg + $ Fmt_cli.style_renderer () + $ Logs_cli.level () + ) + in + let doc = "Displays IPv4, IPv6 and Mail(MX) ip addresses for given host" in + let man = + [ `S Manpage.s_bugs + ; `P "Email bug reports to gbikal AT gmail.com" + ] + in + let info = Cmd.info "ohost" ~version:"%%VERSION%%" ~doc ~man in + Cmd.v info ohost_t + +let () = exit (Cmd.eval cmd) From 1144a58f1e61f9be078c1529445af557db91d42e Mon Sep 17 00:00:00 2001 From: Bikal Lem Date: Mon, 28 Nov 2022 17:23:27 +0000 Subject: [PATCH 2/5] dns-client(eio): add tcp/tls nameserver support --- dns-client-eio.opam | 10 +++-- eio/client/dns_client_eio.ml | 77 +++++++++++++++++++++++++---------- eio/client/dns_client_eio.mli | 2 +- eio/client/dune | 6 ++- 4 files changed, 68 insertions(+), 27 deletions(-) diff --git a/dns-client-eio.opam b/dns-client-eio.opam index c6739fa21..bc04128cf 100644 --- a/dns-client-eio.opam +++ b/dns-client-eio.opam @@ -15,16 +15,20 @@ build: [ depends: [ "dune" {>="3.2"} "cstruct" {>= "6.0.0"} + "duration" {>= "0.2.1"} "base-domains" "ipaddr" {>= "5.3.0"} "dns-client" {>= version} - "mirage-clock" {>= "3.0.0"} + "dns-client.resolvconf" {>= version} + "happy-eyeballs" {>= "0.3.0"} "mtime" {>= "1.2.0"} "mirage-crypto-rng-eio" {>= "0.10.7"} "domain-name" {>= "0.4.0"} - "mtime" {>= "1.2.0"} "fmt" {>= "0.8.8"} - "eio_main" {>= "0.5"} + "logs" {>= "0.7.0"} + "eio" {>= "0.7.0"} + "tls-eio" {>= "0.15.5"} + "ca-certs" {>= "0.2.3"} ] synopsis: "DNS client for eio" description: """ diff --git a/eio/client/dns_client_eio.ml b/eio/client/dns_client_eio.ml index b634b2eb8..55f05b7be 100644 --- a/eio/client/dns_client_eio.ml +++ b/eio/client/dns_client_eio.ml @@ -7,7 +7,7 @@ type 'a env = < .. > as 'a -type io_addr = Ipaddr.t * int +type io_addr = [`Plaintext of Ipaddr.t * int | `Tls of Tls.Config.client * Ipaddr.t * int] type stack = { sw : Eio.Switch.t; mono_clock : Eio.Time.Mono.t; @@ -40,7 +40,7 @@ module Transport : Dns_client.S and context = { t : t ; mutable requests : Cstruct.t Eio.Promise.u IM.t - ; mutable ns_connection: + ; mutable ns_connection: ; mutable buf : Cstruct.t } @@ -64,16 +64,35 @@ module Transport : Dns_client.S let ( let* ) = Result.bind let ( let+ ) r f = Result.map f r + let authenticator = + let authenticator_ref = ref None in + fun () -> + match !authenticator_ref with + | Some x -> x + | None -> match Ca_certs.authenticator () with + | Ok a -> authenticator_ref := Some a ; a + | Error `Msg m -> invalid_arg ("failed to load trust anchors: " ^ m) + let decode_resolv_conf data = let* ips = Dns_resolvconf.parse data in + let authenticator = authenticator () in match ips with | [] -> Error (`Msg "empty nameservers from resolv.conf") - | ips -> Ok (List.map (function `Nameserver ip -> (ip, 53)) ips) + | ips -> + List.map + (function `Nameserver ip -> + let tls_config = Tls.Config.client ~authenticator ~ip () in + [`Plaintext (ip, 53); `Tls (tls_config, ip, 853)] + ) + ips + |> List.flatten + |> Result.ok - let default_resolvers = - List.(map - (fun ip -> (ip, 53)) - ((::) (Ipaddr.of_string_exn "1.1.1.1", Dns_client.default_resolvers))) + let default_resolvers () = + let authenticator = authenticator () in + let peer_name = Dns_client.default_resolver_hostname in + let tls_config = Tls.Config.client ~authenticator ~peer_name () in + List.map (fun ip -> `Tls (tls_config, ip, 853)) Dns_client.default_resolvers let rng = Mirage_crypto_rng.generate ?g:None let clock = Mtime_clock.elapsed_ns @@ -82,14 +101,14 @@ module Transport : Dns_client.S { nameservers = (match nameservers with | Some (`Udp,_) -> invalid_arg "UDP is not supported" - | Some (`Tcp, []) -> Static default_resolvers + | Some (`Tcp, []) -> Static (default_resolvers ()) | Some (`Tcp, ns) -> Static ns | None -> (let* data = read_file stack.resolv_conf in let+ ips = decode_resolv_conf data in (ips, Some (Digest.string data))) |> function - | Error _ -> Resolv_conf { ips = default_resolvers; digest = None} + | Error _ -> Resolv_conf { ips = default_resolvers (); digest = None} | Ok(ips, digest) -> Resolv_conf {ips; digest}) ; stack ; timeout = Eio.Time.Timeout.v stack.mono_clock @@ Mtime.Span.of_uint64_ns timeout @@ -112,7 +131,7 @@ module Transport : Dns_client.S resolv_conf.ips <- ips; | Error _ -> resolv_conf.digest <- None; - resolv_conf.ips <- default_resolvers + resolv_conf.ips <- default_resolvers () in match t.nameservers with | Static _ -> () @@ -125,9 +144,16 @@ module Transport : Dns_client.S | Error _, None -> () | Error _, Some _ -> resolv_conf.digest <- None; - resolv_conf.ips <- default_resolvers) + resolv_conf.ips <- default_resolvers ()) + + let find_ns t (ip, port) = + List.find + (function `Plaintext (ip', p) + | `Tls (_, ip', p) -> Ipaddr.compare ip ip' = 0 && p = port + ) + (nameserver_ips t) - let rec he_handle_actions t he actions = + let rec he_handle_actions t he actions : #Eio.Flow.two_way option = let fiber_of_action = function | Happy_eyeballs.Connect (host, id, (ip, port)) -> fun () -> @@ -144,6 +170,11 @@ module Transport : Dns_client.S let flow = Eio.Net.connect ~sw:t.stack.sw t.stack.net stream in Log.debug (fun m -> m "he_handle_actions: connected to nameserver (%a)" Fmt.(pair ~sep:comma Ipaddr.pp int) (ip, port)); + let flow = + match find_ns t (ip, port) with + | `Plaintext _ -> (flow :> Eio.Flow.two_way) + | `Tls (config, _,_) -> (Tls_eio.client_of_flow config flow :> Eio.Flow.two_way) + in Some flow) with Eio.Time.Timeout -> Log.debug (fun m -> m "he_handle_actions: connection to nameserver (%a) timed out" @@ -163,6 +194,9 @@ module Transport : Dns_client.S in Eio.Fiber.any (List.map fiber_of_action actions) + let to_ip_port = + List.map (function `Plaintext (ip, port) -> (ip, port) | `Tls (_, ip, port) -> (ip, port)) + let rec connect t = Log.debug (fun m -> m "connect : establishing connection to nameservers"); match t.ctx, t.ns_connection_condition with @@ -174,15 +208,15 @@ module Transport : Dns_client.S let ns_connection_condition = Eio.Condition.create () in t.ns_connection_condition <- Some ns_connection_condition; maybe_update_nameservers t; - let ns = nameserver_ips t in + let ns = to_ip_port @@ nameserver_ips t in let he = Happy_eyeballs.create (clock ()) in let he, actions = Happy_eyeballs.connect_ip he (clock ()) ~id:1 ns in begin match he_handle_actions t he actions with - | Some ns_connection -> + | Some conn -> let context = { t = t ; requests = IM.empty - ; ns_connection + ; ns_connection = conn ; buf = Cstruct.empty } in @@ -195,21 +229,20 @@ module Transport : Dns_client.S let error_msg = Fmt.str "unable to connect to nameservers %a" Fmt.(list ~sep:(any ", ") (pair ~sep:(any ":") Ipaddr.pp int)) - (nameserver_ips t) + (to_ip_port @@ nameserver_ips t) in Logs.debug (fun m -> m "connect : %s" error_msg); Error (`Msg error_msg) end - let rec recv_data ?(min=2) t fd id : unit = + let rec recv_data t flow id : unit = let buf = Cstruct.create 512 in Logs.debug (fun m -> m "recv_data (%d): t.buf.len %d" id (Cstruct.length t.buf)); - let got = Eio.Flow.single_read fd buf in + let got = Eio.Flow.single_read flow buf in Logs.debug (fun m -> m "recv_data (%d): got %d" id got); let buf = Cstruct.sub buf 0 got in t.buf <- if Cstruct.length t.buf = 0 then buf else Cstruct.append t.buf buf; - Logs.debug (fun m -> m "recv_data (%d): t.buf.len %d" id (Cstruct.length t.buf)); - if got < min then recv_data ~min t fd id + Logs.debug (fun m -> m "recv_data (%d): t.buf.len %d" id (Cstruct.length t.buf)) let rec recv_packet t ns_connection request_id = Logs.debug (fun m -> m "recv_packet (%d): recv_packet" request_id); @@ -235,7 +268,7 @@ module Transport : Dns_client.S recv_packet t ns_connection request_id end else begin - recv_data ~min:packet_len t ns_connection request_id; + recv_data t ns_connection request_id; recv_packet t ns_connection request_id end ) @@ -249,7 +282,7 @@ module Transport : Dns_client.S Error (`Msg "Invalid DNS query packet (data length <= 4)") let send_recv ctx packet = - let* () = validate_query_packet packet in + let* () = validate_query_packet packet in try let request_id = Cstruct.BE.get_uint16 packet 2 in Eio.Time.Timeout.run_exn ctx.t.timeout (fun () -> diff --git a/eio/client/dns_client_eio.mli b/eio/client/dns_client_eio.mli index bc6a6f738..9ed87a1a3 100644 --- a/eio/client/dns_client_eio.mli +++ b/eio/client/dns_client_eio.mli @@ -8,7 +8,7 @@ type 'a env = < > as 'a module Transport : Dns_client.S - with type io_addr = Ipaddr.t * int + with type io_addr = [`Plaintext of Ipaddr.t * int | `Tls of Tls.Config.client * Ipaddr.t * int] and type +'a io = 'a include module type of Dns_client.Make(Transport) diff --git a/eio/client/dune b/eio/client/dune index f00d05ed8..7b5c5557a 100644 --- a/eio/client/dune +++ b/eio/client/dune @@ -12,7 +12,11 @@ mtime mtime.clock.os mirage-crypto-rng - mirage-crypto-rng-eio)) + mirage-crypto-rng-eio + domain-name + ca-certs + eio + tls-eio)) (executable (name ohost) From d98235afbc7c2f0cbd0d9d18128f573600c9a0ef Mon Sep 17 00:00:00 2001 From: Bikal Lem Date: Tue, 29 Nov 2022 15:20:19 +0000 Subject: [PATCH 3/5] dns-client(eio): support udp nameservers --- eio/client/dns_client_eio.ml | 53 +++++++++++++++++++---------------- eio/client/dns_client_eio.mli | 6 ++-- 2 files changed, 32 insertions(+), 27 deletions(-) diff --git a/eio/client/dns_client_eio.ml b/eio/client/dns_client_eio.ml index 55f05b7be..258841f3d 100644 --- a/eio/client/dns_client_eio.ml +++ b/eio/client/dns_client_eio.ml @@ -9,10 +9,11 @@ type 'a env = < type io_addr = [`Plaintext of Ipaddr.t * int | `Tls of Tls.Config.client * Ipaddr.t * int] type stack = { - sw : Eio.Switch.t; - mono_clock : Eio.Time.Mono.t; - net : Eio.Net.t; - resolv_conf : Eio.Fs.dir Eio.Path.t + fs : Eio.Fs.dir Eio.Path.t; + sw : Eio.Switch.t; + mono_clock : Eio.Time.Mono.t; + net : Eio.Net.t; + resolv_conf : string; } module IM = Map.Make(Int) @@ -30,7 +31,7 @@ module Transport : Dns_client.S type +'a io = 'a type t = - { nameservers : nameservers + { nameservers : Dns.proto * nameservers ; stack : stack ; timeout : Eio.Time.Timeout.t ; mutable ns_connection_condition : Eio.Condition.t option @@ -55,11 +56,11 @@ module Transport : Dns_client.S mutable digest : Digest.t option ; } - let read_file file = - match Eio.Path.load file with + let read_resolv_conf stack = + match Eio.Path.(stack.fs / stack.resolv_conf) |> Eio.Path.load with | content -> Ok content | exception e -> - Fmt.error_msg "Error while reading file %a: %a" Eio.Path.pp file Fmt.exn e + Fmt.error_msg "Error while reading file %s: %a" stack.resolv_conf Fmt.exn e let ( let* ) = Result.bind let ( let+ ) r f = Result.map f r @@ -101,15 +102,17 @@ module Transport : Dns_client.S { nameservers = (match nameservers with | Some (`Udp,_) -> invalid_arg "UDP is not supported" - | Some (`Tcp, []) -> Static (default_resolvers ()) - | Some (`Tcp, ns) -> Static ns + | Some (proto, []) -> proto, Static (default_resolvers ()) + | Some (`Tcp, ns) -> `Tcp, Static ns | None -> - (let* data = read_file stack.resolv_conf in + (let* data = read_resolv_conf stack in let+ ips = decode_resolv_conf data in (ips, Some (Digest.string data))) |> function - | Error _ -> Resolv_conf { ips = default_resolvers (); digest = None} - | Ok(ips, digest) -> Resolv_conf {ips; digest}) + | Error (`Msg e) -> + Log.warn (fun m -> m "failed to decode %s - %s" stack.resolv_conf e); + (`Tcp, Resolv_conf { ips = default_resolvers (); digest = None}) + | Ok(ips, digest) -> `Tcp, Resolv_conf {ips; digest}) ; stack ; timeout = Eio.Time.Timeout.v stack.mono_clock @@ Mtime.Span.of_uint64_ns timeout ; ns_connection_condition = None @@ -118,8 +121,8 @@ module Transport : Dns_client.S let nameserver_ips t = match t.nameservers with - | Static ips -> ips - | Resolv_conf{ ips;_ } -> ips + | _, Static ips -> ips + | _, Resolv_conf{ ips;_ } -> ips let nameservers t = (`Tcp, nameserver_ips t) @@ -134,9 +137,9 @@ module Transport : Dns_client.S resolv_conf.ips <- default_resolvers () in match t.nameservers with - | Static _ -> () - | Resolv_conf resolv_conf -> - (match read_file t.stack.resolv_conf, resolv_conf.digest with + | _, Static _ -> () + | _, Resolv_conf resolv_conf -> + (match read_resolv_conf t.stack, resolv_conf.digest with | Ok data, Some d -> let digest = Digest.string data in if Digest.equal digest d then () else update_resolv_conf resolv_conf data digest @@ -235,7 +238,7 @@ module Transport : Dns_client.S Error (`Msg error_msg) end - let rec recv_data t flow id : unit = + let recv_data t flow id : unit = let buf = Cstruct.create 512 in Logs.debug (fun m -> m "recv_data (%d): t.buf.len %d" id (Cstruct.length t.buf)); let got = Eio.Flow.single_read flow buf in @@ -312,11 +315,13 @@ include Dns_client.Make(Transport) let run ?(resolv_conf = "/etc/resolv.conf") (env: _ env) f = Mirage_crypto_rng_eio.run (module Mirage_crypto_rng.Fortuna) env (fun () -> Eio.Switch.run (fun sw -> - let stack = { - sw; - mono_clock = env#mono_clock; - net = env#net; - resolv_conf = Eio.Path.(env#fs / resolv_conf) } + let stack = + { sw + ; mono_clock = env#mono_clock + ; net = env#net + ; resolv_conf + ; fs = env#fs + } in f stack ) diff --git a/eio/client/dns_client_eio.mli b/eio/client/dns_client_eio.mli index 9ed87a1a3..8ec184ac2 100644 --- a/eio/client/dns_client_eio.mli +++ b/eio/client/dns_client_eio.mli @@ -14,7 +14,7 @@ module Transport : Dns_client.S include module type of Dns_client.Make(Transport) val run : - ?resolv_conf:string + ?resolv_conf:string -> _ env -> (Transport.stack -> 'a) -> 'a @@ -22,8 +22,8 @@ val run : [Dns_client.S]. @param resolv_conf is the local path to [resolv_conf] file. It is by default set to - [/etc/resolv.conf]. - + [/etc/resolv.conf]. + Example: {[ let () = From 2fa2f980b44b04bdd8bf6f4ed10c8dbdd072979e Mon Sep 17 00:00:00 2001 From: Bikal Lem Date: Sat, 10 Dec 2022 01:02:40 +0000 Subject: [PATCH 4/5] dns-client(eio): update to latest happy-eyeballs --- .gitignore | 1 + eio/client/dns_client_eio.ml | 269 +++++++++++++++++----------------- eio/client/dns_client_eio.mli | 4 +- eio/client/ohost.ml | 49 +++++-- 4 files changed, 170 insertions(+), 153 deletions(-) diff --git a/.gitignore b/.gitignore index d0ad5f6b9..90b72992c 100644 --- a/.gitignore +++ b/.gitignore @@ -9,3 +9,4 @@ coverage/ *key *private *pem +vendor diff --git a/eio/client/dns_client_eio.ml b/eio/client/dns_client_eio.ml index 258841f3d..2c8c7338b 100644 --- a/eio/client/dns_client_eio.ml +++ b/eio/client/dns_client_eio.ml @@ -7,7 +7,7 @@ type 'a env = < .. > as 'a -type io_addr = [`Plaintext of Ipaddr.t * int | `Tls of Tls.Config.client * Ipaddr.t * int] +type io_addr = [`Plaintext of Ipaddr.t * int | `Tls of Ipaddr.t * int] type stack = { fs : Eio.Fs.dir Eio.Path.t; sw : Eio.Switch.t; @@ -30,20 +30,20 @@ module Transport : Dns_client.S type nonrec stack = stack type +'a io = 'a - type t = - { nameservers : Dns.proto * nameservers - ; stack : stack - ; timeout : Eio.Time.Timeout.t - ; mutable ns_connection_condition : Eio.Condition.t option - ; mutable ctx : (Dns.proto * context) option - } + type t = { + nameservers : Dns.proto * nameservers ; + stack : stack ; + timeout : Eio.Time.Timeout.t ; + mutable ns_connection_condition : Eio.Condition.t option ; + mutable ctx : (Dns.proto * context) option ; + } - and context = - { t : t - ; mutable requests : Cstruct.t Eio.Promise.u IM.t - ; mutable ns_connection: - ; mutable buf : Cstruct.t - } + and context = { + t : t ; + mutable requests : Cstruct.t Eio.Promise.u IM.t ; + mutable ns_connection: ; + mutable buf : Cstruct.t ; + } (* DNS nameservers. *) and nameservers = @@ -65,35 +65,17 @@ module Transport : Dns_client.S let ( let* ) = Result.bind let ( let+ ) r f = Result.map f r - let authenticator = - let authenticator_ref = ref None in - fun () -> - match !authenticator_ref with - | Some x -> x - | None -> match Ca_certs.authenticator () with - | Ok a -> authenticator_ref := Some a ; a - | Error `Msg m -> invalid_arg ("failed to load trust anchors: " ^ m) - let decode_resolv_conf data = let* ips = Dns_resolvconf.parse data in - let authenticator = authenticator () in match ips with | [] -> Error (`Msg "empty nameservers from resolv.conf") | ips -> - List.map - (function `Nameserver ip -> - let tls_config = Tls.Config.client ~authenticator ~ip () in - [`Plaintext (ip, 53); `Tls (tls_config, ip, 853)] - ) - ips + List.map (function `Nameserver ip -> [`Plaintext (ip, 53); `Tls (ip, 853)]) ips |> List.flatten |> Result.ok let default_resolvers () = - let authenticator = authenticator () in - let peer_name = Dns_client.default_resolver_hostname in - let tls_config = Tls.Config.client ~authenticator ~peer_name () in - List.map (fun ip -> `Tls (tls_config, ip, 853)) Dns_client.default_resolvers + List.map (fun ip -> `Tls (ip, 853)) Dns_client.default_resolvers let rng = Mirage_crypto_rng.generate ?g:None let clock = Mtime_clock.elapsed_ns @@ -101,18 +83,18 @@ module Transport : Dns_client.S let create ?nameservers ~timeout stack = { nameservers = (match nameservers with - | Some (`Udp,_) -> invalid_arg "UDP is not supported" - | Some (proto, []) -> proto, Static (default_resolvers ()) - | Some (`Tcp, ns) -> `Tcp, Static ns - | None -> - (let* data = read_resolv_conf stack in - let+ ips = decode_resolv_conf data in - (ips, Some (Digest.string data))) - |> function - | Error (`Msg e) -> - Log.warn (fun m -> m "failed to decode %s - %s" stack.resolv_conf e); - (`Tcp, Resolv_conf { ips = default_resolvers (); digest = None}) - | Ok(ips, digest) -> `Tcp, Resolv_conf {ips; digest}) + | Some (`Udp,_) -> invalid_arg "UDP is not supported" + | Some (proto, []) -> proto, Static (default_resolvers ()) + | Some (`Tcp, ns) -> `Tcp, Static ns + | None -> + (let* data = read_resolv_conf stack in + let+ ips = decode_resolv_conf data in + (ips, Some (Digest.string data))) + |> function + | Error (`Msg e) -> + Log.warn (fun m -> m "failed to decode %s - %s" stack.resolv_conf e); + (`Tcp, Resolv_conf { ips = default_resolvers (); digest = None}) + | Ok(ips, digest) -> `Tcp, Resolv_conf {ips; digest}) ; stack ; timeout = Eio.Time.Timeout.v stack.mono_clock @@ Mtime.Span.of_uint64_ns timeout ; ns_connection_condition = None @@ -140,65 +122,67 @@ module Transport : Dns_client.S | _, Static _ -> () | _, Resolv_conf resolv_conf -> (match read_resolv_conf t.stack, resolv_conf.digest with - | Ok data, Some d -> - let digest = Digest.string data in - if Digest.equal digest d then () else update_resolv_conf resolv_conf data digest - | Ok data, None -> update_resolv_conf resolv_conf data (Digest.string data) - | Error _, None -> () - | Error _, Some _ -> - resolv_conf.digest <- None; - resolv_conf.ips <- default_resolvers ()) + | Ok data, Some d -> + let digest = Digest.string data in + if Digest.equal digest d then () else update_resolv_conf resolv_conf data digest + | Ok data, None -> update_resolv_conf resolv_conf data (Digest.string data) + | Error _, None -> () + | Error _, Some _ -> + resolv_conf.digest <- None; + resolv_conf.ips <- default_resolvers ()) let find_ns t (ip, port) = List.find - (function `Plaintext (ip', p) - | `Tls (_, ip', p) -> Ipaddr.compare ip ip' = 0 && p = port - ) + (function `Plaintext (ip', p) | `Tls (ip', p) -> Ipaddr.compare ip ip' = 0 && p = port) (nameserver_ips t) - let rec he_handle_actions t he actions : #Eio.Flow.two_way option = + let rec he_handle_actions t he actions = let fiber_of_action = function | Happy_eyeballs.Connect (host, id, (ip, port)) -> fun () -> let ip' = - begin match ip with - | Ipaddr.V4 ip -> Ipaddr.V4.to_octets ip - | Ipaddr.V6 ip -> Ipaddr.V6.to_octets ip - end + (match ip with + | Ipaddr.V4 ip -> Ipaddr.V4.to_octets ip + | Ipaddr.V6 ip -> Ipaddr.V6.to_octets ip) |> Eio.Net.Ipaddr.of_raw in let stream = `Tcp (ip', port) in begin try - Eio.Time.Timeout.run_exn t.timeout (fun () -> - let flow = Eio.Net.connect ~sw:t.stack.sw t.stack.net stream in - Log.debug (fun m -> m "he_handle_actions: connected to nameserver (%a)" - Fmt.(pair ~sep:comma Ipaddr.pp int) (ip, port)); - let flow = - match find_ns t (ip, port) with - | `Plaintext _ -> (flow :> Eio.Flow.two_way) - | `Tls (config, _,_) -> (Tls_eio.client_of_flow config flow :> Eio.Flow.two_way) - in - Some flow) - with Eio.Time.Timeout -> - Log.debug (fun m -> m "he_handle_actions: connection to nameserver (%a) timed out" - Fmt.(pair ~sep:comma Ipaddr.pp int) (ip, port)); - let event = Happy_eyeballs.Connection_failed (host, id, (ip, port)) in - let he, actions = Happy_eyeballs.event he (clock ()) event in - he_handle_actions t he actions + Eio.Time.Timeout.run_exn t.timeout (fun () -> + let flow = Eio.Net.connect ~sw:t.stack.sw t.stack.net stream in + Log.debug (fun m -> m "[he_handle_actions] connected to nameserver (%a)" + Fmt.(pair ~sep:comma Ipaddr.pp int) (ip, port)); + Some (ip, port, flow)) + with Eio.Time.Timeout as ex -> + Log.debug (fun m -> m "[he_handle_actions] connection to nameserver (%a) timed out" + Fmt.(pair ~sep:comma Ipaddr.pp int) (ip, port)); + let err = Printexc.to_string ex in + let event = Happy_eyeballs.Connection_failed (host, id, (ip, port), err) in + let he, actions = Happy_eyeballs.event he (clock ()) event in + he_handle_actions t he actions end - | Happy_eyeballs.Connect_failed (_host, id) -> + | Connect_failed _ -> fun () -> - Logs.debug (fun m -> m "he_handle_actions: connection failed %d" id); + Log.debug (fun m -> m "[he_handle_actions] connection failed"); None - | a -> + | Connect_cancelled _ | Resolve_a _ | Resolve_aaaa _ as a -> fun () -> - Log.warn (fun m -> m "he_handle_actions: ignoring action %a" Happy_eyeballs.pp_action a); + Log.warn (fun m -> m "[he_handle_actions] ignoring action %a" Happy_eyeballs.pp_action a); None in Eio.Fiber.any (List.map fiber_of_action actions) let to_ip_port = - List.map (function `Plaintext (ip, port) -> (ip, port) | `Tls (_, ip, port) -> (ip, port)) + List.map (function `Plaintext (ip, port) -> (ip, port) | `Tls (ip, port) -> (ip, port)) + + let authenticator = + let authenticator_ref = ref None in + fun () -> + match !authenticator_ref with + | Some x -> x + | None -> match Ca_certs.authenticator () with + | Ok a -> authenticator_ref := Some a ; a + | Error `Msg m -> invalid_arg ("failed to load trust anchors: " ^ m) let rec connect t = Log.debug (fun m -> m "connect : establishing connection to nameservers"); @@ -212,47 +196,56 @@ module Transport : Dns_client.S t.ns_connection_condition <- Some ns_connection_condition; maybe_update_nameservers t; let ns = to_ip_port @@ nameserver_ips t in + let _waiters, id = Happy_eyeballs.Waiter_map.(register () empty) in let he = Happy_eyeballs.create (clock ()) in - let he, actions = Happy_eyeballs.connect_ip he (clock ()) ~id:1 ns in + let he, actions = Happy_eyeballs.connect_ip he (clock ()) ~id ns in begin match he_handle_actions t he actions with - | Some conn -> - let context = - { t = t - ; requests = IM.empty - ; ns_connection = conn - ; buf = Cstruct.empty - } - in - t.ctx <- Some (`Tcp, context); - Eio.Condition.broadcast ns_connection_condition; - Ok (`Tcp, context) - | None -> - t.ns_connection_condition <- None; - Eio.Condition.broadcast ns_connection_condition; - let error_msg = - Fmt.str "unable to connect to nameservers %a" - Fmt.(list ~sep:(any ", ") (pair ~sep:(any ":") Ipaddr.pp int)) - (to_ip_port @@ nameserver_ips t) - in - Logs.debug (fun m -> m "connect : %s" error_msg); - Error (`Msg error_msg) + | Some (ip, port, conn) -> + let conn = + match find_ns t (ip, port) with + | `Plaintext _ -> (conn :> Eio.Flow.two_way) + | `Tls (_,_) -> + let authenticator = authenticator () in + let config = Tls.Config.(client ~authenticator ()) in + (Tls_eio.client_of_flow config conn :> Eio.Flow.two_way) + in + let context = + { t = t + ; requests = IM.empty + ; ns_connection = conn + ; buf = Cstruct.empty + } + in + t.ctx <- Some (`Tcp, context); + Eio.Condition.broadcast ns_connection_condition; + Ok (`Tcp, context) + | None -> + t.ns_connection_condition <- None; + Eio.Condition.broadcast ns_connection_condition; + let error_msg = + Fmt.str "unable to connect to nameservers %a" + Fmt.(list ~sep:(any ", ") (pair ~sep:(any ":") Ipaddr.pp int)) + (to_ip_port @@ nameserver_ips t) + in + Log.debug (fun m -> m "connect : %s" error_msg); + Error (`Msg error_msg) end let recv_data t flow id : unit = let buf = Cstruct.create 512 in - Logs.debug (fun m -> m "recv_data (%d): t.buf.len %d" id (Cstruct.length t.buf)); + Log.debug (fun m -> m "recv_data (%X): t.buf.len %d" id (Cstruct.length t.buf)); let got = Eio.Flow.single_read flow buf in - Logs.debug (fun m -> m "recv_data (%d): got %d" id got); + Log.debug (fun m -> m "recv_data (%X): got %d" id got); let buf = Cstruct.sub buf 0 got in t.buf <- if Cstruct.length t.buf = 0 then buf else Cstruct.append t.buf buf; - Logs.debug (fun m -> m "recv_data (%d): t.buf.len %d" id (Cstruct.length t.buf)) + Log.debug (fun m -> m "recv_data (%X): t.buf.len %d" id (Cstruct.length t.buf)) let rec recv_packet t ns_connection request_id = - Logs.debug (fun m -> m "recv_packet (%d): recv_packet" request_id); + Log.debug (fun m -> m "recv_packet (%X)" request_id); let buf_len = Cstruct.length t.buf in if buf_len > 2 then ( let packet_len = Cstruct.BE.get_uint16 t.buf 0 in - Logs.debug (fun m -> m "recv_packet (%d): packet_len %d" request_id (Cstruct.length t.buf)); + Log.debug (fun m -> m "recv_packet (%X): packet_len %d" request_id (Cstruct.length t.buf)); if buf_len - 2 >= packet_len then let packet, rest = if buf_len - 2 = packet_len @@ -261,13 +254,13 @@ module Transport : Dns_client.S in t.buf <- rest; let response_id = Cstruct.BE.get_uint16 packet 2 in - Logs.debug (fun m -> m "recv_packet (%d): response %d" request_id response_id); + Log.debug (fun m -> m "recv_packet (%X): got response %X" request_id response_id); if response_id = request_id then packet else begin (match IM.find response_id t.requests with - | r -> Eio.Promise.resolve r packet - | exception Not_found -> ()); + | r -> Eio.Promise.resolve r packet + | exception Not_found -> ()); recv_packet t ns_connection request_id end else begin @@ -282,28 +275,28 @@ module Transport : Dns_client.S let validate_query_packet tx = if Cstruct.length tx > 4 then Ok () else - Error (`Msg "Invalid DNS query packet (data length <= 4)") + Error (`Msg "Invalid DNS query packet (data length <= 4)") let send_recv ctx packet = let* () = validate_query_packet packet in try let request_id = Cstruct.BE.get_uint16 packet 2 in Eio.Time.Timeout.run_exn ctx.t.timeout (fun () -> - Eio.Flow.write ctx.ns_connection [packet]; - Logs.debug (fun m -> m "send_recv (%d): request" request_id); - let response_p, response_r = Eio.Promise.create () in - ctx.requests <- IM.add request_id response_r ctx.requests; - let response = - Eio.Fiber.first - (fun () -> recv_packet ctx ctx.ns_connection request_id) - (fun () -> Eio.Promise.await response_p) - in - Logs.debug (fun m -> m "send_recv (%d): got response" request_id); - Ok response - ) + Eio.Flow.write ctx.ns_connection [packet]; + Log.debug (fun m -> m "send_recv (%X): wrote request" request_id); + let response_p, response_r = Eio.Promise.create () in + ctx.requests <- IM.add request_id response_r ctx.requests; + let response = + Eio.Fiber.first + (fun () -> recv_packet ctx ctx.ns_connection request_id) + (fun () -> Eio.Promise.await response_p) + in + Log.debug (fun m -> m "send_recv (%X): got response" request_id); + Ok response + ) with | Eio.Time.Timeout -> Error (`Msg "DNS request timeout") - | exn -> Error (`Msg (Printexc.to_string_default exn)) + (* | exn -> Error (`Msg (Printexc.to_string exn)) *) let close _ = () let bind a f = f a @@ -314,15 +307,15 @@ include Dns_client.Make(Transport) let run ?(resolv_conf = "/etc/resolv.conf") (env: _ env) f = Mirage_crypto_rng_eio.run (module Mirage_crypto_rng.Fortuna) env (fun () -> - Eio.Switch.run (fun sw -> - let stack = - { sw - ; mono_clock = env#mono_clock - ; net = env#net - ; resolv_conf - ; fs = env#fs - } - in - f stack + Eio.Switch.run (fun sw -> + let stack = + { sw + ; mono_clock = env#mono_clock + ; net = env#net + ; resolv_conf + ; fs = env#fs + } + in + f stack + ) ) - ) diff --git a/eio/client/dns_client_eio.mli b/eio/client/dns_client_eio.mli index 8ec184ac2..39b05f5ae 100644 --- a/eio/client/dns_client_eio.mli +++ b/eio/client/dns_client_eio.mli @@ -8,13 +8,13 @@ type 'a env = < > as 'a module Transport : Dns_client.S - with type io_addr = [`Plaintext of Ipaddr.t * int | `Tls of Tls.Config.client * Ipaddr.t * int] + with type io_addr = [`Plaintext of Ipaddr.t * int | `Tls of Ipaddr.t * int] and type +'a io = 'a include module type of Dns_client.Make(Transport) val run : - ?resolv_conf:string + ?resolv_conf:string -> _ env -> (Transport.stack -> 'a) -> 'a diff --git a/eio/client/ohost.ml b/eio/client/ohost.ml index d449e4114..f5d13b01f 100644 --- a/eio/client/ohost.ml +++ b/eio/client/ohost.ml @@ -16,29 +16,50 @@ let ipv6 t dn () = let mx t dn () = match Dns_client_eio.getaddrinfo t Mx dn with | Ok (_ttl, resp) -> Ok - ("MX", Fmt.str "%a\n" - (Fmt.list (fun ppf -> Fmt.pf ppf "%a mail is handled by %a" Domain_name.pp dn Dns.Mx.pp)) - (Dns.Rr_map.Mx_set.elements resp)) + ("MX", Fmt.str "%a\n" + (Fmt.list (fun ppf -> Fmt.pf ppf "%a mail is handled by %a" Domain_name.pp dn Dns.Mx.pp)) + (Dns.Rr_map.Mx_set.elements resp)) | Error (`Msg m) -> Error ("MX", m) let is_error = (function Error _ -> true | Ok _ -> false) +let stamp_tag : Mtime.span Logs.Tag.def = + Logs.Tag.def "stamp" ~doc:"Relative monotonic time stamp" Mtime.Span.pp + +let stamp c = Logs.Tag.(empty |> add stamp_tag (Mtime_clock.count c)) + +let reporter ppf = + let report src level ~over k msgf = + let k _ = over (); k () in + let with_stamp h tags k ppf fmt = + let _stamp = match tags with + | None -> None + | Some tags -> Logs.Tag.find stamp_tag tags + in + Format.kfprintf k ppf ("[%s] %a @[" ^^ fmt ^^ "@]@.") + (Logs.Src.name src) + Logs.pp_header (level, h) + in + msgf @@ fun ?header ?tags fmt -> with_stamp header tags k ppf fmt + in + { Logs.report = report } + let display_host_ips h_name style_renderer level = Fmt_tty.setup_std_outputs ?style_renderer () ; Logs.set_level level; - Logs.set_reporter (Logs_fmt.reporter ()); + Logs.set_reporter (reporter Format.std_formatter); Eio_main.run @@ fun env -> Dns_client_eio.run env @@ fun stack -> - let t = Dns_client_eio.create ~timeout:1_000_000_000L stack in + let t = Dns_client_eio.create stack in let dn = Domain_name.(host_exn (of_string_exn h_name)) in let tasks = [ipv4 t dn; ipv6 t dn; mx t dn] in let results = Eio.Fiber.List.map (fun f -> f ()) tasks in List.iter (function - | Ok (nm, s) -> Fmt.pr "[Ok] %4s: %s\n" nm s - | Error (nm, msg) -> Fmt.pr "[Err] %4s: %s\n" nm msg + | Ok (nm, s) -> Fmt.pr "[Ok] %4s: %s\n" nm s + | Error (nm, msg) -> Fmt.pr "[Err] %4s: %s\n" nm msg ) results @@ -49,11 +70,11 @@ let cmd = in let ohost_t = Term.(const - display_host_ips - $ host_arg - $ Fmt_cli.style_renderer () - $ Logs_cli.level () - ) + display_host_ips + $ host_arg + $ Fmt_cli.style_renderer () + $ Logs_cli.level () + ) in let doc = "Displays IPv4, IPv6 and Mail(MX) ip addresses for given host" in let man = @@ -64,4 +85,6 @@ let cmd = let info = Cmd.info "ohost" ~version:"%%VERSION%%" ~doc ~man in Cmd.v info ohost_t -let () = exit (Cmd.eval cmd) +let () = + Printexc.record_backtrace true; + exit (Cmd.eval cmd) From a89d61e0bc478ed866d33a7e0af9e7a35fdb81bf Mon Sep 17 00:00:00 2001 From: Bikal Lem Date: Sun, 11 Dec 2022 16:50:32 +0000 Subject: [PATCH 5/5] dns-client(eio): improve performance --- eio/client/dns_client_eio.ml | 136 +++++++++++++++++------------------ 1 file changed, 65 insertions(+), 71 deletions(-) diff --git a/eio/client/dns_client_eio.ml b/eio/client/dns_client_eio.ml index 2c8c7338b..eaa737b44 100644 --- a/eio/client/dns_client_eio.ml +++ b/eio/client/dns_client_eio.ml @@ -30,7 +30,7 @@ module Transport : Dns_client.S type nonrec stack = stack type +'a io = 'a - type t = { + type t = { nameservers : Dns.proto * nameservers ; stack : stack ; timeout : Eio.Time.Timeout.t ; @@ -38,11 +38,12 @@ module Transport : Dns_client.S mutable ctx : (Dns.proto * context) option ; } - and context = { + and context = { t : t ; mutable requests : Cstruct.t Eio.Promise.u IM.t ; mutable ns_connection: ; - mutable buf : Cstruct.t ; + mutable recv_buf : Cstruct.t ; + mutable closed : bool ; } (* DNS nameservers. *) @@ -161,10 +162,7 @@ module Transport : Dns_client.S let he, actions = Happy_eyeballs.event he (clock ()) event in he_handle_actions t he actions end - | Connect_failed _ -> - fun () -> - Log.debug (fun m -> m "[he_handle_actions] connection failed"); - None + | Connect_failed _ -> fun () -> None | Connect_cancelled _ | Resolve_a _ | Resolve_aaaa _ as a -> fun () -> Log.warn (fun m -> m "[he_handle_actions] ignoring action %a" Happy_eyeballs.pp_action a); @@ -185,7 +183,6 @@ module Transport : Dns_client.S | Error `Msg m -> invalid_arg ("failed to load trust anchors: " ^ m) let rec connect t = - Log.debug (fun m -> m "connect : establishing connection to nameservers"); match t.ctx, t.ns_connection_condition with | Some ctx, _ -> Ok ctx | None, Some condition -> @@ -209,16 +206,18 @@ module Transport : Dns_client.S let config = Tls.Config.(client ~authenticator ()) in (Tls_eio.client_of_flow config conn :> Eio.Flow.two_way) in - let context = + let ctx = { t = t ; requests = IM.empty ; ns_connection = conn - ; buf = Cstruct.empty + ; recv_buf = Cstruct.create 2048 + ; closed = false } in - t.ctx <- Some (`Tcp, context); + t.ctx <- Some (`Tcp, ctx); + Eio.Fiber.fork ~sw:t.stack.sw ( fun () -> recv_dns_packets ctx ); Eio.Condition.broadcast ns_connection_condition; - Ok (`Tcp, context) + Ok (`Tcp, ctx) | None -> t.ns_connection_condition <- None; Eio.Condition.broadcast ns_connection_condition; @@ -231,72 +230,67 @@ module Transport : Dns_client.S Error (`Msg error_msg) end - let recv_data t flow id : unit = - let buf = Cstruct.create 512 in - Log.debug (fun m -> m "recv_data (%X): t.buf.len %d" id (Cstruct.length t.buf)); - let got = Eio.Flow.single_read flow buf in - Log.debug (fun m -> m "recv_data (%X): got %d" id got); - let buf = Cstruct.sub buf 0 got in - t.buf <- if Cstruct.length t.buf = 0 then buf else Cstruct.append t.buf buf; - Log.debug (fun m -> m "recv_data (%X): t.buf.len %d" id (Cstruct.length t.buf)) + and recv_dns_packets ?(recv_data = Cstruct.empty) (ctx : context) = - let rec recv_packet t ns_connection request_id = - Log.debug (fun m -> m "recv_packet (%X)" request_id); - let buf_len = Cstruct.length t.buf in - if buf_len > 2 then ( - let packet_len = Cstruct.BE.get_uint16 t.buf 0 in - Log.debug (fun m -> m "recv_packet (%X): packet_len %d" request_id (Cstruct.length t.buf)); - if buf_len - 2 >= packet_len then - let packet, rest = - if buf_len - 2 = packet_len - then t.buf, Cstruct.empty - else Cstruct.split t.buf (packet_len + 2) - in - t.buf <- rest; - let response_id = Cstruct.BE.get_uint16 packet 2 in - Log.debug (fun m -> m "recv_packet (%X): got response %X" request_id response_id); - if response_id = request_id - then packet - else begin - (match IM.find response_id t.requests with - | r -> Eio.Promise.resolve r packet - | exception Not_found -> ()); - recv_packet t ns_connection request_id - end - else begin - recv_data t ns_connection request_id; - recv_packet t ns_connection request_id - end - ) - else begin - recv_data t ns_connection request_id; - recv_packet t ns_connection request_id - end + let append_recv_buf ctx got recv_data = + let buf = Cstruct.sub ctx.recv_buf 0 got in + if Cstruct.is_empty recv_data + then buf + else Cstruct.append recv_data buf + in + + let rec handle_data recv_data = + let recv_data_len = Cstruct.length recv_data in + if recv_data_len < 2 + then recv_dns_packets ~recv_data ctx + else + match Cstruct.BE.get_uint16 recv_data 0 with + | packet_len when recv_data_len - 2 >= packet_len -> + let packet, recv_data = Cstruct.split recv_data @@ packet_len + 2 in + let response_id = Cstruct.BE.get_uint16 packet 2 in + (match IM.find response_id ctx.requests with + | r -> + ctx.requests <- IM.remove response_id ctx.requests ; + Eio.Promise.resolve r packet + | exception Not_found -> () (* spurious data, ignore *) + ); + if not @@ IM.is_empty ctx.requests then handle_data recv_data else () + | _ -> recv_dns_packets ~recv_data ctx + in + + match Eio.Flow.single_read ctx.ns_connection ctx.recv_buf with + | got -> + let recv_data = append_recv_buf ctx got recv_data in + handle_data recv_data + | exception End_of_file -> + ctx.t.ns_connection_condition <- None ; + ctx.t.ctx <- None ; + ctx.closed <- true ; + if not @@ IM.is_empty ctx.requests then + (match connect ctx.t with + | Ok _ -> recv_dns_packets ~recv_data ctx + | Error _ -> Log.warn (fun m -> m "[recv_dns_packets] connection closed while processing dns requests") ) + else () let validate_query_packet tx = if Cstruct.length tx > 4 then Ok () else Error (`Msg "Invalid DNS query packet (data length <= 4)") let send_recv ctx packet = - let* () = validate_query_packet packet in - try - let request_id = Cstruct.BE.get_uint16 packet 2 in - Eio.Time.Timeout.run_exn ctx.t.timeout (fun () -> - Eio.Flow.write ctx.ns_connection [packet]; - Log.debug (fun m -> m "send_recv (%X): wrote request" request_id); - let response_p, response_r = Eio.Promise.create () in - ctx.requests <- IM.add request_id response_r ctx.requests; - let response = - Eio.Fiber.first - (fun () -> recv_packet ctx ctx.ns_connection request_id) - (fun () -> Eio.Promise.await response_p) - in - Log.debug (fun m -> m "send_recv (%X): got response" request_id); - Ok response - ) - with - | Eio.Time.Timeout -> Error (`Msg "DNS request timeout") - (* | exn -> Error (`Msg (Printexc.to_string exn)) *) + if not ctx.closed then + let* () = validate_query_packet packet in + try + let request_id = Cstruct.BE.get_uint16 packet 2 in + let response_p, response_r = Eio.Promise.create () in + ctx.requests <- IM.add request_id response_r ctx.requests; + Eio.Time.Timeout.run_exn ctx.t.timeout (fun () -> + Eio.Flow.write ctx.ns_connection [packet]; + let response = Eio.Promise.await response_p in + Ok response + ) + with Eio.Time.Timeout -> Error (`Msg "DNS request timeout") + else + Error (`Msg "Nameserver closed connection") let close _ = () let bind a f = f a