resolver, stub: add require_domain argument

mirage/stub/dns_stub_mirage.ml

@@ -89,6 +89,7 @@ module Make (S : Tcpip.Stack.V4V6) = struct
     mutable update_tls : Tls.Config.server -> unit ;
     mutable clients : Ipaddr.Set.t ;
     record_clients : bool ;
+    require_domain : bool ;
   }
 
   let primary_data { server ; _ } =
@@ -265,7 +266,14 @@ module Make (S : Tcpip.Stack.V4V6) = struct
       (* check header flags: recursion desired (and send recursion available) *)
       (server t proto ip packet header question data buf >>= function
         | Some data -> Lwt.return (Some data)
-        | None -> resolve t question data header proto) >|= fun reply ->
+        | None ->
+          let dn, qtyp = question in
+          if Domain_name.count_labels dn = 1 && (qtyp = `K (Rr_map.K A) || qtyp = `K (Rr_map.K Aaaa)) then
+            let data = `Rcode_error (Rcode.NXDomain, Opcode.Query, None) in
+            let reply = build_reply header question proto data in
+            Lwt.return (Some reply)
+          else
+            resolve t question data header proto) >|= fun reply ->
       let stop = Mirage_mtime.elapsed_ns () in
       Dns_resolver_metrics.response_metric (Int64.sub stop start);
       reply
@@ -302,7 +310,7 @@ module Make (S : Tcpip.Stack.V4V6) = struct
       let len = Cstruct.BE.get_uint16 k 0 in
       read_tls f len
 
-  let create ?(add_reserved = true) ?(record_clients = true) ?(cache_size = 10000) ?(udp = true) ?(tcp = true) ?(port = 53) ?tls ?(tls_port = 853) ?edns ?nameservers ?timeout ?(on_update = fun ~old:_ ?authenticated_key:_ ~update_source:_ _trie -> Lwt.return_unit) primary ~happy_eyeballs stack : t Lwt.t =
+  let create ?(require_domain = false) ?(add_reserved = true) ?(record_clients = true) ?(cache_size = 10000) ?(udp = true) ?(tcp = true) ?(port = 53) ?tls ?(tls_port = 853) ?edns ?nameservers ?timeout ?(on_update = fun ~old:_ ?authenticated_key:_ ~update_source:_ _trie -> Lwt.return_unit) primary ~happy_eyeballs stack : t Lwt.t =
     Client.connect ~cache_size ?edns ?nameservers ?timeout (stack, happy_eyeballs) >|= fun client ->
     let primary =
       if add_reserved then
@@ -315,7 +323,7 @@ module Make (S : Tcpip.Stack.V4V6) = struct
     let server = Dns_server.Primary.server primary in
     let stream, push = Lwt_stream.create () in
     let update_tls _ = () in
-    let t = { client ; server ; on_update ; push ; update_tls ; record_clients ; clients = Ipaddr.Set.empty } in
+    let t = { client ; server ; on_update ; push ; update_tls ; record_clients ; clients = Ipaddr.Set.empty ; require_domain } in
     let udp_cb ~src ~dst:_ ~src_port buf =
       let buf = Cstruct.to_string buf in
       metrics `Udp_queries;

mirage/stub/dns_stub_mirage.mli

@@ -10,15 +10,15 @@ module Make (S : Tcpip.Stack.V4V6) : sig
       ?timer_interval:int64 -> ?getaddrinfo:getaddrinfo -> stack -> t Lwt.t
   end
 
-  val create : ?add_reserved:bool -> ?record_clients:bool -> ?cache_size:int -> ?udp:bool -> ?tcp:bool -> ?port:int ->
+  val create : ?require_domain:bool -> ?add_reserved:bool -> ?record_clients:bool -> ?cache_size:int -> ?udp:bool -> ?tcp:bool -> ?port:int ->
     ?tls:Tls.Config.server -> ?tls_port:int ->
     ?edns:[ `Auto | `Manual of Dns.Edns.t | `None ] ->
     ?nameservers:string list ->
     ?timeout:int64 ->
     ?on_update:(old:Dns_trie.t -> ?authenticated_key:[ `raw ] Domain_name.t ->
                 update_source:Ipaddr.t -> Dns_trie.t -> unit Lwt.t) ->
     Dns_server.Primary.s -> happy_eyeballs:H.t -> S.t -> t Lwt.t
