Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

further fixes for cache and resolver #257

Merged
merged 2 commits into from
Jul 13, 2021
Merged

further fixes for cache and resolver #257

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
1f68d03
Dns_resolver: remove type alias, use Dns_cache.get_or_cname
hannesm Jul 13, 2021
7373832
Dns_resolver_cache.answer: revive the cname and any code
hannesm Jul 13, 2021
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
40 changes: 40 additions & 0 deletions cache/dns_cache.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
7 changes: 7 additions & 0 deletions cache/dns_cache.mli
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
15 changes: 8 additions & 7 deletions resolver/dns_resolver.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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 ->
Expand All @@ -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
| _ ->
Expand Down
116 changes: 62 additions & 54 deletions resolver/dns_resolver_cache.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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);
Expand All @@ -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
Expand All @@ -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
Expand All @@ -339,52 +335,64 @@ 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)
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
flags, data
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))
| 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))
| 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))
| 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)
(* | 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) *)
(* | 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)
| `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)
| `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) *)
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
| `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.<name> (a service name!) *)
(* TODO unclear why it's here... *)
let qname', qtype' =
Expand Down
32 changes: 14 additions & 18 deletions resolver/dns_resolver_cache.mli
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -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
Loading