Dnssec improvements

app/dune

@@ -48,3 +48,10 @@
   (package      dns-cli)
   (libraries    dns dns-client-lwt dns-cli cmdliner mtime.clock.os
                 lwt.unix dnssec))
+
+(executable
+  (name         resolver)
+  (public_name  resolver)
+  (modules      resolver)
+  (package      dns-cli)
+  (libraries    dns-resolver dns-resolver.mirage lwt.unix tcpip.stack-socket mirage-clock-unix mirage-unix logs.fmt mirage-crypto-rng.unix))

app/resolver.ml

@@ -0,0 +1,26 @@
+
+module Rng = Mirage_crypto_rng_mirage.Make(Unix_os.Time)(Mclock)
+module Resolver = Dns_resolver_mirage.Make(Rng)(Pclock)(Mclock)(Unix_os.Time)(Tcpip_stack_socket.V4V6)
+
+open Lwt.Infix
+
+let main () =
+  Mirage_crypto_rng_unix.initialize (module Mirage_crypto_rng.Fortuna);
+  Logs.set_level (Some Debug) ;
+  Logs.set_reporter (Logs_fmt.reporter ());
+  Udpv4v6_socket.connect ~ipv4_only:true ~ipv6_only:false Ipaddr.V4.Prefix.global None >>= fun udp ->
+  Tcpv4v6_socket.connect ~ipv4_only:true ~ipv6_only:false Ipaddr.V4.Prefix.global None >>= fun tcp ->
+  Tcpip_stack_socket.V4V6.connect udp tcp >>= fun stack ->
+  let resolver =
+    let primary_t =
+      (* setup DNS server state: *)
+      Dns_server.Primary.create ~rng:Mirage_crypto_rng.generate Dns_trie.empty
+    in
+    Dns_resolver.create ~dnssec:true ~ip_protocol:`Ipv4_only
+      (Mclock.elapsed_ns ()) Mirage_crypto_rng.generate primary_t
+  in 
+  Resolver.resolver ~port:5353 stack resolver;
+  Tcpip_stack_socket.V4V6.listen stack
+
+let () =
+  Lwt_main.run (main ())

dns-cli.opam

@@ -23,6 +23,9 @@ depends: [
   "mirage-crypto" {>= "1.0.0"}
   "mirage-crypto-pk" {>= "1.0.0"}
   "mirage-crypto-rng" {>= "1.0.0"}
+  "mirage-unix"
+  "mirage-clock-unix"
+  "tcpip" {>= "8.2.0"}
   "ohex" {>= "0.2.0"}
   "ptime" {>= "0.8.5"}
   "mtime" {>= "1.2.0"}

dnssec/dnssec.ml

@@ -188,6 +188,19 @@ let verify : type a . Ptime.t -> pub -> [`raw] Domain_name.t -> Rrsig.t ->
     in
     ok_if_true (Mirage_crypto_pk.Rsa.PKCS1.verify ~hashp ~key ~signature msg)
 
+let filter_ds_if_sha2_present ds_set =
+  (* RFC 4509 - drop SHA1 DS if SHA2 DS are present *)
+  if Rr_map.Ds_set.exists (fun ds ->
+      match ds.Ds.digest_type with
+      | Ds.SHA256 | Ds.SHA384 -> true | _ -> false)
+      ds_set
+  then
+    Rr_map.Ds_set.filter
+      (fun ds -> not (ds.Ds.digest_type = SHA1))
+      ds_set
+  else
+    ds_set
+
 let validate_ds zone dnskeys ds =
   let* used_dnskey =
     let key_signing_keys =
@@ -199,11 +212,12 @@ let validate_ds zone dnskeys ds =
     if Rr_map.Dnskey_set.cardinal key_signing_keys = 1 then
       Ok (Rr_map.Dnskey_set.choose key_signing_keys)
     else
-      Error (`Msg "none or multiple key singing keys")
+      Error (`Msg (string_of_int (Rr_map.Dnskey_set.cardinal key_signing_keys) ^ " key signing keys for " ^ string_of_int ds.key_tag))
   in
   let* dgst = digest ds.Ds.digest_type zone used_dnskey in
   if String.equal ds.Ds.digest dgst then begin
