Skip to content

Commit

Permalink
eio(client): add dns-client-eio.opam package
Browse files Browse the repository at this point in the history
Add `dns-client-eio` opam package. The package implements
`dns_client` functionality using the `eio` package. It is
compatible with OCaml version 5.0 and above.

`Dns_client_eio` attempts to connect to the given dns name servers
as specified by the happy eyeballs spec -
https://datatracker.ietf.org/doc/html/rfc8305#section-3.1.
  • Loading branch information
bikallem committed Jun 28, 2022
1 parent 50132ef commit acc4f5a
Show file tree
Hide file tree
Showing 4 changed files with 256 additions and 0 deletions.
29 changes: 29 additions & 0 deletions dns-client-eio.opam
Original file line number Diff line number Diff line change
@@ -0,0 +1,29 @@
opam-version: "2.0"
maintainer: "team AT robur dot io"
authors: ["Bikal Gurung <gbikal@gmail.com>"]
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" {>= version}
"mirage-crypto-rng-eio" {>= version}
]
synopsis: "DNS client for eio"
description: """
A resolver implementation using uDNS and eio.
"""
198 changes: 198 additions & 0 deletions eio/client/dns_client_eio.ml
Original file line number Diff line number Diff line change
@@ -0,0 +1,198 @@
module E = Eio

type env = <
clock : E.Time.clock ;
net : E.Net.t;
fs : E.Dir.t;
secure_random : Eio.Flow.source;
>

type io_addr = Ipaddr.t * int
type stack = env * E.Switch.t

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 context = E.Net.stream_socket

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 ; (* Timeout in nano seconds *)
env : env;
sw : E.Switch.t ;
mutex : E.Mutex.t ;
}

let read_file env file =
match E.Dir.load (E.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
let mutex = E.Mutex.create () in
{ nameservers; timeout_ns = timeout; env; sw; mutex }

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) = E.Mutex.use_ro t.mutex @@ fun () -> Queue.peek ns_q in
let ip = ipaddr_octects ip |> E.Net.Ipaddr.of_raw in
let stream = `Tcp (ip, port) in
try
let timeout = Duration.to_f t.timeout_ns in
E.Time.with_timeout_exn (E.Stdenv.clock t.env) timeout @@ fun () ->
let flow = E.Net.connect ~sw:t.sw (E.Stdenv.net t.env) stream in
Ok flow
with E.Time.Timeout ->
(* Push the non responsive nameserver to the back of the queue. *)
let ns = E.Mutex.use_rw ~protect:true t.mutex @@ fun () -> 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 = E.Flow.cstruct_source [dns_query] in
E.Flow.copy src ctx;
let dns_response = Cstruct.create 2048 in
let got = E.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 E.Flow.close flow with _ -> ()
let bind a f = f a
let lift v = v
end

module Client = Dns_client.Make(Transport)
module type DNS_CLIENT = module type of Dns_client.Make(Transport)

let run env (f:(module DNS_CLIENT) -> 'a) =
Mirage_crypto_rng_eio.run (module Mirage_crypto_rng.Fortuna) env @@ fun () ->
f (module Client)
15 changes: 15 additions & 0 deletions eio/client/dns_client_eio.mli
Original file line number Diff line number Diff line change
@@ -0,0 +1,15 @@
type env = <
clock : Eio.Time.clock ;
net : Eio.Net.t ;
fs : Eio.Dir.t ;
secure_random : Eio.Flow.source;
>

module Transport : Dns_client.S
with type io_addr = Ipaddr.t * int
and type stack = env * Eio.Switch.t
and type +'a io = 'a

module type DNS_CLIENT = module type of Dns_client.Make(Transport)

val run : < env; ..> -> ((module DNS_CLIENT) -> 'a) -> 'a
14 changes: 14 additions & 0 deletions eio/client/dune
Original file line number Diff line number Diff line change
@@ -0,0 +1,14 @@
(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
mirage-crypto-rng-eio))

0 comments on commit acc4f5a

Please sign in to comment.