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/build-with-docker.sh b/build-with-docker.sh index 65bbb0e..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: d68d2a8d2337b8c1a78995e1acbb4f72082076c73be45bf40dd6268c87b2353e" +echo "SHA2 last known: 14cc59ec7c3754f83f7422d48176bc0eb8e47d3c3ef116ae09619409b590d3cb" echo "(hashes should match for released versions)" 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/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/config.ml b/config.ml index 87f9f23..8e2a763 100644 --- a/config.ml +++ b/config.ml @@ -22,19 +22,18 @@ 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"; 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) diff --git a/dao.ml b/dao.ml index d1580e1..30b4c2d 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; } 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,17 @@ 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 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 resolver: %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 + 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..be6ebb9 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; } val read_network_config : Qubes.DB.t -> network_config Lwt.t 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/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/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) diff --git a/my_dns.ml b/my_dns.ml index c94cbb1..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 = [ `TCP | `UDP ] * io_addr 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 ; + protocol : Dns.proto ; + nameserver : io_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 { protocol ; nameserver ; _ } = protocol, [ nameserver ] 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 ~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 @@ -28,12 +32,12 @@ 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 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/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) -> diff --git a/unikernel.ml b/unikernel.ml index 72f2c83..cccb710 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, [ 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