-  (** [create ~add_reserved ~record_clients ~cache_size ~edns ~nameservers ~timeout ~on_update server ~happy_eyeballs stack]
+  (** [create ~require_domain ~add_reserved ~record_clients ~cache_size ~edns ~nameservers ~timeout ~on_update server ~happy_eyeballs stack]
       registers a stub resolver on the provided protocols [udp], [tcp], [tls]
       using [port] for udp and tcp (defaults to 53), [tls_port] for tls (defaults
       to 853) using the [resolver] configuration. The [timer] is in milliseconds
@@ -30,7 +30,11 @@ module Make (S : Tcpip.Stack.V4V6) : sig
 
       The [add_reserved] is by default [true], and adds reserved zones (from RFC
       6303, 6761, 6762) to the primary server
-      (see {!Dns_resolver_root.reserved_zones}). *)
+      (see {!Dns_resolver_root.reserved_zones}).
+
+      The [require_domain] is by default [false]. If enabled, single-label
+      queries for address records (A or AAAA) are immediately replied to with a
+      no data reply. *)
 
   include Dns_resolver_mirage_shared.S with type t := t
 end

resolver/dns_resolver.ml

@@ -78,9 +78,10 @@ type t = {
   queried : awaiting list QM.t ;
   mutable clients : Ipaddr.Set.t ;
   record_clients : bool ;
+  require_domain : bool ;
 }
 
-let create ?(add_reserved = true) ?(record_clients = true) ?(cache_size = 10000) ?(ip_protocol = `Both) features now ts rng primary =
+let create ?(require_domain = false) ?(add_reserved = true) ?(record_clients = true) ?(cache_size = 10000) ?(ip_protocol = `Both) features now ts rng primary =
   let cache = Dns_cache.empty cache_size in
   let cache =
     List.fold_left (fun cache (name, b) ->
@@ -116,7 +117,7 @@ let create ?(add_reserved = true) ?(record_clients = true) ?(cache_size = 10000)
       primary
   in
   { ip_protocol ; features ; rng ; cache ; primary ; transit = TM.empty ; queried = QM.empty ;
-    clients = Ipaddr.Set.empty ; record_clients }
+    clients = Ipaddr.Set.empty ; record_clients ; require_domain }
 
 let features t = FS.elements t.features
 
@@ -575,9 +576,16 @@ let handle_buf t now ts query_allowed proto sender sport buf =
           Log.debug (fun m -> m "handled delegation %a:%d" Ipaddr.pp sender sport) ;
           handle_delegation t ts proto sender sport res dele
         | `None ->
-          Log.debug (fun m -> m "resolving %a:%d" Ipaddr.pp sender sport) ;
-          (* DNSSEC request DS / DNSKEY / NS from auth *)
-          resolve t ts proto sender sport res
+          let dn, qtyp = res.question in
+          if Domain_name.count_labels dn = 1 && (qtyp = `K (Rr_map.K A) || qtyp = `K (Rr_map.K Aaaa)) then
+            let reply = Packet.create res.header res.question (`Answer (Name_rr_map.empty, Name_rr_map.empty)) in
+            let data, _ = Packet.encode proto reply in
+            t, [ proto, sender, sport, 0l, data ], []
+          else begin
+            Log.debug (fun m -> m "resolving %a:%d" Ipaddr.pp sender sport) ;
+            (* DNSSEC request DS / DNSKEY / NS from auth *)
+            resolve t ts proto sender sport res
+          end
       end
     | _ ->
       Log.err (fun m -> m "ignoring unsolicited packet (query allowed? %b) %a" query_allowed Packet.pp res);

resolver/dns_resolver.mli

@@ -6,11 +6,11 @@ type t
 type feature =
   [ `Dnssec | `Qname_minimisation | `Opportunistic_tls_authoritative ]
 
-val create : ?add_reserved:bool -> ?record_clients:bool -> ?cache_size:int ->
+val create : ?require_domain:bool -> ?add_reserved:bool -> ?record_clients:bool -> ?cache_size:int ->
   ?ip_protocol:[ `Both | `Ipv4_only | `Ipv6_only ] ->
   feature list -> Ptime.t ->
   int64 -> (int -> string) -> Dns_server.Primary.s -> t
-(** [create ~add_reserved ~record_clients ~cache_size ~ip_protocol features now ts rng primary]
+(** [create ~require_domain ~add_reserved ~record_clients ~cache_size ~ip_protocol features now ts rng primary]
     creates the value of a resolver, pre-filled with root NS and their IP
     addresses. If [ip_protocol] is provided, and set to [`V4_only], only IPv4
     packets will be emitted. If [`V6_only] is set, only IPv6 packets will be
@@ -24,6 +24,10 @@ val create : ?add_reserved:bool -> ?record_clients:bool -> ?cache_size:int ->
     6303, 6761, 6762) to the primary server
     (see {!Dns_resolver_root.reserved_zones}).
 
+    The [require_domain] is by default [false]. If enabled, single-label queries
+    for address records (A or AAAA) are immediately replied to with a no data
+    reply.
+
     Some features can be specified, whether DNSSec validation should be done,
     whether query name minimisation should be done, and whether opportunistic
     encryption using TLS to the authoritative should be done.