From 6c7813852b97861c2ed05fd07542a59ef12172fd Mon Sep 17 00:00:00 2001 From: Bikal Lem Date: Mon, 13 Jun 2022 16:35:54 +0100 Subject: [PATCH] eio(client): add Dns_client_eio module This commit implements Dns_client_eio which connects to dns name servers in a round robin fashion. It prioritises IPv6 servers compared to IPv4 servers and pushes a server name to the last of the queue if connection to it is not successful. --- dns-client-eio.opam | 29 ++++++ eio/client/dns_client_eio.ml | 177 +++++++++++++++++++++++++++++++++++ eio/client/dune | 12 +++ 3 files changed, 218 insertions(+) create mode 100644 dns-client-eio.opam create mode 100644 eio/client/dns_client_eio.ml create mode 100644 eio/client/dune diff --git a/dns-client-eio.opam b/dns-client-eio.opam new file mode 100644 index 000000000..bc40ed250 --- /dev/null +++ b/dns-client-eio.opam @@ -0,0 +1,29 @@ +opam-version: "2.0" +maintainer: "team AT robur dot io" +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" {>= "0.8.0"} + "mirage-crypto-rng-eio" {>= "0.8.0"} +] +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..313947526 --- /dev/null +++ b/eio/client/dns_client_eio.ml @@ -0,0 +1,177 @@ +open Eio + +module Transport : Dns_client.S + with type io_addr = Ipaddr.t * int + and type stack = (Stdenv.t * Switch.t) + and type +'a io = 'a += struct + type io_addr = Ipaddr.t * int + type stack = (Stdenv.t * Eio.Switch.t) + type +'a io = 'a + type nameservers = + | Static of io_addr Queue.t + | Resolv_conf of { + mutable nameservers : io_addr Queue.t ; + mutable digest : Digest.t option ; + } + type t = { + nameservers : nameservers ; + timeout_ns : int64 ; + env : Stdenv.t; + sw : Switch.t; + } + type context = Net.stream_socket + + let read_file env file = + match Dir.load (Stdenv.fs env) file with + | content -> Ok content + | exception e -> + let err = "Error while reading file: " ^ file ^ ". " ^ (Printexc.to_string e) in + Error (`Msg err) + + (* Prioritises IPv6 nameservers before IPv4 nameservers so that we + are more conformant with the happy eyballs RFC when implementing it. + https://datatracker.ietf.org/doc/html/rfc8305#section-3 *) + let ipv6_first_queue ns = + ns + |> List.sort ( fun (a,_) (b,_) -> + match a, b with + | Ipaddr.V4 _, Ipaddr.V4 _ -> 0 + | Ipaddr.V6 _, Ipaddr.V6 _ -> 0 + | Ipaddr.V6 _, Ipaddr.V4 _ -> -1 + | Ipaddr.V4 _, Ipaddr.V6 _ -> 1 ) + |> List.to_seq + |> Queue.of_seq + + let decode_resolv_conf data = + match Dns_resolvconf.parse data with + | Ok [] -> Error (`Msg "empty nameservers from resolv.conf") + | Ok ips -> + ips + |> List.map (function `Nameserver ip -> (ip, 53)) + |> ipv6_first_queue + |> Result.ok + | Error _ as e -> e + + let default_resolvers () = + Dns_client.default_resolvers + |> List.map (fun ip -> ip, 53) + |> ipv6_first_queue + + let create ?nameservers ~timeout (env, sw) = + let nameservers = + match nameservers with + | Some (proto, ns) -> begin + match proto with + | `Udp -> invalid_arg "UDP is not supported" + | `Tcp -> + let ns = match ns with + | [] -> default_resolvers () + | ns -> ipv6_first_queue ns in + Static ns + end + | None -> + let nameservers, digest = + match + let ( let* ) = Result.bind in + let* data = read_file env "/etc/resolv.conf" in + let* ips = decode_resolv_conf data in + Ok (ips, Digest.string data) + with + | Error _ -> default_resolvers (), None + | Ok(ips, digest) -> (ips, Some digest) + in + (Resolv_conf { nameservers; digest }) + in + { nameservers; timeout_ns = timeout; env; sw } + + let nameservers0 + { nameservers = + Static nameservers + | Resolv_conf {nameservers; _ } ; + _ } = + nameservers + + let nameservers t = + let nameservers = + nameservers0 t + |> Queue.to_seq + |> List.of_seq + in + (`Tcp, nameservers) + + let rng = Mirage_crypto_rng.generate ?g:None + let clock = Mtime_clock.elapsed_ns + + let maybe_resolve_conf t = + match t.nameservers with + | Static _ -> () + | Resolv_conf resolv_conf -> + let decode_update data dgst = + match decode_resolv_conf data with + | Ok ips -> + resolv_conf.digest <- Some dgst; + resolv_conf.nameservers <- ips; + | Error _ -> + resolv_conf.digest <- None; + resolv_conf.nameservers <- default_resolvers () + in + match read_file t.env "/etc/resolv.conf", resolv_conf.digest with + | Ok data, Some d -> + let digest = Digest.string data in + if Digest.equal digest d then () else decode_update data digest + | Ok data, None -> decode_update data (Digest.string data) + | Error _, None -> () + | Error _, Some _ -> + resolv_conf.digest <- None; + resolv_conf.nameservers <- default_resolvers () + + let ipaddr_octects = function + | Ipaddr.V4 ip -> Ipaddr.V4.to_octets ip + | Ipaddr.V6 ip -> Ipaddr.V6.to_octets ip + + (* Attempt to connect to nameservers in a round robin fashion. + If we are unable to connect within a given timeout value, then + the nameserver is pushed to the back of the queue. + If none of the connection attempts are successful then + Error is returned. + *) + let rec try_ns_connection t n ns_q = + if n >= Queue.length ns_q then + Error (`Msg "Unable to connect to specified nameservers") + else + let (ip, port) = Queue.peek ns_q in + let ip = ipaddr_octects ip |> Net.Ipaddr.of_raw in + let stream = `Tcp (ip, port) in + try + let timeout = Duration.to_f t.timeout_ns in + Time.with_timeout_exn (Stdenv.clock t.env) timeout @@ fun () -> + let flow = Net.connect ~sw:t.sw (Stdenv.net t.env) stream in + Ok flow + with Time.Timeout -> + (* Push the non responsive nameserver to the back of the queue. *) + let ns = Queue.pop ns_q in + Queue.push ns ns_q; + try_ns_connection t (n + 1) ns_q + + let connect t = + maybe_resolve_conf t; + nameservers0 t + |> try_ns_connection t 0 + + let send_recv ctx dns_query = + if Cstruct.length dns_query > 4 then + try + let src = Flow.cstruct_source [dns_query] in + Flow.copy src ctx; + let dns_response = Cstruct.create 2048 in + let got = Flow.read ctx dns_response in + Ok (Cstruct.sub dns_response 0 got) + with e -> Error (`Msg (Printexc.to_string e)) + else + Error (`Msg "Invalid DNS query packet (data length <= 4)") + + let close flow = try Flow.close flow with _ -> () + let bind a f = f a + let lift v = v +end diff --git a/eio/client/dune b/eio/client/dune new file mode 100644 index 000000000..4753818b5 --- /dev/null +++ b/eio/client/dune @@ -0,0 +1,12 @@ +(library + (name dns_client_eio) + (public_name dns-client-eio) + (libraries + cstruct + duration + logs + ipaddr + dns-client + dns-client.resolvconf + mtime.clock.os + mirage-crypto-rng-eio))