From c4f91423768985b50753338bf4bb1a59a2c054b9 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 10 Nov 2021 15:26:17 +0100 Subject: [PATCH] DNS: address code review comments, use qubes-primary-dns from QubesDB --- dao.ml | 11 ++++------- dao.mli | 2 +- my_dns.ml | 17 ++++++++++------- unikernel.ml | 2 +- 4 files changed, 16 insertions(+), 16 deletions(-) diff --git a/dao.ml b/dao.ml index 383b1b6..30b4c2d 100644 --- a/dao.ml +++ b/dao.ml @@ -125,7 +125,7 @@ type network_config = { uplink_our_ip : Ipaddr.V4.t; (* The IP address of our interface to NetVM *) clients_our_ip : Ipaddr.V4.t; (* The IP address of our interface to our client VMs (their gateway) *) - dns : Ipaddr.V4.t list; + dns : Ipaddr.V4.t; } exception Missing_key of string @@ -138,19 +138,16 @@ let try_read_network_config db = let uplink_our_ip = get "/qubes-ip" |> Ipaddr.V4.of_string_exn in let uplink_netvm_ip = get "/qubes-gateway" |> Ipaddr.V4.of_string_exn in let clients_our_ip = get "/qubes-netvm-gateway" |> Ipaddr.V4.of_string_exn in - let dns = - [ get "/qubes-primary-dns" |> Ipaddr.V4.of_string_exn ; - get "/qubes-secondary-dns" |> Ipaddr.V4.of_string_exn ] - in + let dns = get "/qubes-primary-dns" |> Ipaddr.V4.of_string_exn in Log.info (fun f -> f "@[Got network configuration from QubesDB:@,\ NetVM IP on uplink network: %a@,\ Our IP on uplink network: %a@,\ Our IP on client networks: %a@,\ - DNS resolvers: %a@]" + DNS resolver: %a@]" Ipaddr.V4.pp uplink_netvm_ip Ipaddr.V4.pp uplink_our_ip Ipaddr.V4.pp clients_our_ip - Fmt.(list ~sep:(any ", ") Ipaddr.V4.pp) dns); + Ipaddr.V4.pp dns); { uplink_netvm_ip; uplink_our_ip; clients_our_ip ; dns } let read_network_config qubesDB = diff --git a/dao.mli b/dao.mli index 94d418e..be6ebb9 100644 --- a/dao.mli +++ b/dao.mli @@ -24,7 +24,7 @@ type network_config = { uplink_our_ip : Ipaddr.V4.t; (* The IP address of our interface to NetVM *) clients_our_ip : Ipaddr.V4.t; (* The IP address of our interface to our client VMs (their gateway) *) - dns : Ipaddr.V4.t list; + dns : Ipaddr.V4.t; } val read_network_config : Qubes.DB.t -> network_config Lwt.t diff --git a/my_dns.ml b/my_dns.ml index ca2c0f8..24aeac3 100644 --- a/my_dns.ml +++ b/my_dns.ml @@ -3,22 +3,26 @@ open Lwt.Infix module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) = struct type +'a io = 'a Lwt.t type io_addr = Ipaddr.V4.t * int - type ns_addr = Dns.proto * io_addr list type stack = Router.t * (src_port:int -> dst:Ipaddr.V4.t -> dst_port:int -> Cstruct.t -> (unit, [ `Msg of string ]) result Lwt.t) * (Udp_packet.t * Cstruct.t) Lwt_mvar.t type t = { - nameservers : ns_addr ; + protocol : Dns.proto ; + nameserver : io_addr ; stack : stack ; timeout_ns : int64 ; } type context = { t : t ; timeout_ns : int64 ref; mutable src_port : int } - let nameservers t = t.nameservers + let nameservers { protocol ; nameserver ; _ } = protocol, [ nameserver ] let rng = R.generate ?g:None let clock = C.elapsed_ns - let create ?(nameservers = `Udp, [(Ipaddr.V4.of_string_exn "91.239.100.100", 53)]) ~timeout stack = - { nameservers ; stack ; timeout_ns = timeout } + let create ?nameservers ~timeout stack = + let protocol, nameserver = match nameservers with + | None | Some (_, []) -> invalid_arg "no nameserver found" + | Some (proto, ns :: _) -> proto, ns + in + { protocol ; nameserver ; stack ; timeout_ns = timeout } let with_timeout ctx f = let timeout = OS.Time.sleep_ns !(ctx.timeout_ns) >|= fun () -> Error (`Msg "DNS request timeout") in @@ -33,8 +37,7 @@ module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) = struct let send (ctx : context) buf : (unit, [> `Msg of string ]) result Lwt.t = let open Router in let open My_nat in - let nslist = snd ctx.t.nameservers in - let dst, dst_port = List.hd nslist in + let dst, dst_port = ctx.t.nameserver in let router, send_udp, _ = ctx.t.stack in let src_port = Ports.pick_free_port ~consult:router.ports.nat_udp router.ports.dns_udp in ctx.src_port <- src_port; diff --git a/unikernel.ml b/unikernel.ml index 0621e42..cccb710 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -81,7 +81,7 @@ module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK) = struct let send_dns_query = Uplink.send_dns_client_query uplink in let dns_mvar = Lwt_mvar.create_empty () in - let nameservers = `Udp, List.map (fun ip -> ip, 53) config.Dao.dns in + let nameservers = `Udp, [ config.Dao.dns, 53 ] in let dns_client = Dns_client.create ~nameservers (router, send_dns_query, dns_mvar) in let net_listener = network (Dns_client.getaddrinfo dns_client Dns.Rr_map.A) dns_mvar uplink qubesDB router in