Dns_resolver_cache.answer: revive the cname and any code

Dns_cache: provide a get_any function
mirage · Jul 13, 2021 · b3d5bba · b3d5bba
1 parent 1f68d03
commit b3d5bba
Show file tree

Hide file tree

Showing 3 changed files with 101 additions and 39 deletions.
diff --git a/cache/dns_cache.ml b/cache/dns_cache.ml
@@ -185,6 +185,49 @@ let get cache ts name query_type =
     | Ok entry' -> metrics `Hit; LRU.promote name cache, Ok entry'
     | Error e -> metrics `Drop; cache, Error e
 
+let find_any cache name =
+  match LRU.find name cache with
+  | None -> Error `Cache_miss
+  | Some No_domain (meta, name, soa) -> Ok (`No_domain (meta, name, soa))
+  | Some Rr_map rrs -> Ok (`Entries rrs)
+
+let get_any cache ts name =
+  metrics `Lookup;
+  match find_any cache name with
+  | Error e -> metrics `Miss; cache, Error e
+  | Ok r ->
+    let ttl created curr =
+      let ttl = compute_updated_ttl ~created ~now:ts curr in
+      if ttl < 0l then Error `Cache_drop else Ok ttl
+    in
+    LRU.promote name cache,
+    match r with
+    | `No_domain ((created, _), name, soa) ->
+      begin match ttl created soa.Soa.minimum with
+        | Error _ as e -> metrics `Drop ; e
+        | Ok ttl ->
+          metrics `Hit ;
+          Ok (`No_domain (name, { soa with Soa.minimum = ttl }))
+      end
+    | `Entries rrs ->
+      let r =
+        RRMap.fold (fun _k ((created, _), v) acc ->
+            match v with
+            | Entry.Entry b ->
+              begin match ttl created (Rr_map.get_ttl b) with
+                | Ok ttl ->
+                  let B (k, v) = Rr_map.with_ttl b ttl in
+                  Rr_map.add k v acc
+                | Error _ -> acc
+              end
+            | _ -> acc) rrs Rr_map.empty
+      in
+      if Rr_map.is_empty r then begin
+        metrics `Drop ; Error `Cache_drop
+      end else begin
+        metrics `Hit ; Ok (`Entries r)
+      end
+
 let get_or_cname cache ts name query_type =
   metrics `Lookup;
   match

diff --git a/cache/dns_cache.mli b/cache/dns_cache.mli
@@ -67,6 +67,13 @@ val get_or_cname : t -> int64 -> [ `raw ] Domain_name.t -> 'a Rr_map.key ->
 (** [get_or_cname cache timestamp type name] is the same as [get], but if a
     [`Cache_miss] is encountered, a lookup for an alias (CNAME) is done. *)
 
+val get_any : t -> int64 -> [ `raw ] Domain_name.t ->
+  t * ([ `Entries of Rr_map.t
+       | `No_domain of [ `raw ] Domain_name.t * Soa.t ],
+       [ `Cache_miss | `Cache_drop ]) result
+(** [get_any cache timestamp name] retrieves all resource records for [name]
+    in [cache]. *)
+
 val set : t -> int64 -> [ `raw ] Domain_name.t -> 'a Rr_map.key -> rank ->
   entry -> t
 (** [set cache timestamp type name rank value] attempts to insert

diff --git a/resolver/dns_resolver_cache.ml b/resolver/dns_resolver_cache.ml
@@ -337,45 +337,57 @@ let answer t ts name typ =
     in
     flags, data
   in
-  let t, r = match typ with
-    | `Any -> Dns_cache.get_or_cname t ts name A (* TODO *)
-    | `K (Rr_map.K ty) -> Dns_cache.get_or_cname t ts name ty
-  in
-  match r with
-  | Error e ->
-    Logs.warn (fun m -> m "error %a while looking up %a, query"
-                  pp_err e pp_question (name, typ));
-    `Query name, t
-  | Ok `No_domain res ->
-    Logs.debug (fun m -> m "no domain while looking up %a, query" pp_question (name, typ));
-    `Packet (packet t false Rcode.NXDomain Domain_name.Map.empty (to_map res)), t
-  | Ok `No_data res ->
-    Logs.debug (fun m -> m "no data while looking up %a" pp_question (name, typ));
-    `Packet (packet t false Rcode.NoError Domain_name.Map.empty (to_map res)), t
-  | Ok `Serv_fail res ->
-    Logs.debug (fun m -> m "serv fail while looking up %a" pp_question (name, typ));
-    `Packet (packet t false Rcode.ServFail Domain_name.Map.empty (to_map res)), t
-  | Ok `Entry (Rr_map.B (k, v)) ->
-    Logs.debug (fun m -> m "entry while looking up %a" pp_question (name, typ));
-    let data = Name_rr_map.singleton name k v in
-    `Packet (packet t true Rcode.NoError data Domain_name.Map.empty), t
-(*  | Ok `Entries rr_map ->
-    Logs.debug (fun m -> m "entries while looking up %a" pp_question (name, typ));
-    let data = Domain_name.Map.singleton name rr_map in
-    `Packet (packet t true Rcode.NoError data Domain_name.Map.empty), t *)
-(*  | Ok (`Alias (ttl, alias), t) ->
-    Logs.debug (fun m -> m "alias while looking up %a" pp_question (name, typ));
-    match typ with
-    | `Any ->
-      let data = Name_rr_map.singleton name Cname (ttl, alias) in
-      `Packet (packet t false Rcode.NoError data Domain_name.Map.empty), t
-    | `K (K Cname) ->
-      let data = Name_rr_map.singleton name Cname (ttl, alias) in
-      `Packet (packet t false Rcode.NoError data Domain_name.Map.empty), t
-    | `K (K ty) ->
-      match follow_cname t ts ty ~name ttl ~alias with
-      | `Out (rcode, an, au, t) -> `Packet (packet t true rcode an au), t
-      | `Query (n, t) -> `Query n, t *)
+  match typ with
+  | `Any ->
+    let t, r = Dns_cache.get_any t ts name in
+    begin match r with
+      | Error e ->
+        Logs.warn (fun m -> m "error %a while looking up %a, query"
+                      pp_err e pp_question (name, typ));
+        `Query name, t
+      | Ok `No_domain res ->
+        Logs.debug (fun m -> m "no domain while looking up %a, query" pp_question (name, typ));
+        `Packet (packet t false Rcode.NXDomain Domain_name.Map.empty (to_map res)), t
+      | Ok `Entries rr_map ->
+        Logs.debug (fun m -> m "entries while looking up %a" pp_question (name, typ));
+        let data = Domain_name.Map.singleton name rr_map in
+        `Packet (packet t true Rcode.NoError data Domain_name.Map.empty), t
+    end
+  | `K (Rr_map.K ty) ->
+    let t, r = Dns_cache.get_or_cname t ts name ty in
+    match r with
+    | Error e ->
+      Logs.warn (fun m -> m "error %a while looking up %a, query"
+                    pp_err e pp_question (name, typ));
+      `Query name, t
+    | Ok `No_domain res ->
+      Logs.debug (fun m -> m "no domain while looking up %a, query" pp_question (name, typ));
+      `Packet (packet t false Rcode.NXDomain Domain_name.Map.empty (to_map res)), t
+    | Ok `No_data res ->
+      Logs.debug (fun m -> m "no data while looking up %a" pp_question (name, typ));
+      `Packet (packet t false Rcode.NoError Domain_name.Map.empty (to_map res)), t
+    | Ok `Serv_fail res ->
+      Logs.debug (fun m -> m "serv fail while looking up %a" pp_question (name, typ));
+      `Packet (packet t false Rcode.ServFail Domain_name.Map.empty (to_map res)), t
+    | Ok `Entry (Rr_map.B (Cname, (ttl, alias))) ->
+      begin
+        Logs.debug (fun m -> m "alias while looking up %a" pp_question (name, typ));
+        match typ with
+        | `Any ->
+          let data = Name_rr_map.singleton name Cname (ttl, alias) in
+          `Packet (packet t false Rcode.NoError data Domain_name.Map.empty), t
+        | `K (K Cname) ->
+          let data = Name_rr_map.singleton name Cname (ttl, alias) in
+          `Packet (packet t false Rcode.NoError data Domain_name.Map.empty), t
+        | `K (K ty) ->
+          match follow_cname t ts ty ~name ttl ~alias with
+          | `Out (rcode, an, au), t -> `Packet (packet t true rcode an au), t
+          | `Query n, t -> `Query n, t
+      end
+    | Ok `Entry (Rr_map.B (k, v)) ->
+      Logs.debug (fun m -> m "entry while looking up %a" pp_question (name, typ));
+      let data = Name_rr_map.singleton name k v in
+      `Packet (packet t true Rcode.NoError data Domain_name.Map.empty), t
 
 let handle_query t ~rng ts qname qtype =
   match answer t ts qname qtype with