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

@@ -0,0 +1,29 @@
+opam-version: "2.0"
+maintainer: "team AT robur dot io"
+authors: ["Bikal Gurung <[email protected]>"]
+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.
+"""

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 

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))