Merge pull request #135 from palainp/ocaml-dns-update

update to ocaml-dns latest release

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

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)"

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

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

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)

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

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

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

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. *)

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)

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;

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

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