From 1f68d03a6b4467bc4d89cf825597113aefb87d73 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Tue, 13 Jul 2021 16:40:13 +0200 Subject: [PATCH 1/2] Dns_resolver: remove type alias, use Dns_cache.get_or_cname improve follow_cname tests --- resolver/dns_resolver.ml | 15 +++++---- resolver/dns_resolver_cache.ml | 50 +++++++++++++---------------- resolver/dns_resolver_cache.mli | 32 ++++++++---------- test/resolver.ml | 57 ++++++++++++++++++++++++--------- 4 files changed, 87 insertions(+), 67 deletions(-) diff --git a/resolver/dns_resolver.ml b/resolver/dns_resolver.ml index bdf1b24f8..b3abedf06 100644 --- a/resolver/dns_resolver.ml +++ b/resolver/dns_resolver.ml @@ -59,14 +59,14 @@ let pp_stats pf s = type t = { rng : int -> Cstruct.t ; primary : Dns_server.Primary.s ; - cache : Dns_resolver_cache.t ; + cache : Dns_cache.t ; transit : awaiting QM.t ; queried : awaiting list QM.t ; mode : [ `Stub | `Recursive ] ; } let create ?(size = 10000) ?(mode = `Recursive) now rng primary = - let cache = Dns_resolver_cache.empty size in + let cache = Dns_cache.empty size in let cache = List.fold_left (fun cache (name, b) -> Dns_cache.set cache now @@ -360,9 +360,10 @@ let handle_delegation t ts proto sender sport req (delegation, add_data) = Logs.debug (fun m -> m "handling delegation %a (for %a)" Packet.Answer.pp delegation Packet.pp req) ; match req.Packet.data, Packet.Question.qtype req.question with | `Query, Some qtype -> - begin match Dns_resolver_cache.answer t.cache ts (fst req.question) qtype with - | `Query (name, cache) -> - let t = { t with cache } in + let r, cache = Dns_resolver_cache.answer t.cache ts (fst req.question) qtype in + let t = { t with cache } in + begin match r with + | `Query name -> (* we should look into delegation for the actual delegation name, but instead we're looking for any glue (A) in additional *) let ips = Domain_name.Map.fold (fun _ rrmap ips -> @@ -388,13 +389,13 @@ let handle_delegation t ts proto sender sport req (delegation, add_data) = | `Query (cs, ip), t -> t, [], [ `Udp, ip, cs ] end end - | `Packet (flags, reply, cache) -> + | `Packet (flags, reply) -> let max_size, edns = Edns.reply req.edns in Logs.debug (fun m -> m "delegation reply for %a from cache: %a" Packet.pp req Packet.pp_reply reply) ; let packet = Packet.create ?edns (fst req.header, flags) req.question (reply :> Packet.data) in let pkt, _ = Packet.encode ?max_size proto packet in - { t with cache }, [ proto, sender, sport, pkt ], [] + t, [ proto, sender, sport, pkt ], [] (* send it out! we've a cache hit here! *) end | _ -> diff --git a/resolver/dns_resolver_cache.ml b/resolver/dns_resolver_cache.ml index 2a28434c6..4a52ecfcc 100644 --- a/resolver/dns_resolver_cache.ml +++ b/resolver/dns_resolver_cache.ml @@ -2,10 +2,6 @@ open Dns -type t = Dns_cache.t - -let empty = Dns_cache.empty - module N = Domain_name.Set let pp_err ppf = function @@ -281,17 +277,17 @@ let to_map (name, soa) = Name_rr_map.singleton name Soa soa let follow_cname t ts typ ~name ttl ~alias = let rec follow t acc name = - let t, r = Dns_cache.get t ts name typ in + let t, r = Dns_cache.get_or_cname t ts name typ in match r with | Error _ -> Logs.debug (fun m -> m "follow_cname: cache miss, need to query %a" Domain_name.pp name); - `Query (name, t) + `Query name, t | Ok `Entry (Rr_map.B (Cname, (_, alias))) -> let acc' = Domain_name.Map.add name Rr_map.(singleton Cname (ttl, alias)) acc in if Domain_name.Map.mem alias acc then begin Logs.warn (fun m -> m "follow_cname: cycle detected") ; - `Out (Rcode.NoError, acc', Name_rr_map.empty, t) + `Out (Rcode.NoError, acc', Name_rr_map.empty), t end else begin Logs.debug (fun m -> m "follow_cname: alias to %a, follow again" Domain_name.pp alias); @@ -300,16 +296,16 @@ let follow_cname t ts typ ~name ttl ~alias = | Ok `Entry (Rr_map.B (k, v)) -> let acc' = Domain_name.Map.add name Rr_map.(singleton k v) acc in Logs.debug (fun m -> m "follow_cname: entry found, returning"); - `Out (Rcode.NoError, acc', Name_rr_map.empty, t) + `Out (Rcode.NoError, acc', Name_rr_map.empty), t | Ok `No_domain res -> Logs.debug (fun m -> m "follow_cname: nodom"); - `Out (Rcode.NXDomain, acc, to_map res, t) + `Out (Rcode.NXDomain, acc, to_map res), t | Ok `No_data res -> Logs.debug (fun m -> m "follow_cname: nodata"); - `Out (Rcode.NoError, acc, to_map res, t) + `Out (Rcode.NoError, acc, to_map res), t | Ok `Serv_fail res -> Logs.debug (fun m -> m "follow_cname: servfail") ; - `Out (Rcode.ServFail, acc, to_map res, t) + `Out (Rcode.ServFail, acc, to_map res), t in let initial = Name_rr_map.singleton name Cname (ttl, alias) in follow t initial alias @@ -326,7 +322,7 @@ let additionals t ts rrs = *) let answer t ts name typ = - let packet t _add rcode answer authority = + let packet _t _add rcode answer authority = (* TODO why was this RA + RD in here? should not be RD for recursive algorithm TODO should it be authoritative for recursive algorithm? *) let data = (answer, authority) in @@ -339,52 +335,52 @@ let answer t ts name typ = let data = if Packet.Answer.is_empty data then None else Some data in `Rcode_error (x, Opcode.Query, data) in - (flags, data, t) + flags, data in let t, r = match typ with - | `Any -> Dns_cache.get t ts name A (* TODO *) - | `K (Rr_map.K ty) -> Dns_cache.get t ts name ty + | `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) + `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)) + `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)) + `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)) + `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) + `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) *) + `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) + `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) + `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) - | `Query (n, t) -> `Query (n, t) *) + | `Out (rcode, an, au, t) -> `Packet (packet t true rcode an au), t + | `Query (n, t) -> `Query n, t *) let handle_query t ~rng ts qname qtype = match answer t ts qname qtype with - | `Packet (flags, data, t) -> `Reply (flags, data), t - | `Query (name, t) -> + | `Packet (flags, data), t -> `Reply (flags, data), t + | `Query name, t -> (* similar for TLSA, which uses _443._tcp. (a service name!) *) (* TODO unclear why it's here... *) let qname', qtype' = diff --git a/resolver/dns_resolver_cache.mli b/resolver/dns_resolver_cache.mli index 83d2f337d..e1d74e223 100644 --- a/resolver/dns_resolver_cache.mli +++ b/resolver/dns_resolver_cache.mli @@ -1,35 +1,31 @@ (* (c) 2017, 2018 Hannes Mehnert, all rights reserved *) open Dns -type t = Dns_cache.t - -val empty : int -> t - val pp_question : ([ `raw ] Domain_name.t * Packet.Question.qtype) Fmt.t -val follow_cname : t -> int64 -> 'a Rr_map.key -> name:[ `raw ] Domain_name.t -> int32 -> +val follow_cname : Dns_cache.t -> int64 -> 'a Rr_map.key -> name:[ `raw ] Domain_name.t -> int32 -> alias:[ `raw ] Domain_name.t -> - [ `Out of Rcode.t * Name_rr_map.t * Name_rr_map.t * t - | `Query of [ `raw ] Domain_name.t * t - ] + [ `Out of Rcode.t * Name_rr_map.t * Name_rr_map.t + | `Query of [ `raw ] Domain_name.t ] * Dns_cache.t -val answer : t -> int64 -> [ `raw ] Domain_name.t -> Packet.Question.qtype -> - [ `Query of [ `raw ] Domain_name.t * t | `Packet of Packet.Flags.t * Packet.reply * t ] +val answer : Dns_cache.t -> int64 -> [ `raw ] Domain_name.t -> Packet.Question.qtype -> + [ `Query of [ `raw ] Domain_name.t + | `Packet of Packet.Flags.t * Packet.reply ] * Dns_cache.t (* -val resolve_ns : t -> int64 -> Domain_name.t -> - [ `NeedA of Domain_name.t | `NeedCname of Domain_name.t | `HaveIPS of Rr_map.Ipv4_set.t | `NoDom | `No ] * t +val resolve_ns : Dns_cache.t -> int64 -> Domain_name.t -> + [ `NeedA of Domain_name.t | `NeedCname of Domain_name.t | `HaveIPS of Rr_map.Ipv4_set.t | `NoDom | `No ] * Dns_cache.t *) -(*val find_ns : t -> (int -> Cstruct.t) -> int64 -> Domain_name.Set.t -> Domain_name.t -> - [ `Loop | `NeedNS | `NoDom | `No | `Cname of Domain_name.t | `HaveIP of Ipaddr.t | `NeedA of Domain_name.t | `NeedGlue of Domain_name.t ] * t +(*val find_ns : Dns_cache.t -> (int -> Cstruct.t) -> int64 -> Domain_name.Set.t -> Domain_name.t -> + [ `Loop | `NeedNS | `NoDom | `No | `Cname of Domain_name.t | `HaveIP of Ipaddr.t | `NeedA of Domain_name.t | `NeedGlue of Domain_name.t ] * Dns_cache.t *) -val resolve : t -> rng:(int -> Cstruct.t) -> int64 -> [ `raw ] Domain_name.t -> - Rr_map.k -> [ `raw ] Domain_name.t * [ `raw ] Domain_name.t * Rr_map.k * Ipaddr.t * t +val resolve : Dns_cache.t -> rng:(int -> Cstruct.t) -> int64 -> [ `raw ] Domain_name.t -> + Rr_map.k -> [ `raw ] Domain_name.t * [ `raw ] Domain_name.t * Rr_map.k * Ipaddr.t * Dns_cache.t -val handle_query : t -> rng:(int -> Cstruct.t) -> int64 -> [ `raw ] Domain_name.t -> +val handle_query : Dns_cache.t -> rng:(int -> Cstruct.t) -> int64 -> [ `raw ] Domain_name.t -> Packet.Question.qtype -> [ `Reply of Packet.Flags.t * Packet.reply | `Nothing - | `Query of [ `raw ] Domain_name.t * ([ `raw ] Domain_name.t * Packet.Question.qtype) * Ipaddr.t ] * t + | `Query of [ `raw ] Domain_name.t * ([ `raw ] Domain_name.t * Packet.Question.qtype) * Ipaddr.t ] * Dns_cache.t diff --git a/test/resolver.ml b/test/resolver.ml index d9895934b..80df54dae 100644 --- a/test/resolver.ml +++ b/test/resolver.ml @@ -2,7 +2,7 @@ open Dns -let empty = Dns_resolver_cache.empty 100 +let empty = Dns_cache.empty 100 let ip = Ipaddr.V4.of_string_exn let ip6 = Ipaddr.V6.of_string_exn @@ -19,16 +19,16 @@ let rng i = Cstruct.create i let follow_res = let module M = struct type t = - [ `Out of Rcode.t * Name_rr_map.t * Name_rr_map.t * Dns_resolver_cache.t - | `Query of [ `raw ] Domain_name.t * Dns_resolver_cache.t - ] - let pp ppf = function - | `Out (rcode, answer, authority, _) -> Fmt.pf ppf "out %a answer %a authority %a" Rcode.pp rcode Name_rr_map.pp answer Name_rr_map.pp authority - | `Query (name, _) -> Fmt.pf ppf "query %a" Domain_name.pp name - let equal a b = match a, b with - | `Out (rc, an, au, _), `Out (rc', an', au', _) -> + [ `Out of Rcode.t * Name_rr_map.t * Name_rr_map.t + | `Query of [ `raw ] Domain_name.t + ] * Dns_cache.t + let pp ppf (r, _) = match r with + | `Out (rcode, answer, authority) -> Fmt.pf ppf "out %a answer %a authority %a" Rcode.pp rcode Name_rr_map.pp answer Name_rr_map.pp authority + | `Query name -> Fmt.pf ppf "query %a" Domain_name.pp name + let equal (a, _) (b, _) = match a, b with + | `Out (rc, an, au), `Out (rc', an', au') -> Rcode.compare rc rc' = 0 && Name_rr_map.equal an an' && Name_rr_map.equal au au' - | `Query (name, _), `Query (name', _) -> Domain_name.equal name name' + | `Query name, `Query name' -> Domain_name.equal name name' | _, _ -> false end in (module M: Alcotest.TESTABLE with type t = M.t) @@ -41,11 +41,11 @@ let follow_cname_cycle () = (`Entry (B (Cname, cname))) in Alcotest.check follow_res "CNAME single cycle is detected" - (`Out (Rcode.NoError, circ_map, Name_rr_map.empty, cache)) + (`Out (Rcode.NoError, circ_map, Name_rr_map.empty), cache) (Dns_resolver_cache.follow_cname cache 0L A ~name:(name "foo.com") 250l ~alias:(name "foo.com")); Alcotest.check follow_res "CNAME single cycle after timeout errors" - (`Query (name "foo.com", cache)) + (`Query (name "foo.com"), cache) (Dns_resolver_cache.follow_cname cache (sec 251) A ~name:(name "foo.com") 250l ~alias:(name "foo.com")); let a = 250l, name "bar.com" @@ -62,16 +62,43 @@ let follow_cname_cycle () = (Name_rr_map.singleton (name "foo.com") Cname a) in Alcotest.check follow_res "CNAME cycle is detected" - (`Out (Rcode.NoError, c_map, Name_rr_map.empty, cache)) + (`Out (Rcode.NoError, c_map, Name_rr_map.empty), cache) (Dns_resolver_cache.follow_cname cache 0L A ~name:(name "bar.com") 250l ~alias:(name "foo.com")); Alcotest.check follow_res "Query foo.com (since it timed out)" - (`Query (name "foo.com", cache)) + (`Query (name "foo.com"), cache) (Dns_resolver_cache.follow_cname cache (sec 251) A ~name:(name "bar.com") 250l ~alias:(name "foo.com")) +let follow_cnames () = + let cname = 250l, name "bar.com" in + let map = Name_rr_map.singleton (name "foo.com") Cname cname in + let cache = + Dns_cache.set empty 0L (name "foo.com") A AuthoritativeAnswer + (`Entry (B (Cname, cname))) + in + Alcotest.check follow_res "CNAME is followed" + (`Query (name "bar.com"), cache) + (Dns_resolver_cache.follow_cname cache 0L A + ~name:(name "foo.com") 250l ~alias:(name "foo.com")); + Alcotest.check follow_res "CNAME after timeout errors" + (`Query (name "foo.com"), cache) + (Dns_resolver_cache.follow_cname cache (sec 251) A + ~name:(name "foo.com") 250l ~alias:(name "foo.com")); + let a_val = (250l, Rr_map.Ipv4_set.singleton (ip "1.2.3.4")) in + let a = Rr_map.(B (A, a_val)) in + let cache = + Dns_cache.set cache 0L (name "bar.com") A AuthoritativeAnswer (`Entry a) + in + let map = Name_rr_map.add (name "bar.com") A a_val map in + Alcotest.check follow_res "CNAME is followed" + (`Out (Rcode.NoError, map, Name_rr_map.empty), cache) + (Dns_resolver_cache.follow_cname cache 0L A + ~name:(name "foo.com") 250l ~alias:(name "foo.com")) + let follow_cname_tests = [ "follow_cname cycles", `Quick, follow_cname_cycle ; + "follow_cname works", `Quick, follow_cnames ; ] (* let resolve_ns_ret = @@ -1287,7 +1314,7 @@ let scrub_tests = [ ] let tests = [ - "follow_cname cycles", follow_cname_tests ; + "follow_cname", follow_cname_tests ; (* "resolve_ns", resolve_ns_tests ; "find_ns", find_ns_tests ; *) (* "resolve", resolve_tests ;*) From 7373832e7d60998c0f4f0183787cce3577d2c042 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Tue, 13 Jul 2021 17:10:08 +0200 Subject: [PATCH 2/2] Dns_resolver_cache.answer: revive the cname and any code Dns_cache: provide a get_any function --- cache/dns_cache.ml | 40 +++++++++++++++ cache/dns_cache.mli | 7 +++ resolver/dns_resolver_cache.ml | 90 +++++++++++++++++++--------------- 3 files changed, 98 insertions(+), 39 deletions(-) diff --git a/cache/dns_cache.ml b/cache/dns_cache.ml index 3124f6bde..46968d657 100644 --- a/cache/dns_cache.ml +++ b/cache/dns_cache.ml @@ -185,6 +185,46 @@ 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 minimum -> + metrics `Hit; Ok (`No_domain (name, { soa with Soa.minimum })) + 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 + match Rr_map.is_empty r with + | true -> metrics `Drop; Error `Cache_drop + | false -> metrics `Hit; Ok (`Entries r) + let get_or_cname cache ts name query_type = metrics `Lookup; match diff --git a/cache/dns_cache.mli b/cache/dns_cache.mli index 0f7d20be5..18122a880 100644 --- 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 index 4a52ecfcc..79bad7030 100644 --- 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