diff --git a/.gitignore b/.gitignore index d0ad5f6b..90b72992 100644 --- a/.gitignore +++ b/.gitignore @@ -9,3 +9,4 @@ coverage/ *key *private *pem +vendor diff --git a/dns-client-eio.opam b/dns-client-eio.opam new file mode 100644 index 00000000..bc04128c --- /dev/null +++ b/dns-client-eio.opam @@ -0,0 +1,36 @@ +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"} + "duration" {>= "0.2.1"} + "base-domains" + "ipaddr" {>= "5.3.0"} + "dns-client" {>= version} + "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"} + "fmt" {>= "0.8.8"} + "logs" {>= "0.7.0"} + "eio" {>= "0.7.0"} + "tls-eio" {>= "0.15.5"} + "ca-certs" {>= "0.2.3"} +] +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 00000000..eaa737b4 --- /dev/null +++ b/eio/client/dns_client_eio.ml @@ -0,0 +1,315 @@ +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 = [`Plaintext of Ipaddr.t * int | `Tls of Ipaddr.t * int] +type stack = { + 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) + +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 : 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 recv_buf : Cstruct.t ; + mutable closed : bool ; + } + + (* 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_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 %s: %a" stack.resolv_conf 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 -> + List.map (function `Nameserver ip -> [`Plaintext (ip, 53); `Tls (ip, 853)]) ips + |> List.flatten + |> Result.ok + + let 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 + + 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}) + ; 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_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 ()) + + 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 fiber_of_action = function + | Happy_eyeballs.Connect (host, id, (ip, port)) -> + fun () -> + let ip' = + (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)); + 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 + | 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); + 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)) + + 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 = + 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 = 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 ns in + begin match he_handle_actions t he actions with + | 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 ctx = + { t = t + ; requests = IM.empty + ; ns_connection = conn + ; recv_buf = Cstruct.create 2048 + ; closed = false + } + in + 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, ctx) + | 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 + + and recv_dns_packets ?(recv_data = Cstruct.empty) (ctx : context) = + + 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 = + 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 + 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 + ; fs = env#fs + } + in + f stack + ) + ) diff --git a/eio/client/dns_client_eio.mli b/eio/client/dns_client_eio.mli new file mode 100644 index 00000000..39b05f5a --- /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 = [`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 + -> _ 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 00000000..7b5c5557 --- /dev/null +++ b/eio/client/dune @@ -0,0 +1,27 @@ +(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 + domain-name + ca-certs + eio + tls-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 00000000..f5d13b01 --- /dev/null +++ b/eio/client/ohost.ml @@ -0,0 +1,90 @@ +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 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 (reporter Format.std_formatter); + + Eio_main.run @@ fun env -> + Dns_client_eio.run env @@ fun stack -> + 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 + ) + 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 () = + Printexc.record_backtrace true; + exit (Cmd.eval cmd)