-    Log.info (fun m -> m "DS for %a is good" Domain_name.pp zone);
+    Log.debug (fun m -> m "Found DNSKEY for DS for zone %a (key tag %u)"
+                  Domain_name.pp zone ds.Ds.key_tag);
     Ok used_dnskey
   end else
     Error (`Msg "key signing key couldn't be validated")

mirage/resolver/dns_resolver_mirage.ml

@@ -24,6 +24,7 @@ module Make (R : Mirage_crypto_rng_mirage.S) (P : Mirage_clock.PCLOCK) (M : Mira
     end)
 
   let resolver stack ?(root = false) ?(timer = 500) ?(udp = true) ?(tcp = true) ?tls ?(port = 53) ?(tls_port = 853) t =
+    let server_port = 53 in
     (* according to RFC5452 4.5, we can chose source port between 1024-49152 *)
     let sport () = 1024 + Randomconv.int ~bound:48128 R.generate in
     let state = ref t in
@@ -101,8 +102,8 @@ module Make (R : Mirage_crypto_rng_mirage.S) (P : Mirage_clock.PCLOCK) (M : Mira
         S.UDP.listen (S.udp stack) ~port:sport (udp_cb sport false) ;
         Dns.send_udp stack sport dst port (Cstruct.of_string data)
     and handle_query (proto, dst, data) = match proto with
-      | `Udp -> maybe_tcp dst port data
-      | `Tcp -> client_tcp dst port data
+      | `Udp -> maybe_tcp dst server_port data
+      | `Tcp -> client_tcp dst server_port data
     and handle_answer (proto, dst, dst_port, data) = match proto with
       | `Udp -> Dns.send_udp stack port dst dst_port (Cstruct.of_string data)
       | `Tcp -> match try Some (FM.find (dst, dst_port) !tcp_in) with Not_found -> None with
@@ -127,7 +128,7 @@ module Make (R : Mirage_crypto_rng_mirage.S) (P : Mirage_clock.PCLOCK) (M : Mira
         Dns_resolver.handle_buf !state now ts req `Udp src src_port buf
       in
       if not req then
-        (Log.app (fun m -> m "unlisten on UDP %d" src_port);
+        (Log.app (fun m -> m "unlisten on UDP %d" lport);
          S.UDP.unlisten (S.udp stack) ~port:lport);
       state := new_state ;
       Lwt_list.iter_p handle_answer answers >>= fun () ->

resolver/dns_resolver.ml

@@ -108,7 +108,8 @@ let maybe_query ?recursion_desired t ts await retry ip name typ =
     None, t
   else
     (* TODO here we may want to use the _default protocol_ (and edns settings) instead of `Udp *)
-    let edns = Some (Edns.create ~dnssec_ok:t.dnssec ()) in
+    let payload_size = if t.dnssec then Some 1220 (* from RFC 4035 4.1 *) else None in
+    let edns = Some (Edns.create ~dnssec_ok:t.dnssec ?payload_size ()) in
     let t, packet = build_query ?recursion_desired t ts `Udp k retry await.zone edns ip in
     let t = { t with queried = QM.add k [await] t.queried } in
     Log.debug (fun m -> m "maybe_query: query %a %a" Ipaddr.pp ip pp_key k) ;
@@ -301,29 +302,17 @@ let handle_reply t now ts proto sender packet reply =
                 { t with cache },
                 begin match ds with
                   | Ok (`Entry (_, ds_set), _) ->
-                    let keys = match packet.data with
+                    let keys = match reply with
                       | `Answer (a, _) -> Name_rr_map.find zone Rr_map.Dnskey a
                       | _ -> None
                     in
-                    let ds_set =
-                      (* RFC 4509 - drop SHA1 DS if SHA2 DS are present *)
-                      if Rr_map.Ds_set.exists (fun ds ->
-                          match ds.Ds.digest_type with
-                          | Ds.SHA256 | Ds.SHA384 -> true | _ -> false)
-                          ds_set
-                      then
-                        Rr_map.Ds_set.filter
-                          (fun ds -> not (ds.Ds.digest_type = SHA1))
-                          ds_set
-                      else
-                        ds_set
-                    in
+                    let ds_set = Dnssec.filter_ds_if_sha2_present ds_set in
                     Option.map (fun (_, dnskeys) ->
                         Rr_map.Ds_set.fold (fun ds acc ->
                             match Dnssec.validate_ds zone dnskeys ds with
                             | Ok key -> Rr_map.Dnskey_set.add key acc
                             | Error `Msg msg ->
-                              Log.warn (fun m -> m "couldn't validate DS (for %a): %s"
+                              Log.debug (fun m -> m "couldn't validate DS (for %a): %s"
                                             Domain_name.pp zone msg);
                               acc)
                           ds_set Rr_map.Dnskey_set.empty)
@@ -342,17 +331,18 @@ let handle_reply t now ts proto sender packet reply =
                   None
             in
             let* packet, signed =
-              Option.fold
-                ~none:(Ok (packet, false))
-                ~some:(fun dnskeys ->
-                    let* packet =
-                      Result.map_error (fun (`Msg msg) ->
-                          Log.err (fun m -> m "error %s verifying reply %a"
-                                       msg Packet.pp_reply reply))
-                        (Dnssec.verify_packet now dnskeys packet)
-                    in
-                    Ok (packet, true))
-                dnskeys
+              match dnskeys with
+              | None ->
+                Log.warn (fun m -> m "no DNSKEY present, couldn't validate packet");
+                Ok (packet, false)
+              | Some dnskeys ->
+                let* packet =
+                  Result.map_error (fun (`Msg msg) ->
+                      Log.err (fun m -> m "error %s verifying reply %a"
+                                   msg Packet.pp_reply reply))
+                    (Dnssec.verify_packet now dnskeys packet)
+                in
+                Ok (packet, true)
             in
             Ok (t, packet, signed)
           else
@@ -382,7 +372,7 @@ let handle_reply t now ts proto sender packet reply =
           let t, cs = build_query ~recursion_desired t ts `Tcp key 1 zone None sender in
           Log.debug (fun m -> m "resolve: upgrade to tcp %a %a"
                          Ipaddr.pp sender pp_key key) ;
-        Ok (t, out_a, (`Tcp, sender, cs) :: out_q)
+          Ok (t, out_a, (`Tcp, sender, cs) :: out_q)
         | `Try_another_ns ->
           (* is this the right behaviour? by luck we'll use another path *)
           Ok (handle_awaiting_queries t ts key)