From 4cb5cfa036def6b54bad939bcea6aaab27a6ff58 Mon Sep 17 00:00:00 2001 From: palainp Date: Thu, 28 Oct 2021 13:39:32 +0200 Subject: [PATCH 1/8] update to ocaml-dns 6.0.0 interface --- client_net.mli | 2 +- firewall.mli | 2 +- my_dns.ml | 15 ++++++++------- rules.ml | 2 +- 4 files changed, 11 insertions(+), 10 deletions(-) diff --git a/client_net.mli b/client_net.mli index fc1953a..192fc29 100644 --- a/client_net.mli +++ b/client_net.mli @@ -4,7 +4,7 @@ (** Handling client VMs. *) val listen : (unit -> int64) -> - ([ `host ] Domain_name.t -> (int32 * Dns.Rr_map.Ipv4_set.t, [> `Msg of string ]) result Lwt.t) -> + ([ `host ] Domain_name.t -> (int32 * Ipaddr.V4.Set.t, [> `Msg of string ]) result Lwt.t) -> Qubes.DB.t -> Router.t -> 'a Lwt.t (** [listen get_timestamp resolver db router] is a thread that watches for clients being added to and removed from XenStore. Clients are connected to the client network and diff --git a/firewall.mli b/firewall.mli index 88f02ba..0141d94 100644 --- a/firewall.mli +++ b/firewall.mli @@ -7,7 +7,7 @@ val ipv4_from_netvm : Router.t -> Nat_packet.t -> unit Lwt.t (** Handle a packet from the outside world (this module will validate the source IP). *) (* TODO the function type is a workaround, rework the module dependencies / functors to get rid of it *) -val ipv4_from_client : ([ `host ] Domain_name.t -> (int32 * Dns.Rr_map.Ipv4_set.t, [> `Msg of string ]) result Lwt.t) -> +val ipv4_from_client : ([ `host ] Domain_name.t -> (int32 * Ipaddr.V4.Set.t, [> `Msg of string ]) result Lwt.t) -> Router.t -> src:Fw_utils.client_link -> Nat_packet.t -> unit Lwt.t (** Handle a packet from a client. Caller must check the source IP matches the client's before calling this. *) diff --git a/my_dns.ml b/my_dns.ml index c94cbb1..bcdfa47 100644 --- a/my_dns.ml +++ b/my_dns.ml @@ -3,22 +3,22 @@ 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 = [ `TCP | `UDP ] * io_addr + 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 = { - nameserver : ns_addr ; + nameservers : ns_addr ; stack : stack ; timeout_ns : int64 ; } type context = { t : t ; timeout_ns : int64 ref; mutable src_port : int } - let nameserver t = t.nameserver + let nameservers t = t.nameservers let rng = R.generate ?g:None let clock = C.elapsed_ns - let create ?(nameserver = `UDP, (Ipaddr.V4.of_string_exn "91.239.100.100", 53)) ~timeout stack = - { nameserver ; stack ; timeout_ns = timeout } + let create ?(nameservers = `Udp, [(Ipaddr.V4.of_string_exn "91.239.100.100", 53)]) ~timeout stack = + { nameservers ; 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 @@ -28,12 +28,13 @@ module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) = struct ctx.timeout_ns := Int64.sub !(ctx.timeout_ns) (Int64.sub stop start); result - let connect ?nameserver:_ (t : t) = Lwt.return (Ok { t ; timeout_ns = ref t.timeout_ns ; src_port = 0 }) + let connect (t : t) = Lwt.return (Ok { t ; timeout_ns = ref t.timeout_ns ; src_port = 0 }) let send (ctx : context) buf : (unit, [> `Msg of string ]) result Lwt.t = let open Router in let open My_nat in - let dst, dst_port = snd ctx.t.nameserver in + let nslist = snd ctx.t.nameservers in + let dst, dst_port = List.hd(nslist) 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/rules.ml b/rules.ml index da4706c..a70127c 100644 --- a/rules.ml +++ b/rules.ml @@ -59,7 +59,7 @@ module Classifier = struct Log.debug (fun f -> f "Resolving %a" Domain_name.pp name); dns_client name >|= function | Ok (_ttl, found_ips) -> - if Dns.Rr_map.Ipv4_set.mem ip found_ips + if Ipaddr.V4.Set.mem ip found_ips then `Match rule else `No_match | Error (`Msg m) -> From ba8dbc3f579460baacec88b535043b143a0a6c58 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Fri, 5 Nov 2021 18:55:30 +0100 Subject: [PATCH 2/8] Dockerfile: update opam-repository to current master config.ml: require more recent dns and ipaddr packages --- Dockerfile | 2 +- config.ml | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/Dockerfile b/Dockerfile index a6d0773..cafdeb1 100644 --- a/Dockerfile +++ b/Dockerfile @@ -7,7 +7,7 @@ FROM ocurrent/opam@sha256:fce44a073ff874166b51c33a4e37782286d48dbba1b5aa43563a0d # Pin last known-good version for reproducible builds. # Remove this line (and the base image pin above) if you want to test with the # latest versions. -RUN cd ~/opam-repository && git fetch origin master && git reset --hard 0531bd9f8068f9cbd0815cfc5fcbd6b6568e9620 && opam update +RUN cd ~/opam-repository && git fetch origin master && git reset --hard 87ef72b5cd492573258eb1b6f3b30c88af31ae3f && opam update RUN opam depext -i -y mirage RUN mkdir /home/opam/qubes-mirage-firewall diff --git a/config.ml b/config.ml index 87f9f23..a2173e4 100644 --- a/config.ml +++ b/config.ml @@ -29,12 +29,12 @@ let main = package "shared-memory-ring" ~min:"3.0.0"; package "netchannel" ~min:"1.11.0"; package "mirage-net-xen"; - package "ipaddr" ~min:"4.0.0"; + package "ipaddr" ~min:"5.2.0"; package "mirage-qubes" ~min:"0.9.1"; package "mirage-nat" ~min:"2.2.1"; package "mirage-logs"; package "mirage-xen" ~min:"6.0.0"; - package ~min:"4.5.0" "dns-client"; + package ~min:"6.0.0" "dns-client"; package "pf-qubes"; ] "Unikernel.Main" (random @-> mclock @-> job) From 65ff2a920378430cc665d85c7dcf337fbeb76add Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Thu, 3 Dec 2020 21:19:46 +0100 Subject: [PATCH 3/8] update arp to >= 2.3.0, where arp.mirage is a sublibrary --- config.ml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/config.ml b/config.ml index a2173e4..8e2a763 100644 --- a/config.ml +++ b/config.ml @@ -22,8 +22,7 @@ let main = package "cstruct"; package "astring"; package "tcpip" ~min:"3.7.0"; - package "arp"; - package "arp-mirage"; + package ~min:"2.3.0" ~sublibs:["mirage"] "arp"; package "ethernet"; package "mirage-protocols"; package "shared-memory-ring" ~min:"3.0.0"; From 7e3303a8d61b23696b2601c81238a45478f0357b Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Fri, 5 Nov 2021 19:53:39 +0100 Subject: [PATCH 4/8] read DNS resolver IP addresses from QubesDB as specified in https://www.qubes-os.org/doc/vm-interface/ --- dao.ml | 14 ++++++++++---- dao.mli | 1 + my_dns.ml | 2 +- unikernel.ml | 3 ++- 4 files changed, 14 insertions(+), 6 deletions(-) diff --git a/dao.ml b/dao.ml index d1580e1..383b1b6 100644 --- a/dao.ml +++ b/dao.ml @@ -125,11 +125,11 @@ 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; } exception Missing_key of string -(* TODO: /qubes-secondary-dns *) let try_read_network_config db = let get name = match DB.KeyMap.find_opt name db with @@ -138,14 +138,20 @@ 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 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@]" + Our IP on client networks: %a@,\ + DNS resolvers: %a@]" Ipaddr.V4.pp uplink_netvm_ip Ipaddr.V4.pp uplink_our_ip - Ipaddr.V4.pp clients_our_ip); - { uplink_netvm_ip; uplink_our_ip; clients_our_ip } + Ipaddr.V4.pp clients_our_ip + Fmt.(list ~sep:(any ", ") Ipaddr.V4.pp) dns); + { uplink_netvm_ip; uplink_our_ip; clients_our_ip ; dns } let read_network_config qubesDB = let rec aux bindings = diff --git a/dao.mli b/dao.mli index 811c2e7..94d418e 100644 --- a/dao.mli +++ b/dao.mli @@ -24,6 +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; } val read_network_config : Qubes.DB.t -> network_config Lwt.t diff --git a/my_dns.ml b/my_dns.ml index bcdfa47..ca2c0f8 100644 --- a/my_dns.ml +++ b/my_dns.ml @@ -34,7 +34,7 @@ module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) = struct 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 = List.hd nslist 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 72f2c83..0621e42 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -81,7 +81,8 @@ 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 dns_client = Dns_client.create (router, send_dns_query, dns_mvar) in + let nameservers = `Udp, List.map (fun ip -> ip, 53) config.Dao.dns 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 From d4e365a49918311106a0ffb1c373788e2b0cd94f Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Fri, 5 Nov 2021 19:59:00 +0100 Subject: [PATCH 5/8] avoid fmt and cstruct deprecation warnings --- client_net.ml | 4 ++-- firewall.ml | 2 +- fw_utils.ml | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/client_net.ml b/client_net.ml index 10d4412..8f0f975 100644 --- a/client_net.ml +++ b/client_net.ml @@ -27,7 +27,7 @@ let writev eth dst proto fillfn = ) class client_iface eth ~domid ~gateway_ip ~client_ip client_mac : client_link = - let log_header = Fmt.strf "dom%d:%a" domid Ipaddr.V4.pp client_ip in + let log_header = Fmt.str "dom%d:%a" domid Ipaddr.V4.pp client_ip in object val queue = FrameQ.create (Ipaddr.V4.to_string client_ip) val mutable rules = [] @@ -99,7 +99,7 @@ let add_vif get_ts { Dao.ClientVif.domid; device_id } dns_client ~client_ip ~rou else begin Log.debug (fun m -> m "New firewall rules for %s@.%a" (Ipaddr.V4.to_string client_ip) - Fmt.(list ~sep:(unit "@.") Pf_qubes.Parse_qubes.pp_rule) new_rules); + Fmt.(list ~sep:(any "@.") Pf_qubes.Parse_qubes.pp_rule) new_rules); (* empty NAT table if rules are updated: they might deny old connections *) My_nat.remove_connections router.Router.nat router.Router.ports client_ip; end); diff --git a/firewall.ml b/firewall.ml index 9b1587c..aecc383 100644 --- a/firewall.ml +++ b/firewall.ml @@ -22,7 +22,7 @@ let transmit_ipv4 packet iface = 0 | Ok (n, frags) -> fragments := frags ; n) >>= fun () -> Lwt_list.iter_s (fun f -> - let size = Cstruct.len f in + let size = Cstruct.length f in iface#writev `IPv4 (fun b -> Cstruct.blit f 0 b 0 size ; size)) !fragments) (fun ex -> diff --git a/fw_utils.ml b/fw_utils.ml index f6d5c7b..e4a1789 100644 --- a/fw_utils.ml +++ b/fw_utils.ml @@ -45,4 +45,4 @@ let error fmt = let or_raise msg pp = function | Ok x -> x - | Error e -> failwith (Fmt.strf "%s: %a" msg pp e) + | Error e -> failwith (Fmt.str "%s: %a" msg pp e) From 6835072104f2705ce56e0615255486c20c9ef13c Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Fri, 5 Nov 2021 19:39:10 +0100 Subject: [PATCH 6/8] build-with-docker: update hash --- build-with-docker.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/build-with-docker.sh b/build-with-docker.sh index 65bbb0e..4f34782 100755 --- a/build-with-docker.sh +++ b/build-with-docker.sh @@ -5,5 +5,5 @@ docker build -t qubes-mirage-firewall . echo Building Firewall... docker run --rm -i -v `pwd`:/home/opam/qubes-mirage-firewall qubes-mirage-firewall echo "SHA2 of build: $(sha256sum qubes_firewall.xen)" -echo "SHA2 last known: d68d2a8d2337b8c1a78995e1acbb4f72082076c73be45bf40dd6268c87b2353e" +echo "SHA2 last known: 2615ab9a9cbe5b29cf0d2a82aff7e281d06666da9cad5e767dbbc08acb77e295" echo "(hashes should match for released versions)" From c4f91423768985b50753338bf4bb1a59a2c054b9 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 10 Nov 2021 15:26:17 +0100 Subject: [PATCH 7/8] 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 From 6e76ab299b005ec88fdd4f46eef28b8ac1ee6d12 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 10 Nov 2021 15:31:36 +0100 Subject: [PATCH 8/8] update sha256 of build --- build-with-docker.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/build-with-docker.sh b/build-with-docker.sh index 4f34782..e2bb56f 100755 --- a/build-with-docker.sh +++ b/build-with-docker.sh @@ -5,5 +5,5 @@ docker build -t qubes-mirage-firewall . echo Building Firewall... docker run --rm -i -v `pwd`:/home/opam/qubes-mirage-firewall qubes-mirage-firewall echo "SHA2 of build: $(sha256sum qubes_firewall.xen)" -echo "SHA2 last known: 2615ab9a9cbe5b29cf0d2a82aff7e281d06666da9cad5e767dbbc08acb77e295" +echo "SHA2 last known: 14cc59ec7c3754f83f7422d48176bc0eb8e47d3c3ef116ae09619409b590d3cb" echo "(hashes should match for released versions)"