Git-Mirrors/qubes-mirage-firewall
1
0
Fork 0
mirror of https://github.com/mirage/qubes-mirage-firewall.git synced 2024-10-01 01:05:39 -04:00
Code Issues Packages Projects Releases Wiki Activity

DNS: address code review comments, use qubes-primary-dns from QubesDB

Browse Source
This commit is contained in:
Hannes Mehnert 2021-11-10 15:26:17 +01:00
parent 6835072104
commit c4f9142376
4 changed files with 16 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
dao.ml
View File

@ -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 "@[<v2>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 =

2
dao.mli
View File

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

17
my_dns.ml
View File

@ -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;

2
unikernel.ml
View File

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