From 789a97fb438270e8b305a93329a49f3498f3e329 Mon Sep 17 00:00:00 2001 From: Bikal Lem Date: Mon, 13 Jun 2022 16:35:54 +0100 Subject: [PATCH] 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)