281 lines
12 KiB
OCaml
281 lines
12 KiB
OCaml
(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
|
|
|
|
open Dns
|
|
open Dns_resolver_cache
|
|
|
|
let src = Logs.Src.create "dns_resolver_util" ~doc:"DNS resolver util"
|
|
module Log = (val Logs.src_log src : Logs.LOG)
|
|
|
|
type e = E : 'a Rr_map.key * 'a Dns_cache.entry -> e
|
|
|
|
let invalid_soa name =
|
|
let p pre =
|
|
Result.value ~default:name
|
|
(Result.bind
|
|
(Domain_name.prepend_label name "invalid")
|
|
(fun n -> Domain_name.prepend_label n pre))
|
|
in
|
|
{
|
|
Soa.nameserver = p "ns" ; hostmaster = p "hostmaster" ;
|
|
serial = 1l ; refresh = 16384l ; retry = 2048l ;
|
|
expiry = 1048576l ; minimum = 300l
|
|
}
|
|
|
|
let rrsig rr_map ty =
|
|
match Rr_map.find Rrsig rr_map with
|
|
| Some v ->
|
|
Rr_map.Rrsig_set.find_first_opt (fun rrsig ->
|
|
rrsig.Rrsig.type_covered = Rr_map.to_int ty)
|
|
(snd v)
|
|
| None -> None
|
|
|
|
let noerror bailiwick (_, flags) ~signed q_name q_type (answer, authority) additional =
|
|
(* maybe should be passed explicitly (when we don't do qname minimisation) *)
|
|
let in_bailiwick name = Domain_name.is_subdomain ~domain:bailiwick ~subdomain:name in
|
|
(* ANSWER *)
|
|
let answers, anames =
|
|
match Domain_name.Map.find q_name answer with
|
|
| None ->
|
|
(* NODATA (no answer, but SOA (or not) in authority) *)
|
|
begin
|
|
(* RFC2308, Sec 2.2 "No data":
|
|
- answer is empty
|
|
- authority has a) SOA + NS, b) SOA, or c) nothing *)
|
|
(* an example for this behaviour is NS:
|
|
asking for AAAA www.soup.io, get empty answer + SOA in authority
|
|
asking for AAAA coffee.soup.io, get empty answer + authority *)
|
|
(* the "sub" should be relaxed - for dig ns mail.mehnert.org I get soa in mehnert.org!
|
|
--> but how to discover SOA/zone boundaries? *)
|
|
let rank rrsig =
|
|
if Packet.Flags.mem `Authoritative flags then
|
|
Dns_cache.AuthoritativeAuthority (if signed then rrsig else None)
|
|
else
|
|
Dns_cache.Additional
|
|
in
|
|
match
|
|
Domain_name.Map.fold (fun name rr_map acc ->
|
|
if Domain_name.is_subdomain ~subdomain:q_name ~domain:name then
|
|
match Rr_map.find Soa rr_map with
|
|
| Some soa -> (name, soa, rr_map) :: acc
|
|
| None -> acc
|
|
else
|
|
acc)
|
|
authority []
|
|
with
|
|
| (name, soa, rr_map)::_ ->
|
|
begin match q_type with
|
|
| `Any -> [] (* i really don't know how to handle ANY NoDATA*)
|
|
| `K Rr_map.K k -> [ q_name, E (k, `No_data (name, soa)), rank (rrsig rr_map Soa) ]
|
|
(* this is wrong for the normal iterative algorithm:
|
|
it asks for foo.com @root, and get .com NS in AU and A in AD
|
|
| [] when not (Packet.Header.FS.mem `Truncation flags) ->
|
|
Log.warn (fun m -> m "noerror answer, but nothing in authority whose sub is %a in %a, invalid_soa!"
|
|
pp_question (q_name, q_type) Name_rr_map.pp authority) ;
|
|
[ q_type, q_name, Additional, `No_data (q_name, invalid_soa q_name) ] *)
|
|
end
|
|
| [] -> [] (* general case when we get an answer from root server *)
|
|
end, Domain_name.Set.empty
|
|
| Some rr_map ->
|
|
let rank rrsig =
|
|
if Packet.Flags.mem `Authoritative flags then
|
|
Dns_cache.AuthoritativeAnswer (if signed then rrsig else None)
|
|
else
|
|
Dns_cache.NonAuthoritativeAnswer
|
|
in
|
|
(* collect those rrsets which are of interest depending on q_type! *)
|
|
match q_type with
|
|
| `Any ->
|
|
Rr_map.fold (fun (B (k, v)) (acc, names) ->
|
|
(q_name, E (k, `Entry v), rank (rrsig rr_map k)) :: acc,
|
|
Domain_name.Host_set.fold (fun n acc ->
|
|
Domain_name.Set.add (Domain_name.raw n) acc)
|
|
(Rr_map.names k v) names)
|
|
rr_map ([], Domain_name.Set.empty)
|
|
| `K (Rr_map.K Cname) ->
|
|
begin match Rr_map.find Cname rr_map with
|
|
| Some v -> [ q_name, E (Cname, `Entry v), rank (rrsig rr_map Cname) ],
|
|
Domain_name.Host_set.fold (fun n acc ->
|
|
Domain_name.Set.add (Domain_name.raw n) acc)
|
|
(Rr_map.names Cname v) Domain_name.Set.empty
|
|
| None ->
|
|
(* case no cname *)
|
|
Log.warn (fun m -> m "noerror answer with right name, but no cname in %a, invalid soa for %a"
|
|
Name_rr_map.pp answer pp_question (q_name, q_type));
|
|
[ q_name, E (Cname, `No_data (q_name, invalid_soa q_name)), rank None ],
|
|
Domain_name.Set.empty
|
|
end
|
|
| `K (Rr_map.K k) -> match Rr_map.find k rr_map with
|
|
| Some v ->
|
|
[ q_name, E (k, `Entry v), rank (rrsig rr_map k) ],
|
|
Domain_name.Host_set.fold (fun n acc ->
|
|
Domain_name.Set.add (Domain_name.raw n) acc)
|
|
(Rr_map.names k v) Domain_name.Set.empty
|
|
| None -> match Rr_map.find Cname rr_map with
|
|
| None ->
|
|
(* case neither TYP nor cname *)
|
|
Log.warn (fun m -> m "noerror answer with right name, but not TYP nor cname in %a, invalid soa for %a"
|
|
Name_rr_map.pp answer pp_question (q_name, q_type));
|
|
[ q_name, E (k, `No_data (q_name, invalid_soa q_name)), rank None ],
|
|
Domain_name.Set.empty
|
|
| Some cname ->
|
|
(* explicitly register as CNAME so it'll be found *)
|
|
(* should we try to find further records for the new alias? *)
|
|
[ q_name, E (Cname, `Entry cname), rank (rrsig rr_map Cname) ],
|
|
Domain_name.Set.singleton (snd cname)
|
|
in
|
|
|
|
(* AUTHORITY - NS and DS records, also nsec and nsec3 *)
|
|
let ns, nsnames =
|
|
(* authority points us to NS of q_name! *)
|
|
(* we collect a list of NS records and the ns names *)
|
|
(* TODO need to be more careful, q: foo.com a: foo.com a 1.2.3.4 au: foo.com ns blablubb.com ad: blablubb.com A 1.2.3.4 *)
|
|
let rank s =
|
|
if Packet.Flags.mem `Authoritative flags then
|
|
Dns_cache.AuthoritativeAuthority (if signed then s else None)
|
|
else
|
|
Dns_cache.Additional
|
|
in
|
|
let ns, others, names =
|
|
Domain_name.Map.fold (fun name map (ns_acc, other_acc, s) ->
|
|
if in_bailiwick name then
|
|
let ns, s =
|
|
match Rr_map.find Ns map with
|
|
| None -> ns_acc, s
|
|
| Some (ns : int32 * Domain_name.Host_set.t) ->
|
|
(name, ns) :: ns_acc, Domain_name.Host_set.fold (fun n acc ->
|
|
Domain_name.Set.add (Domain_name.raw n) acc)
|
|
(snd ns) s
|
|
in
|
|
let others = match Rr_map.find Nsec map with
|
|
| None -> other_acc
|
|
| Some n -> (name, E (Nsec, `Entry n), rank (rrsig map Nsec)) :: other_acc
|
|
in
|
|
let others = match Rr_map.find Nsec3 map with
|
|
| None -> others
|
|
| Some n -> (name, E (Nsec3, `Entry n), rank (rrsig map Nsec3)) :: others
|
|
in
|
|
let others = match Rr_map.find Ds map with
|
|
| None -> others
|
|
| Some n -> (name, E (Ds, `Entry n), rank (rrsig map Ds)) :: others
|
|
in
|
|
ns, others, s
|
|
else
|
|
ns_acc, other_acc, s)
|
|
authority
|
|
([], [], Domain_name.Set.empty)
|
|
in
|
|
List.fold_left (fun acc (name, ns) ->
|
|
(name, E (Ns, `Entry ns), rank None) :: acc)
|
|
others ns, names
|
|
in
|
|
|
|
(* ADDITIONAL *)
|
|
(* maybe only these thingies which are subdomains of q_name? *)
|
|
(* preserve A/AAAA records only for NS lookups? *)
|
|
(* now we have processed:
|
|
- answer (filtered to where name = q_name)
|
|
- authority with SOA and NS entries
|
|
- names from these answers, and authority
|
|
- additional section can contain glue records if needed
|
|
- only A and AAAA records are of interest for glue *)
|
|
let glues =
|
|
let names = Domain_name.Set.union anames nsnames in
|
|
let names = Domain_name.Set.filter in_bailiwick names in
|
|
Domain_name.Set.fold (fun name acc ->
|
|
match Domain_name.Map.find name additional with
|
|
| None -> acc
|
|
| Some map ->
|
|
let a = match Rr_map.find A map with
|
|
| None -> acc
|
|
| Some v -> (name, E (A, `Entry v), Dns_cache.Additional) :: acc
|
|
in
|
|
match Rr_map.find Aaaa map with
|
|
| None -> a
|
|
| Some v -> (name, E (Aaaa, `Entry v), Dns_cache.Additional) :: a)
|
|
names []
|
|
in
|
|
(* This is defined in RFC2181, Sec9 -- answer is unique if authority or
|
|
additional is non-empty *)
|
|
let answer_complete =
|
|
not (Domain_name.Map.is_empty authority && Domain_name.Map.is_empty additional)
|
|
in
|
|
match answers, ns with
|
|
| [], [] when not answer_complete && Packet.Flags.mem `Truncation flags ->
|
|
(* special handling for truncated replies.. better not add anything *)
|
|
Log.warn (fun m -> m "truncated reply for %a, ignoring completely"
|
|
pp_question (q_name, q_type));
|
|
[]
|
|
| [], [] ->
|
|
(* not sure if this can happen, maybe discard everything? *)
|
|
Log.warn (fun m -> m "reply without answers or ns invalid so for %a"
|
|
pp_question (q_name, q_type));
|
|
begin match q_type with
|
|
| `Any -> []
|
|
| `K Rr_map.K k -> [ q_name, E (k,`No_data (q_name, invalid_soa q_name)), Dns_cache.Additional ]
|
|
end
|
|
| _, _ -> answers @ ns @ glues
|
|
|
|
let find_soa name authority =
|
|
let rec go name =
|
|
match Domain_name.Map.find name authority with
|
|
| None -> go (Domain_name.drop_label_exn name)
|
|
| Some rrmap -> match Rr_map.(find Soa rrmap) with
|
|
| None -> go (Domain_name.drop_label_exn name)
|
|
| Some soa -> name, soa, rrsig rrmap Soa
|
|
in
|
|
try Some (go name) with Invalid_argument _ -> None
|
|
|
|
let nxdomain (_, flags) ~signed name data =
|
|
(* we can't do much if authoritiative is not set (some auth dns do so) *)
|
|
(* There are cases where answer is non-empty, but contains a CNAME *)
|
|
(* RFC 2308 Sec 1 + 2.1 show that NXDomain is for the last QNAME! *)
|
|
(* -> need to potentially extract CNAME(s) *)
|
|
let answer, authority = match data with
|
|
| None -> Name_rr_map.empty, Name_rr_map.empty
|
|
| Some x -> x
|
|
in
|
|
let cnames =
|
|
let rec go acc name =
|
|
match Domain_name.Map.find name answer with
|
|
| None -> acc
|
|
| Some rrmap -> match Rr_map.(find Cname rrmap) with
|
|
| None -> acc
|
|
| Some (ttl, alias) -> go ((name, (ttl, alias), rrsig rrmap Cname) :: acc) alias
|
|
in
|
|
go [] name
|
|
in
|
|
let soa = find_soa name authority in
|
|
(* since NXDomain have CNAME semantics, we store them as CNAME *)
|
|
let rank rrsig =
|
|
if Packet.Flags.mem `Authoritative flags then
|
|
Dns_cache.AuthoritativeAnswer (if signed then rrsig else None)
|
|
else
|
|
Dns_cache.NonAuthoritativeAnswer
|
|
in
|
|
(* we conclude NXDomain, there are 3 cases we care about:
|
|
no soa in authority and no cname answer -> inject an invalid_soa (avoid loops)
|
|
a matching soa, no cname -> NoDom q_name
|
|
_, a matching cname -> NoErr q_name with cname
|
|
*)
|
|
let entries =
|
|
let soa_name, soa, rrsig = match soa with
|
|
| None -> name, invalid_soa name, None
|
|
| Some x -> x
|
|
in
|
|
match cnames with
|
|
| [] -> [ name, E (Cname, `No_domain (soa_name, soa)), rrsig ]
|
|
| rrs -> List.map (fun (name, cname, rrsig) -> (name, E (Cname, `Entry cname), rrsig)) rrs
|
|
in
|
|
(* the cname does not matter *)
|
|
List.map (fun (name, res, rrsig) -> name, res, rank rrsig) entries
|
|
|
|
let scrub zone ~signed qtype p =
|
|
Log.debug (fun m -> m "scrubbing (bailiwick %a) data %a"
|
|
Domain_name.pp zone Packet.pp p);
|
|
let qname = fst p.question in
|
|
match p.Packet.data with
|
|
| `Answer data ->
|
|
Ok (noerror zone p.header ~signed qname qtype data p.additional)
|
|
| `Rcode_error (Rcode.NXDomain, _, data) ->
|
|
Ok (nxdomain p.Packet.header ~signed qname data)
|
|
| e -> Error (Packet.rcode_data e)
|