swrup/mte
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Browse source
This commit is contained in:
swrup 2025-11-11 02:07:51 +01:00
parent aa2ff7b2f0
commit 2f3113f55d
11742 changed files with 1223940 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

100
unikernel/duniverse/ocaml-dns/resolver/dns_block.ml Normal file
View file

@ -0,0 +1,100 @@
open Dns
let src = Logs.Src.create "dns_block" ~doc:"DNS block"
module Log = (val Logs.src_log src : Logs.LOG)
let nameserver =
let lh = Domain_name.of_string_exn "localhost"
and bl = Domain_name.of_string_exn "blocked"
in
fun ns -> Domain_name.equal ns lh || Domain_name.equal ns bl
let ipv4 =
let lh = Ipaddr.V4.(Set.singleton localhost)
and any = Ipaddr.V4.(Set.singleton any)
in
fun ipv4s -> Ipaddr.V4.Set.equal ipv4s lh || Ipaddr.V4.Set.equal ipv4s any
let ipv6 =
let lh = Ipaddr.V6.(Set.singleton localhost)
and un = Ipaddr.V6.(Set.singleton unspecified)
in
fun ipv6s -> Ipaddr.V6.Set.equal ipv6s lh || Ipaddr.V6.Set.equal ipv6s un
let likely reply =
(* HACK! We assume blocked domains have a certain shape. *)
let blocked_soa auth =
Domain_name.Map.cardinal auth > 0 &&
Domain_name.Map.for_all (fun _domain rr ->
match Rr_map.find Rr_map.Soa rr with
| None -> false
| Some soa -> nameserver soa.nameserver)
auth
in
match reply.Packet.data with
| `Answer (answ, _auth) ->
Domain_name.Map.for_all
(fun _domain rr ->
Rr_map.for_all
(function
| Rr_map.B (Rr_map.A, (_, ips)) -> ipv4 ips
| Rr_map.B (Rr_map.Aaaa, (_, ips)) -> ipv6 ips
| _ -> false)
rr)
answ
| `Rcode_error (Rcode.NXDomain, _, Some (_answ, auth)) -> blocked_soa auth
| _ -> false
let reason reply =
let find_soa_hostmaster rr =
match Rr_map.find Rr_map.Soa rr with
| None -> None
| Some soa ->
if nameserver soa.Soa.nameserver then
Some (Domain_name.to_string soa.Soa.hostmaster)
else
None
in
let find_soa_hostmaster_in_domain_map map =
Domain_name.Map.fold (fun _domain rr acc ->
match acc, find_soa_hostmaster rr with
| None, x -> x
| Some x, None -> Some x
| Some x, Some y ->
if not (String.equal x y) then
Log.info (fun m -> m "finding blocklist resulted in %S and %S, using the first" x y);
Some x) map None
in
let find_soa_hostmaster_in_reply answer authority =
match find_soa_hostmaster_in_domain_map answer, find_soa_hostmaster_in_domain_map authority with
| None, x -> x
| Some x, None -> Some x
| Some x, Some y ->
if not (String.equal x y) then
Log.info (fun m -> m "finding blocklist resulted in %S (answer) and %S (authority), using the first" x y);
Some x
in
let r =
match reply.Packet.data with
| `Answer (answ, auth) -> find_soa_hostmaster_in_reply answ auth
| `Rcode_error (Rcode.NXDomain, _, Some (answ, auth)) ->
find_soa_hostmaster_in_reply answ auth
| _ -> None
in
Option.map (fun reason -> "appears in blocklist " ^ reason) r
let edns reply =
if likely reply then
(* After guessing that a domain is blocked we add [`Filtered] extended error
code and emit a [`Blocked] metrics event. *)
let reason = reason reply in
match reply.edns with
| None ->
Some (Edns.create ~extended_error:(`Blocked, reason) ())
| Some ({ Edns.extensions = []; extended_rcode; version; dnssec_ok; payload_size }) ->
Some (Edns.create ~extended_error:(`Blocked, reason) ~extended_rcode ~version ~dnssec_ok ~payload_size ())
| Some edns ->
Log.warn (fun m -> m "don't know how to extend edns to add extended error; not doing anything:@ %a" Edns.pp edns);
Some edns
else
None

667
unikernel/duniverse/ocaml-dns/resolver/dns_resolver.ml Normal file
View file

@ -0,0 +1,667 @@
(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
open Dns
type key = [ `raw ] Domain_name.t * Packet.Question.qtype
let pp_key = Dns_resolver_cache.pp_question
let src = Logs.Src.create "dns_resolver" ~doc:"DNS resolver"
module Log = (val Logs.src_log src : Logs.LOG)
(* The cache (a Map!?) for answers: once a specific type/name comes in, we know
which questions can progress now *)
module QM = Map.Make(struct
type t = key
let compare (n, t) (n', t') =
match Domain_name.compare n n' with
| 0 -> Packet.Question.compare_qtype t t'
| x -> x
end)
type awaiting = {
ts : int64;
retry : int;
proto : proto;
zone : [ `raw ] Domain_name.t;
edns : Edns.t option;
ip : Ipaddr.t;
port : int;
question : key;
id : int;
checking_disabled : bool;
dnssec_ok : bool;
}
let awaiting_eq a b =
Ipaddr.compare a.ip b.ip = 0 &&
Int.equal a.port b.port &&
Domain_name.equal (fst a.question) (fst b.question) &&
Packet.Question.compare_qtype (snd a.question) (snd b.question) = 0 &&
Int.equal a.id b.id
module TM = Map.Make(struct
type t = key * Ipaddr.t * int * int
let compare ((n, t), ip, port, id) ((n', t'), ip', port', id') =
let andThen v f = match v with 0 -> f () | x -> x in
andThen (Domain_name.compare n n')
(fun () -> andThen (Packet.Question.compare_qtype t t')
(fun () -> andThen (Ipaddr.compare ip ip')
(fun () -> andThen (Int.compare port port')
(fun () -> Int.compare id id'))))
end)
let retry_interval = Duration.of_ms 500
type feature =
[ `Dnssec | `Qname_minimisation | `Opportunistic_tls_authoritative ]
module FS = Set.Make(struct
type t = feature
let compare a b = match a, b with
| `Dnssec, `Dnssec -> 0 | `Dnssec, _ -> 1 | _, `Dnssec -> -1
| `Qname_minimisation, `Qname_minimisation -> 0
| `Qname_minimisation, _ -> 1
| _, `Qname_minimisation -> -1
| `Opportunistic_tls_authoritative, `Opportunistic_tls_authoritative -> 0
(* | `Opportunistic_tls_authoritative, _ -> 1
| _, `Opportunistic_tls_authoritative -> -1 *)
end)
type t = {
ip_protocol : [ `Both | `Ipv4_only | `Ipv6_only ];
features : FS.t ;
rng : int -> string ;
primary : Dns_server.Primary.s ;
cache : Dns_cache.t ;
transit : awaiting TM.t ;
queried : awaiting list QM.t ;
mutable clients : Ipaddr.Set.t ;
record_clients : bool ;
}
let create ?(record_clients = true) ?(cache_size = 10000) ?(ip_protocol = `Both) features now rng primary =
let cache = Dns_cache.empty cache_size in
let cache =
List.fold_left (fun cache (name, b) ->
Dns_cache.set cache now
name A Dns_cache.Additional
(`Entry b))
cache Dns_resolver_root.a_records
in
let cache =
List.fold_left (fun cache (name, b) ->
Dns_cache.set cache now
name Aaaa Dns_cache.Additional
(`Entry b))
cache Dns_resolver_root.aaaa_records
in
let cache =
Dns_cache.set cache now
Domain_name.root Ns Dns_cache.Additional
(`Entry Dns_resolver_root.ns_records)
in
let cache =
Dns_cache.set cache now
Domain_name.root Ds Dns_cache.Additional
(`Entry (Int32.max_int, Dnssec.root_ds))
in
let features = FS.of_list features in
{ ip_protocol ; features ; rng ; cache ; primary ; transit = TM.empty ; queried = QM.empty ;
clients = Ipaddr.Set.empty ; record_clients }
let features t = FS.elements t.features
let pick rng = function
| [] -> None
| [ x ] -> Some x
| xs -> Some (List.nth xs (Randomconv.int ~bound:(List.length xs) rng))
let build_query ?id ?(recursion_desired = false) ?(checking_disabled = false) ?(dnssec_ok = true) t ts proto question retry zone edns ip =
let id = match id with Some id -> id | None -> Randomconv.int16 t.rng in
let header =
let flags =
(* tell the NS we will do the checking.
See: https://www.rfc-editor.org/rfc/rfc4035#section-4.6 *)
let flags =
if FS.mem `Dnssec t.features then
Packet.Flags.singleton `Checking_disabled
else Packet.Flags.empty
in
if recursion_desired then
Packet.Flags.add `Recursion_desired flags
else
flags
in
id, flags
in
let el = { ts; retry; proto; zone; edns; ip; port = 53; question; id; checking_disabled; dnssec_ok } in
let key = question, ip, el.port, id in
let transit =
if TM.mem key t.transit then
Log.warn (fun m -> m "overwriting transit of %a" pp_key question) ;
TM.add key el t.transit
in
let packet = Packet.create ?edns header (question :> Packet.Question.t) `Query in
let cs, _ = Packet.encode proto packet in
{ t with transit }, cs
let query ?recursion_desired t ts await retry ip name typ =
let k = (name, typ) in
let await = { await with retry = succ await.retry } in
(* TODO here we may want to use the _default protocol_ (and edns settings) instead of `Udp *)
let payload_size = if FS.mem `Dnssec t.features then Some 1220 (* from RFC 4035 4.1 *) else None in
let edns = Some (Edns.create ~dnssec_ok:(FS.mem `Dnssec t.features) ?payload_size ()) in
let t, packet = build_query ?recursion_desired ~checking_disabled:await.checking_disabled ~dnssec_ok:await.dnssec_ok t ts `Udp k retry await.zone edns ip in
let queried =
let q = Option.value ~default:[] (QM.find_opt k t.queried) in
if List.exists (awaiting_eq await) q then q else await :: q
in
let t = { t with queried = QM.add k queried t.queried } in
Log.debug (fun m -> m "query: query %a %a" Ipaddr.pp ip pp_key k) ;
(packet, ip), t
let was_in_transit t key id sender sport =
let tm_key = key, sender, sport, id in
match TM.find tm_key t with
| exception Not_found ->
Log.warn (fun m -> m "key %a not present in set (likely retransmitted)"
pp_key key);
None, t
| awaiting ->
if Ipaddr.compare sender awaiting.ip = 0 && id = awaiting.id then
Some (awaiting.zone, awaiting.edns), TM.remove tm_key t
else
(Log.warn (fun m -> m "unsolicited reply for %a (id %04X vs o_id %04X, sender %a vs o_sender %a)"
pp_key key id awaiting.id Ipaddr.pp sender Ipaddr.pp awaiting.ip);
None, t)
let find_queries t k =
match QM.find k t with
| exception Not_found ->
Log.warn (fun m -> m "couldn't find entry %a in map" pp_key k) ;
t, []
| vals ->
QM.remove k t, vals
let handle_query ?(retry = 0) t ts awaiting =
if Int64.sub ts awaiting.ts > Int64.shift_left retry_interval 2 then begin
Log.warn (fun m -> m "dropping q %a from %a:%d (timed out)"
pp_key awaiting.question Ipaddr.pp awaiting.ip awaiting.port);
`Nothing, t
end else
let dnssec = FS.mem `Dnssec t.features && not awaiting.checking_disabled in
let qname_minimisation = FS.mem `Qname_minimisation t.features in
let r, cache = Dns_resolver_cache.handle_query t.cache ~qname_minimisation ~dnssec ~dnssec_ok:awaiting.dnssec_ok ~rng:t.rng t.ip_protocol ts awaiting.question in
let t = { t with cache } in
match r with
| `Queries _ when awaiting.retry >= 10 ->
Log.warn (fun m -> m "dropping q %a from %a:%d (already sent 10 packets)"
pp_key awaiting.question Ipaddr.pp awaiting.ip awaiting.port);
(* TODO reply with error! *)
`Nothing, t
| `Queries [] ->
Log.warn (fun m -> m "dropping q %a from %a:%d (queries is empty)"
pp_key awaiting.question Ipaddr.pp awaiting.ip awaiting.port);
`Nothing, t
| `Queries qs ->
let query_one (acc, t) (zone, (nam, types), ip) =
Log.debug (fun m -> m "have to query (zone %a) %a using ip %a"
Domain_name.pp zone
Fmt.(list ~sep:(any ", ") pp_key)
(List.map (fun t -> (nam, t)) types)
Ipaddr.pp ip);
let await = { awaiting with zone } in
List.fold_left (fun (acc, t) typ ->
let r, t = query t ts await retry ip nam typ in
r :: acc, t)
(acc, t) types
in
let r, t = List.fold_left query_one ([], t) qs in
`Query r, t
| `Reply (flags, answer, additional) ->
let time = Int64.sub ts awaiting.ts in
let max_size, edns = Edns.reply awaiting.edns in
let packet = Packet.create ?edns ?additional (awaiting.id, flags) (awaiting.question :> Packet.Question.t) (answer :> Packet.data) in
Log.debug (fun m -> m "answering %a after %a %d out packets: %a"
pp_key awaiting.question Duration.pp time awaiting.retry
Packet.pp packet) ;
Dns_resolver_metrics.response_metric time;
let cs, _ = Packet.encode ?max_size awaiting.proto packet in
let ttl = Packet.minimum_ttl (answer :> Packet.data) in
`Answer (ttl, cs), t
let scrub_it t proto zone edns ts ~signed qtype p =
match Dns_resolver_utils.scrub zone ~signed qtype p, edns with
| Ok xs, _ ->
let cache =
List.fold_left
(fun t (n, Dns_resolver_utils.E (ty, e), r) ->
(*Log.debug (fun m -> m "Dns_cache.set %a %a %a"
Rr_map.ppk (K ty) Domain_name.pp n (Dns_cache.pp_entry ty) e) ;*)
Dns_cache.set t ts n ty r e)
t xs
in
if Packet.Flags.mem `Truncation (snd p.header) && proto = `Udp then
(Log.warn (fun m -> m "NS truncated reply, using TCP now") ;
`Upgrade_to_tcp cache)
else
`Cache cache
| Error Rcode.FormErr, Some _ ->
Log.warn (fun m -> m "NS sent FormErr, retrying without edns!") ;
`Query_without_edns
| Error e, _ ->
Log.warn (fun m -> m "NS didn't like us %a" Rcode.pp e) ;
`Try_another_ns
let handle_primary t now ts proto sender sport packet _request buf =
(* makes only sense to ask primary for query=true since we'll never issue questions from primary *)
let handle_inner name =
let t, answer, _, _ = Dns_server.Primary.handle_packet t now ts proto sender sport packet name in
match answer with
| None -> `None (* TODO incoming ??? are never replied to - should be revised!? *)
| Some reply ->
(* delegation if authoritative is not set! *)
if Packet.Flags.mem `Authoritative (snd reply.header) then begin
Log.debug (fun m -> m "authoritative reply %a" Packet.pp reply) ;
let reply =
match Dns_block.edns reply with
| None -> reply
| Some edns ->
Dns_resolver_metrics.resolver_stats `Blocked;
Dns.Packet.with_edns reply (Some edns)
in
let r = Packet.encode proto reply in
let ttl = Packet.minimum_ttl reply.data in
`Reply (t, (reply, ttl, r))
end else match reply.data with
| `Answer data -> `Delegation (data, reply.additional)
| _ -> `None (* not authoritative, error!! *)
in
match Dns_server.(handle_tsig (Primary.server t) now packet buf) with
| Error (e, data) ->
Log.err (fun m -> m "tsig failed %a" Tsig_op.pp_e e);
begin match data with
| Some data -> `Reply (t, 0l, data)
| None -> `None
end
| Ok None ->
begin match handle_inner None with
| `Reply (t, (_, ttl, (out, _))) -> `Reply (t, ttl, out)
| `None -> `None
| `Delegation d -> `Delegation d
end
| Ok (Some (name, tsig, mac, key)) ->
match handle_inner (Some name) with
| `Reply (t, (reply, ttl, (buf, max_size))) ->
begin match Dns_server.((Primary.server t).tsig_sign) ~max_size ~mac name tsig ~key reply buf with
| None ->
Log.warn (fun m -> m "couldn't use %a to tsig sign, using unsigned reply" Domain_name.pp name) ;
`Reply (t, ttl, buf)
| Some (buf, _) -> `Reply (t, 0l, buf)
end
| `None -> `None
| `Delegation x -> `Delegation x
let handle_awaiting_queries ?retry t ts (name, typ) =
let queried, values = find_queries t.queried (name, typ) in
let t = { t with queried } in
List.fold_left (fun (t, out_a, out_q) awaiting ->
Log.debug (fun m -> m "now querying %a" pp_key awaiting.question) ;
match handle_query ?retry t ts awaiting with
| `Nothing, t -> t, out_a, out_q
| `Query pkts, t -> t, out_a, (List.map (fun (pkt, dst) -> (`Udp, dst, pkt)) pkts) @ out_q
| `Answer (ttl, pkt), t -> t, (awaiting.proto, awaiting.ip, awaiting.port, ttl, pkt) :: out_a, out_q)
(t, [], []) values
let resolve t ts proto sender sport req =
match req.Packet.data, Packet.Question.qtype req.Packet.question with
| `Query, Some q_type ->
Log.debug (fun m -> m "resolving %a" Packet.Question.pp req.question) ;
if not (Packet.Flags.mem `Recursion_desired (snd req.Packet.header)) then
Log.warn (fun m -> m "recursion not desired") ;
(* ask the cache *)
let checking_disabled = Packet.Flags.mem `Checking_disabled (snd req.header)
and dnssec_ok = match req.edns with None -> false | Some edns -> edns.Edns.dnssec_ok in
let awaiting = { ts; retry = 0; proto; zone = Domain_name.root ; edns = req.edns; ip = sender; port = sport; question = (fst req.question, q_type); id = fst req.header; checking_disabled; dnssec_ok } in
begin match handle_query t ts awaiting with
| `Answer (ttl, pkt), t ->
Log.debug (fun m -> m "answer %a" Packet.Question.pp req.question) ;
t, [ (proto, sender, sport, ttl, pkt) ], []
| `Nothing, t ->
Log.debug (fun m -> m "nothing %a" Packet.Question.pp req.question) ;
t, [], [] (* TODO: send a reply!? *)
| `Query pkts, t ->
Log.debug (fun m -> m "query %d %a" (List.length pkts) Packet.Question.pp req.question) ;
t, [], List.map (fun (packet, dst) -> `Udp, dst, packet) pkts
end
| _ ->
Log.err (fun m -> m "ignoring %a" Packet.pp req);
let pkt = Packet.create
(fst req.header, Packet.Flags.empty) req.question
(`Rcode_error (Rcode.NotImp, Packet.opcode_data req.data, None))
in
let buf, _ = Packet.encode proto pkt in
t, [ proto, sender, sport, 0l, buf ], []
let handle_reply t now ts proto sender sport packet reply =
match reply, Packet.Question.qtype packet.Packet.question with
| `Answer _, Some qtype
| `Rcode_error (Rcode.NXDomain, Opcode.Query, _), Some qtype
| `Rcode_error (Rcode.ServFail, Opcode.Query, _), Some qtype ->
begin
Log.debug (fun m -> m "handling reply to %a" Packet.Question.pp packet.question);
(* (a) first check whether frame was in transit! *)
let key = fst packet.question, qtype in
let r, transit = was_in_transit t.transit key (fst packet.header) sender sport in
let t = { t with transit } in
match r with
| None -> Ok (t, [], [])
| Some (zone, edns) ->
(* (b) DNSSec verification of RRs *)
let t, packet, signed =
if FS.mem `Dnssec t.features then
let t, dnskeys =
match qtype with
| `K K Rr_map.Dnskey ->
let cache, ds = Dns_cache.get t.cache ts zone Rr_map.Ds in
{ t with cache },
begin match ds with
| Ok (`Entry (_, ds_set), _) ->
let keys = match reply with
| `Answer (a, _) -> Name_rr_map.find zone Rr_map.Dnskey a
| _ -> None
in
let ds_set = Dnssec.filter_ds_if_sha2_present ds_set in
Option.map (fun (_, dnskeys) ->
Rr_map.Ds_set.fold (fun ds acc ->
match Dnssec.validate_ds zone dnskeys ds with
| Ok key -> Rr_map.Dnskey_set.add key acc
| Error `Msg msg ->
Log.debug (fun m -> m "couldn't validate DS (for %a): %s"
Domain_name.pp zone msg);
acc
| Error `Extended e ->
Log.debug (fun m -> m "couldn't validate DS (for %a): %a"
Domain_name.pp zone
Extended_error.pp e);
acc)
ds_set Rr_map.Dnskey_set.empty)
keys
| _ ->
Log.warn (fun m -> m "no DS in cache for %a" Domain_name.pp zone);
None
end
| _ ->
let cache, dnskeys = Dns_cache.get t.cache ts zone Rr_map.Dnskey in
{ t with cache },
match dnskeys with
| Ok (`Entry (_, dnskey_set), _) -> Some dnskey_set
| _ ->
Log.warn (fun m -> m "no DNSKEYS in cache for %a" Domain_name.pp zone);
None
in
let packet, signed =
match dnskeys with
| None ->
Log.warn (fun m -> m "no DNSKEY present, couldn't validate packet");
packet, false
| Some dnskeys ->
match Dnssec.verify_packet now dnskeys packet with
| Ok packet -> packet, true
| Error `Msg msg ->
Log.err (fun m -> m "error %s verifying reply %a"
msg Packet.pp_reply reply);
packet, false
in
t, packet, signed
else
t, packet, false
in
(* (c) now we scrub and either *)
match scrub_it t.cache proto zone edns ts ~signed qtype packet with
| `Query_without_edns ->
let t, cs = build_query t ts proto key 1 zone None sender in
Log.debug (fun m -> m "resolve: requery without edns %a %a"
Ipaddr.pp sender pp_key key) ;
Ok (t, [], [ `Udp, sender, cs ])
| `Upgrade_to_tcp cache ->
(* RFC 2181 Sec 9: correct would be to drop entire frame, and retry with tcp *)
(* but we're happy to retrieve the partial information, it may be useful *)
let t = { t with cache } in
(* this may provoke the very same question again -
but since tcp is first, that should trigger the TCP connection,
which is then reused... ok, we may send the same query twice
with different ids *)
(* TODO we may want to get rid of the handle_awaiting_queries
entirely here!? *)
let (t, out_a, out_q), recursion_desired =
handle_awaiting_queries t ts key, false
in
let edns = Some (Edns.create ~dnssec_ok:(FS.mem `Dnssec t.features) ()) in
let t, cs = build_query ~recursion_desired t ts `Tcp key 1 zone edns sender in
Log.debug (fun m -> m "resolve: upgrade to tcp %a %a"
Ipaddr.pp sender pp_key key) ;
Ok (t, out_a, (`Tcp, sender, cs) :: out_q)
| `Try_another_ns ->
(* is this the right behaviour? by luck we'll use another path *)
Ok (handle_awaiting_queries t ts key)
| `Cache cache ->
let t = { t with cache } in
Ok (handle_awaiting_queries t ts key)
end
| v, _ ->
Log.err (fun m -> m "ignoring reply %a" Packet.pp_reply v);
Error ()
let handle_delegation t ts proto sender sport req (delegation, add_data) =
Log.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 ->
let dnssec = FS.mem `Dnssec t.features && not (Packet.Flags.mem `Checking_disabled (snd req.header))
and dnssec_ok = match req.edns with None -> false | Some edns -> edns.Edns.dnssec_ok
in
let r, cache = Dns_resolver_cache.answer ~dnssec ~dnssec_ok 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 =
let ip4s, ip6s =
Domain_name.Map.fold (fun _ rrmap (ip4s, ip6s) ->
(match Rr_map.(find A rrmap) with
| None -> ip4s
| Some (_, ip4s') -> Ipaddr.V4.Set.union ip4s ip4s'),
(match Rr_map.(find Aaaa rrmap) with
| None -> ip6s
| Some (_, ip6s') -> Ipaddr.V6.Set.union ip6s ip6s'))
add_data (Ipaddr.V4.Set.empty, Ipaddr.V6.Set.empty)
in
let ip4s = List.map (fun ip -> Ipaddr.V4 ip) (Ipaddr.V4.Set.elements ip4s)
and ip6s = List.map (fun ip -> Ipaddr.V6 ip) (Ipaddr.V6.Set.elements ip6s)
in
match t.ip_protocol with
| `Both -> ip4s @ ip6s
| `Ipv4_only -> ip4s
| `Ipv6_only -> ip6s
in
begin match pick t.rng ips with
| None ->
Log.err (fun m -> m "something is wrong, delegation but no IP");
t, [], []
| Some ip ->
Log.debug (fun m -> m "found ip %a, maybe querying %a"
Ipaddr.pp ip pp_key (name, qtype)) ;
(* TODO is Domain_name.root correct here? *)
let checking_disabled = Packet.Flags.mem `Checking_disabled (snd req.header)
and dnssec_ok = match req.edns with None -> false | Some edns -> edns.Edns.dnssec_ok
in
let await = { ts; retry = 0; proto; zone = Domain_name.root; edns = req.edns; ip = sender; port = sport; question = (fst req.question, qtype); id = fst req.header; checking_disabled; dnssec_ok } in
let (cs, ip), t = query ~recursion_desired:true t ts await 0 ip name qtype in
t, [], [ `Udp, ip, cs ]
end
| `Packet (flags, reply, additional) ->
let max_size, edns = Edns.reply req.edns in
Log.debug (fun m -> m "delegation reply for %a from cache: %a"
Packet.pp req Packet.pp_reply reply) ;
let packet = Packet.create ?edns ?additional (fst req.header, flags) req.question (reply :> Packet.data) in
let ttl = Packet.minimum_ttl (reply :> Packet.data) in
let pkt, _ = Packet.encode ?max_size proto packet in
Dns_resolver_metrics.response_metric 0L;
t, [ proto, sender, sport, ttl, pkt ], []
(* send it out! we've a cache hit here! *)
end
| _ ->
Log.err (fun m -> m "ignoring %a" Packet.pp req) ;
let pkt =
Packet.create (fst req.header, Packet.Flags.empty)
req.question (`Rcode_error (Rcode.NotImp, Packet.opcode_data req.data, None))
in
t, [ proto, sender, sport, 0l, fst (Packet.encode proto pkt) ], []
let handle_buf t now ts query_allowed proto sender sport buf =
match Packet.decode buf with
(* | Error (`Bad_edns_version v) ->
Log.err (fun m -> m "bad edns version (from %a:%d) %u for@.%a"
Ipaddr.pp sender sport
v Cstruct.hexdump_pp buf) ;
t, handle_error ~error:Dns_enum.BadVersOrSig proto sender sport buf, [] *)
| Error e ->
Dns_resolver_metrics.resolver_stats `Error;
Log.err (fun m -> m "decode error (from %a:%d) %a for@.%a"
Ipaddr.pp sender sport
Packet.pp_err e Ohex.pp buf) ;
let answer = match Packet.raw_error buf Rcode.FormErr with
| None -> []
| Some data -> [ proto, sender, sport, 0l, data ]
in
t, answer, []
| Ok res ->
Log.debug (fun m -> m "reacting to packet from %a:%d"
Ipaddr.pp sender sport) ;
match res.Packet.data with
| #Packet.reply as reply ->
begin
match handle_reply t now ts proto sender sport res reply with
| Ok a ->
Log.debug (fun m -> m "handled reply %a:%d"
Ipaddr.pp sender sport) ;
a
| Error () -> t, [], []
end
| #Packet.request as req when query_allowed ->
Dns_resolver_metrics.resolver_stats `Queries;
if t.record_clients then
if not (Ipaddr.Set.mem sender t.clients) then begin
t.clients <- Ipaddr.Set.add sender t.clients;
Dns_resolver_metrics.resolver_stats `Clients
end;
begin
match handle_primary t.primary now ts proto sender sport res req buf with
| `Reply (primary, ttl, pkt) ->
Dns_resolver_metrics.response_metric 0L;
Log.debug (fun m -> m "handled primary %a:%d" Ipaddr.pp sender sport) ;
{ t with primary }, [ proto, sender, sport, ttl, pkt ], []
| `Delegation dele ->
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
end
| _ ->
Log.err (fun m -> m "ignoring unsolicited packet (query allowed? %b) %a" query_allowed Packet.pp res);
t, [], []
let query_root t now proto =
let root_ip () =
match pick t.rng (Dns_resolver_root.ips t.ip_protocol) with
| None -> assert false
| Some x -> x
in
let ip =
match Dns_cache.get t.cache now Domain_name.root Ns with
| _, Ok (`Entry (_, names), _) ->
let ip4s, ip6s =
Domain_name.Host_set.fold (fun name (v4s, v6s) ->
(match snd (Dns_cache.get t.cache now (Domain_name.raw name) A) with
| Ok (`Entry (_, ips), _) -> Ipaddr.V4.Set.union ips v4s
| _ -> v4s),
(match snd (Dns_cache.get t.cache now (Domain_name.raw name) Aaaa) with
| Ok (`Entry (_, ips), _) -> Ipaddr.V6.Set.union ips v6s
| _ -> v6s))
names (Ipaddr.V4.Set.empty, Ipaddr.V6.Set.empty)
in
let ip4s = List.map (fun ip -> Ipaddr.V4 ip) (Ipaddr.V4.Set.elements ip4s)
and ip6s = List.map (fun ip -> Ipaddr.V6 ip) (Ipaddr.V6.Set.elements ip6s)
in
let ips = match t.ip_protocol with
| `Both -> ip4s @ ip6s
| `Ipv4_only -> ip4s
| `Ipv6_only -> ip6s
in
begin match pick t.rng ips with
| Some ip -> ip
| None -> root_ip ()
end
| _ -> root_ip ()
in
let question = Domain_name.root, `K (Rr_map.K Ns)
and id = Randomconv.int16 t.rng
and edns = Some (Edns.create ())
and checking_disabled = false
and dnssec_ok = true
in
let el =
{ ts = now; retry = 0; proto; zone = Domain_name.root; edns; ip; port = 53; question; id; checking_disabled; dnssec_ok }
in
let key = question, ip, el.port, id in
let t = { t with transit = TM.add key el t.transit } in
let packet = Packet.create ?edns (id, Packet.Flags.empty) question `Query in
let cs, _ = Packet.encode proto packet in
t, (proto, ip, cs)
let max_retries = 5
let err_retries t question =
let t, reqs = find_queries t question in
t, List.fold_left (fun acc awaiting ->
Log.debug (fun m -> m "now erroring to %a" pp_key awaiting.question) ;
let packet = Packet.create (awaiting.id, Packet.Flags.empty)
(awaiting.question :> Packet.Question.t)
(`Rcode_error (Rcode.ServFail, Opcode.Query, None))
in
let buf, _ = Packet.encode awaiting.proto packet in
(awaiting.proto, awaiting.ip, awaiting.port, 0l, buf) :: acc)
[] reqs
let timer t ts =
let transit, rem =
TM.partition
(fun _ awaiting -> Int64.sub ts awaiting.ts < retry_interval)
t.transit
in
let t = { t with transit } in
if not (TM.is_empty transit && TM.is_empty rem) then
Log.debug (fun m -> m "try_other timer wheel -- keeping %d, running over %d"
(TM.cardinal transit) (TM.cardinal rem)) ;
TM.fold (fun ((name, typ), _ip, _port, _id) awaiting (t, out_a, out_q) ->
let retry = succ awaiting.retry in
if retry < max_retries then begin
let t, outa, outq = handle_awaiting_queries ~retry t ts (name, typ) in
(t, outa @ out_a, outq @ out_q)
end else begin
Log.info (fun m -> m "retry limit exceeded for %a at %a!"
pp_key (name, typ) Ipaddr.pp awaiting.ip) ;
let queried, out_as = err_retries t.queried (name, typ) in
({ t with queried }, out_as @ out_a, out_q)
end)
rem (t, [], [])
let primary_data t = Dns_server.Primary.data t.primary
let with_primary_data t now ts data =
let primary, outs = Dns_server.Primary.with_data t.primary now ts data in
{ t with primary }, outs

56
unikernel/duniverse/ocaml-dns/resolver/dns_resolver.mli Normal file
View file

@ -0,0 +1,56 @@
(* (c) 2018 Hannes Mehnert, all rights reserved *)
type t
(** The type of a DNS resolver. *)
type feature =
[ `Dnssec | `Qname_minimisation | `Opportunistic_tls_authoritative ]
val create : ?record_clients:bool -> ?cache_size:int ->
?ip_protocol:[ `Both | `Ipv4_only | `Ipv6_only ] ->
feature list ->
int64 -> (int -> string) -> Dns_server.Primary.s -> t
(** [create ~record_clients ~cache_size ~ip_protocol features now 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
emitted. If [`Both] (the default), either IPv4 and IPv6 packets are
emitted. If [record_clients] is true (the default), the metrics of
the resolver will include the amount of clients. This keeps a set of
Ipaddr.t of all clients around, which may use some memory if it is a public
resolver.
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.
*)
val features : t -> feature list
val handle_buf : t -> Ptime.t -> int64 -> bool -> Dns.proto -> Ipaddr.t ->
int -> string ->
t * (Dns.proto * Ipaddr.t * int * int32 * string) list
* (Dns.proto * Ipaddr.t * string) list
(** [handle_buf t now ts query_or_reply proto sender source-port buf] handles
resolution of [buf], which leads to a new [t], a list of answers to be
transmitted (quintuple of protocol, ip address, port, minimum ttl, buffer),
and a list of queries (triple of protocol, ip address, buffer). *)
val query_root : t -> int64 -> Dns.proto ->
t * (Dns.proto * Ipaddr.t * string)
(** [query_root t now proto] potentially requests an update of the root
zone. Best invoked by a regular timer. *)
val timer : t -> int64 ->
t * (Dns.proto * Ipaddr.t * int * int32 * string) list
* (Dns.proto * Ipaddr.t * string) list
(** [timer t now] potentially retransmits DNS requests and/or sends NXDomain
answers. *)
val primary_data : t -> Dns_trie.t
(** [primary_data t] is the DNS trie of the primary. *)
val with_primary_data : t -> Ptime.t -> int64 -> Dns_trie.t -> t * (Ipaddr.t * string list) list
(** [with_primary_data t now ts data] is a pair [(t', outs)] where [t'] is [t]
updated with the [data] DNS trie, and [outs] is the data to send out (if
any). *)

496
unikernel/duniverse/ocaml-dns/resolver/dns_resolver_cache.ml Normal file
View file

@ -0,0 +1,496 @@
(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
open Dns
module N = Domain_name.Set
let src = Logs.Src.create "dns_resolver_cache" ~doc:"DNS resolver cache"
module Log = (val Logs.src_log src : Logs.LOG)
let _pp_err ppf = function
| `Cache_miss -> Fmt.string ppf "cache miss"
| `Cache_drop -> Fmt.string ppf "cache drop"
let pp_question ppf (name, typ) =
Fmt.pf ppf "%a (%a)" Domain_name.pp name Packet.Question.pp_qtype typ
let is_signed = function
| Dns_cache.AuthoritativeAnswer signed
| AuthoritativeAuthority signed -> signed
| _ -> None
let find_nsec t ts typ name =
let rec up name =
match snd (Dns_cache.get t ts name Nsec) with
| Ok (`Entry (ttl, nsec), rank) ->
if Bit_map.mem (Rr_map.to_int typ) nsec.Nsec.types then
Some (name, (ttl, nsec), rank)
else
None
| _ ->
if Domain_name.count_labels name >= 1 then
up (Domain_name.drop_label_exn name)
else
None
in
up name
let nsec_no t ts typ name =
match find_nsec t ts typ name with
| Some _ -> true
| None -> false
let find_nsec3 t ts typ name =
let rec up name =
match snd (Dns_cache.get_nsec3 t ts name) with
| Ok nsec3 ->
let (_, _, Nsec3.{ iterations ; salt ; _ }, _) = List.hd nsec3 in
let soa_name = Domain_name.drop_label_exn name in
let hashed_name = Dnssec.nsec3_hashed_name salt iterations ~soa_name name in
List.find_opt (fun (name, _, nsec3, _) ->
let name = Domain_name.drop_label_exn ~rev:true name in
let hashed_next_owner =
Domain_name.prepend_label_exn soa_name
(Base32.encode nsec3.Nsec3.next_owner_hashed)
in
(* TODO non-wc-expanded nsec3 only?? *)
(Domain_name.compare name hashed_name < 0 &&
Domain_name.compare hashed_name hashed_next_owner < 0) ||
(* TODO wc nsec3 as well? *)
(Domain_name.compare name hashed_name = 0 &&
not (Bit_map.mem (Rr_map.to_int typ) nsec3.types))
)
nsec3
| Error _ ->
if Domain_name.count_labels name > 1 then
up (Domain_name.drop_label_exn name)
else
None
in
up name
let nsec3_covering t ts typ name =
match find_nsec3 t ts typ name with
| None -> false
| Some _ -> true
let upwards_ds_nonexisting t ts name =
let rec go name =
if nsec_no t ts Ds name || nsec3_covering t ts Ds name then
true
else
match Domain_name.drop_label name with
| Error _ -> false
| Ok name -> go name
in
go name
let find_nearest_ns ip_proto dnssec ts t name =
let find_ns name = match snd (Dns_cache.get t ts name Ns) with
| Ok (`Entry (_, names), r) -> Domain_name.Host_set.elements names, is_signed r
| _ -> [], None
and find_dnskey name = match snd (Dns_cache.get t ts name Dnskey) with
| Ok _ -> true
| _ -> false
and dnskey_nonexisting name = match snd (Dns_cache.get t ts name Dnskey) with
| Ok _ -> false
| Error _ ->
(* no need to check for Ds nonexistance upwards, since we're only called
if we have a Ds *)
nsec_no t ts Dnskey name || nsec3_covering t ts Dnskey name
and need_to_query_for_ds name = match snd (Dns_cache.get t ts name Ds) with
| Ok _ -> false
| Error _ -> not (upwards_ds_nonexisting t ts name)
and have_ds name =
match snd (Dns_cache.get t ts name Ds) with
| Ok (`Entry _, _) -> true
| _ -> false
and find_address name =
let ip4s =
Result.fold
~ok:(function
| `Entry (_, ips), _ ->
List.map (fun ip -> Ipaddr.V4 ip) (Ipaddr.V4.Set.elements ips)
| _ -> [])
~error:(fun _ -> [])
(snd (Dns_cache.get t ts name A))
and ip6s =
Result.fold
~ok:(function
| `Entry (_, ips), _ ->
List.map (fun ip -> Ipaddr.V6 ip) (Ipaddr.V6.Set.elements ips)
| _ -> [])
~error:(fun _ -> [])
(snd (Dns_cache.get t ts name Aaaa))
in
match ip_proto with
| `Both -> ip4s @ ip6s
| `Ipv4_only -> ip4s
| `Ipv6_only -> ip6s
in
let have_ips_or_dnskey name ips =
if dnssec && not (find_dnskey name) && have_ds name then
if dnskey_nonexisting name then (
(* this is tricky, and likely bad - we have a DS but no DNSKEY *)
Log.warn (fun m -> m "DS present for %a, but nonexisting DNSKEY (NSEC/NSEC3)"
Domain_name.pp name);
`HaveIPs (name, ips))
else
(* if dnssec is enabled, and have a DS record, and we don't have a dnskey,
request it -- avoiding loops by only asking for dnskey if there's DS *)
`NeedDnskey (name, ips)
else
`HaveIPs (name, ips)
in
let rec go nam =
(* Log.info (fun m -> m "go %a" Domain_name.pp nam); *)
let ns, signed_ns = find_ns nam in
match ns with
| [] ->
(* Log.warn (fun m -> m "go no NS for %a" Domain_name.pp nam); *)
if Domain_name.(equal root nam) then
[ have_ips_or_dnskey nam (Dns_resolver_root.ips ip_proto) ]
else
go (Domain_name.drop_label_exn nam)
| _ when dnssec && need_to_query_for_ds nam ->
(* dnssec enabled, and no DS (and no nonexistance proof for DS) ->
query for DS (which is always provided by the domain above:
"." has it for ".coop" / ".com" for "example/com"
-> this also avoids loops, if we get a negative reply for DS, we move
on (and run into the case below)
*)
(* Log.info (fun m -> m "need to query for DS %a" Domain_name.pp nam); *)
List.map (function
| `HaveIPs (_name, ips) -> `NeedDs (nam, ips)
| `NeedDnskey _ | `NeedAddress _ | `NeedDs _
| `NeedSignedNs _ as r -> r)
(if Domain_name.(equal root nam) then
[ have_ips_or_dnskey name (Dns_resolver_root.ips ip_proto) ]
else
go (Domain_name.drop_label_exn nam))
| name_servers ->
List.fold_left (fun acc ns ->
let host = Domain_name.raw ns in
match find_address host with
| [] ->
(* Log.info (fun m -> m "go no address for NS %a (for %a)"
Domain_name.pp host
Domain_name.pp nam); *)
if Domain_name.is_subdomain ~subdomain:ns ~domain:nam then
(* we actually need glue *)
if Domain_name.(equal root nam) then
have_ips_or_dnskey nam (Dns_resolver_root.ips ip_proto) :: acc
else
(go (Domain_name.drop_label_exn nam)) @ acc
else
`NeedAddress (nam, host) :: acc
| ips ->
(* Log.info (fun m -> m "go address for NS %a (for %a): %a (dnssec %B signed_ns %B have_ds %B find_dnskey %B)"
Domain_name.pp host
Domain_name.pp nam
Ipaddr.pp ip
dnssec (Option.is_some signed_ns) (have_ds nam)
(find_dnskey nam)); *)
if dnssec && Option.is_none signed_ns && have_ds nam then
if find_dnskey nam then
`NeedSignedNs (nam, ips) :: acc
else if dnskey_nonexisting nam then (
(* Log.warn (fun m -> m "DS present for %a, but NSEC/NSEC3 for DNSKEY"
Domain_name.pp nam); *)
have_ips_or_dnskey nam ips :: acc)
else
`NeedDnskey (nam, ips) :: acc
else
have_ips_or_dnskey nam ips :: acc)
[] name_servers
in
go name
let resolve t ~qname_minimisation ~dnssec ip_proto ts name typ =
(* the standard recursive algorithm *)
let addresses = match ip_proto with
| `Both -> [`K (Rr_map.K A); `K (Rr_map.K Aaaa)]
| `Ipv4_only -> [`K (Rr_map.K A)]
| `Ipv6_only -> [`K (Rr_map.K Aaaa)]
in
(* with DNSSec:
- input is qname and qtyp
- (a) we have (validated) NS record (+DNSKEY) for zone -> move along
- (b) we miss a NS entry -> drop label and find one
---> we also want to collect DS and DNSKEY entries (or non-existence of DS)
---> we get DS by dnssec ok in EDNS
---> we may have unsigned NS (+ glue), and need to ask the NS for NS (+dnssec)
---> we may have unsigned glue, and need to go down for signed A/AAAA
*)
let rec go t visited types zone name =
Log.debug (fun m -> m "go %a (zone %a)" Domain_name.pp name Domain_name.pp zone) ;
let t =
if N.mem zone visited then
(* we need to break the cycle if there's one domain pointing to NS in
another domain, and this other domain NS pointing to one domain. *)
(* if we lack glue here, we should query .. for NS again with the hope
to get some glue *)
Dns_cache.remove t zone
else
t
in
List.concat_map (function
| `NeedAddress (zone, ns) -> go t (N.add zone visited) addresses zone ns
| `NeedDnskey (zone, ips) -> [ zone, zone, [`K (Rr_map.K Dnskey)], ips, t ]
| `NeedDs (zone, ips) -> [ zone, zone, [`K (Rr_map.K Ds)], ips, t ]
| `HaveIPs (zone, ips) ->
(* qname minimisation: if we can, query minimal qname (and NS)
this is possible as long as we haven't received a negative reply on
the NS query -- that's why we have another Dns_cache.get NS below *)
let name, types =
if qname_minimisation then
let n = Domain_name.count_labels name
and z = Domain_name.count_labels zone
in
let n' =
if succ z < n then
Domain_name.drop_label_exn ~amount:(n - succ z) name
else
name
in
let name' =
match snd (Dns_cache.get t ts n' Ns) with
| Ok (`Entry _, _) -> n'
| _ -> name
in
name', if Domain_name.equal name' name then types else [ `K (Rr_map.K Ns) ]
else
name, types
in
[ zone, name, types, ips, t ]
| `NeedSignedNs (domain, ips) -> [ domain, domain, [ `K (Rr_map.K Ns) ], ips, t ])
(find_nearest_ns ip_proto dnssec ts t (Domain_name.raw name))
in
go t N.empty [typ] Domain_name.root name
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_or_cname t ts name typ in
match r with
| Error _ ->
Log.debug (fun m -> m "follow_cname: cache miss, need to query %a"
Domain_name.pp name);
`Query name, t
| Ok (`Alias (_, alias), r) ->
let acc' = Domain_name.Map.add name (Rr_map.singleton Cname (ttl, alias)) acc in
if Domain_name.Map.mem alias acc then begin
Log.warn (fun m -> m "follow_cname: cycle detected") ;
`Out (Rcode.NoError, is_signed r, acc', Name_rr_map.empty), t
end else begin
Log.debug (fun m -> m "follow_cname: alias to %a, follow again"
Domain_name.pp alias);
follow t acc' alias
end
| Ok (`Entry v, r) ->
let acc' = Domain_name.Map.add name Rr_map.(singleton typ v) acc in
Log.debug (fun m -> m "follow_cname: entry found, returning");
`Out (Rcode.NoError, is_signed r, acc', Name_rr_map.empty), t
| Ok (`No_domain res, r) ->
Log.debug (fun m -> m "follow_cname: nodom");
`Out (Rcode.NXDomain, is_signed r, acc, to_map res), t
| Ok (`No_data res, r) ->
Log.debug (fun m -> m "follow_cname: nodata");
`Out (Rcode.NoError, is_signed r, acc, to_map res), t
| Ok (`Serv_fail res, r) ->
Log.debug (fun m -> m "follow_cname: servfail") ;
`Out (Rcode.ServFail, is_signed r, acc, to_map res), t
in
let initial = Name_rr_map.singleton name Cname (ttl, alias) in
follow t initial alias
let signed_or_nonexisting ~dnssec t ts ty name r =
if dnssec then
Option.is_some (is_signed r) || nsec_no t ts ty name || nsec3_covering t ts ty name ||
upwards_ds_nonexisting t ts name
else
true
let ttl k = function
| Ok (`Entry v, _) -> Rr_map.ttl k v
| Ok ((`No_data (_, soa), _) | (`No_domain (_, soa), _) | (`Serv_fail (_, soa), _)) ->
soa.Soa.minimum
| Ok (`Alias (ttl, _), _) -> ttl
| Error _ -> 0l
let answer ~dnssec ~dnssec_ok t ts name (typ : Packet.Question.qtype) =
let packet _t _add ty rcode ~ttl ~rrsig answer authority =
let answer =
if dnssec_ok then
if Domain_name.Map.cardinal answer > 0 then
match rrsig with
| Some rrsig -> Name_rr_map.add name Rrsig (ttl, Rr_map.Rrsig_set.singleton rrsig) answer
| None -> answer
else
answer
else
answer
in
let authority =
if dnssec_ok then
if Domain_name.Map.cardinal authority = 1 then
let name, rr_map = Domain_name.Map.choose authority in
match Rr_map.find Soa rr_map with
| None -> authority
| Some _soa ->
let authority =
match rrsig with
| None -> authority
| Some rrsig ->
Name_rr_map.add name Rrsig (ttl, Rr_map.Rrsig_set.singleton rrsig) authority
in
match ty with
| None -> authority
| Some ty ->
match find_nsec t ts ty name, find_nsec3 t ts ty name with
| Some (name, (ttl, nsec), rank), _ ->
let authority = Name_rr_map.add name Nsec (ttl, nsec) authority in
(match is_signed rank with
| Some rrsig -> Name_rr_map.add name Rrsig (ttl, Rr_map.Rrsig_set.singleton rrsig) authority
| None -> authority)
| _, Some (name, ttl, nsec3, rank) ->
let authority = Name_rr_map.add name Nsec3 (ttl, nsec3) authority in
(match is_signed rank with
| Some rrsig -> Name_rr_map.add name Rrsig (ttl, Rr_map.Rrsig_set.singleton rrsig) authority
| None -> authority)
| None, _ -> authority
else
authority
else
authority
in
let data = (answer, authority) in
let flags =
let f = Packet.Flags.(add `Recursion_available (singleton `Recursion_desired)) in
if dnssec && match rrsig with Some _ -> true | None -> false then
Packet.Flags.add `Authentic_data f
else
f
(* XXX: we should look for a fixpoint here ;) *)
(* and additional, t = if add then additionals t ts answer else [], t *)
and data = match rcode with
| Rcode.NoError -> `Answer data
| x ->
let data = if Packet.Answer.is_empty data then None else Some data in
`Rcode_error (x, Opcode.Query, data)
in
flags, data, None
in
match typ with
| `Any ->
let t, r = Dns_cache.get_any t ts name in
let ttl = match r with
| Ok (`No_domain (_, soa), _) -> soa.Soa.minimum
| Ok (`Entries _rrs, _) -> 0l
| Error _ -> 0l
in
begin match r with
| Error _e ->
(* Log.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, r) ->
Log.debug (fun m -> m "no domain while looking up %a, query" pp_question (name, typ));
`Packet (packet t false None Rcode.NXDomain ~ttl ~rrsig:(is_signed r) Domain_name.Map.empty (to_map res)), t
| Ok (`Entries rr_map, r) ->
Log.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 None Rcode.NoError ~ttl ~rrsig:(is_signed r) 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
let ttl = ttl ty r in
match r with
| Error _e ->
(* Log.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, r) ->
if not (signed_or_nonexisting ~dnssec t ts ty name r) then `Query name, t else (
Log.debug (fun m -> m "no domain while looking up %a" pp_question (name, typ));
`Packet (packet t false (Some ty) Rcode.NXDomain ~ttl ~rrsig:(is_signed r) Domain_name.Map.empty (to_map res)), t)
| Ok (`No_data res, r) ->
if not (signed_or_nonexisting ~dnssec t ts ty name r) then `Query name, t else (
Log.debug (fun m -> m "no data while looking up %a" pp_question (name, typ));
`Packet (packet t false (Some ty) Rcode.NoError ~ttl ~rrsig:(is_signed r) Domain_name.Map.empty (to_map res)), t)
| Ok (`Serv_fail res, r) ->
if not (signed_or_nonexisting ~dnssec t ts ty name r) then `Query name, t else (
Log.debug (fun m -> m "serv fail while looking up %a" pp_question (name, typ));
`Packet (packet t false (Some ty) Rcode.ServFail ~ttl ~rrsig:None Domain_name.Map.empty (to_map res)), t)
| Ok (`Alias (ttl, alias), r) ->
if not (signed_or_nonexisting ~dnssec t ts ty name r) then `Query name, t else
begin
Log.debug (fun m -> m "alias while looking up %a" pp_question (name, typ));
match ty with
| Cname ->
let data = Name_rr_map.singleton name Cname (ttl, alias) in
`Packet (packet t false (Some ty) Rcode.NoError ~ttl ~rrsig:(is_signed r) data Domain_name.Map.empty), t
| ty ->
match follow_cname t ts ty ~name ttl ~alias with
| `Out (rcode, rrsig, an, au), t -> `Packet (packet t true (Some ty) rcode ~ttl ~rrsig an au), t
| `Query n, t -> `Query n, t
end
| Ok (`Entry v, r) ->
if not (signed_or_nonexisting ~dnssec t ts ty name r) then `Query name, t else
(Log.debug (fun m -> m "entry while looking up %a" pp_question (name, typ));
let data = Name_rr_map.singleton name ty v in
`Packet (packet t true (Some ty) Rcode.NoError ~ttl ~rrsig:(is_signed r) data Domain_name.Map.empty), t)
let pick_n rng n xs =
let l = List.length xs in
if n >= l then
xs
else
let rec pick amount bound =
if amount = 0 then
[]
else
let e = Randomconv.int ~bound rng in
let ips'' = pick (amount - 1) (bound - 1) in
e :: List.map (fun idx -> if idx < e then idx else succ idx) ips''
in
let idx = pick n l in
List.map (List.nth xs) idx
let handle_query t ~qname_minimisation ~dnssec ~dnssec_ok ~rng ip_proto ts (qname, qtype) =
match answer ~dnssec ~dnssec_ok t ts qname qtype with
| `Packet (flags, data, additional), t ->
Log.debug (fun m -> m "handle_query: reply %a (%a)" Domain_name.pp qname
Packet.Question.pp_qtype qtype);
`Reply (flags, data, additional), t
| `Query name, t ->
(* DS should be requested at the parent *)
let name', recover =
if Domain_name.count_labels name > 1 && qtype = `K (Rr_map.K Ds) then
let n' = Domain_name.drop_label_exn name in
n', fun n -> if Domain_name.equal n n' then name else n
else
name, Fun.id
in
let actions = resolve t ~qname_minimisation ~dnssec ip_proto ts name' qtype in
let up_to_three = pick_n rng 3 actions in
let ip1 = 4 - List.length up_to_three in
let ip2 = max 1 (3 - List.length up_to_three) in
let _i, queries, t' =
List.fold_left (fun (i, acc, _t) (zone, name'', types, ips, t) ->
let name'' = recover name'' in
let number_of_ips = if i = 0 then ip1 else ip2 in
let ips = pick_n rng number_of_ips ips in
Log.debug (fun m -> m "handle_query %a (%a) query %a, resolve zone %a query %a (%a), ips %a"
Domain_name.pp qname Packet.Question.pp_qtype qtype
Domain_name.pp name Domain_name.pp zone Domain_name.pp name''
Fmt.(list ~sep:(any ", ") Packet.Question.pp_qtype) types
Fmt.(list ~sep:(any ", ") Ipaddr.pp) ips);
let actions =
List.map (fun ip -> (zone, (name'', types), ip)) ips
in
succ i, acc @ actions, Some t)
(0, [], None) up_to_three
in
`Queries queries, Option.value ~default:t t'

25
unikernel/duniverse/ocaml-dns/resolver/dns_resolver_cache.mli Normal file
View file

@ -0,0 +1,25 @@
(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
open Dns
val pp_question : ([ `raw ] Domain_name.t * Packet.Question.qtype) Fmt.t
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 * Rrsig.t option * Name_rr_map.t * Name_rr_map.t
| `Query of [ `raw ] Domain_name.t ] * Dns_cache.t
val answer : dnssec:bool -> dnssec_ok:bool -> Dns_cache.t -> int64 -> [ `raw ] Domain_name.t -> Packet.Question.qtype ->
[ `Query of [ `raw ] Domain_name.t
| `Packet of Packet.Flags.t * Packet.reply * Name_rr_map.t option ] * Dns_cache.t
val resolve : Dns_cache.t -> qname_minimisation:bool -> dnssec:bool ->
[`Both | `Ipv4_only | `Ipv6_only] -> int64 -> [ `raw ] Domain_name.t ->
Packet.Question.qtype ->
([ `raw ] Domain_name.t * [ `raw ] Domain_name.t * Packet.Question.qtype list * Ipaddr.t list * Dns_cache.t) list
val handle_query : Dns_cache.t -> qname_minimisation:bool -> dnssec:bool -> dnssec_ok:bool ->
rng:(int -> string) -> [`Both | `Ipv4_only | `Ipv6_only ] ->
int64 ->
[ `raw ] Domain_name.t * Packet.Question.qtype ->
[ `Reply of Packet.Flags.t * Packet.reply * Name_rr_map.t option
| `Queries of ([ `raw ] Domain_name.t * ([ `raw ] Domain_name.t * Packet.Question.qtype list) * Ipaddr.t) list ] * Dns_cache.t

18
unikernel/duniverse/ocaml-dns/resolver/dns_resolver_metrics.ml Normal file
View file

@ -0,0 +1,18 @@
let resolver_stats =
let f = function
| `Error -> "error"
| `Queries -> "queries"
| `Blocked -> "blocked"
| `Clients -> "clients"
in
let src = Dns.counter_metrics ~f "dns-resolver" in
(fun r -> Metrics.add src (fun x -> x) (fun d -> d r))
let response_metric =
let store = ref (0L, 0L) in
let data dp =
store := (Int64.succ (fst !store), Int64.add dp (snd !store));
Metrics.Data.v [ Metrics.uint "mean response" (Duration.to_ms (Int64.div (snd !store) (fst !store))) ]
in
let src = Metrics.Src.v ~tags:Metrics.Tags.[] ~data "dns-resolver-timings" in
(fun dp -> Metrics.add src (fun x -> x) (fun d -> d dp))

3
unikernel/duniverse/ocaml-dns/resolver/dns_resolver_metrics.mli Normal file
View file

@ -0,0 +1,3 @@
val resolver_stats : [ `Blocked | `Clients | `Error | `Queries ] -> unit
val response_metric : int64 -> unit

82
unikernel/duniverse/ocaml-dns/resolver/dns_resolver_root.ml Normal file
View file

@ -0,0 +1,82 @@
(* (c) 2018 Hannes Mehnert, all rights reserved *)
open Dns
let root_servers =
List.map (fun (n, ip4, ip6) ->
Domain_name.(host_exn (of_string_exn n)),
Ipaddr.V4.of_string_exn ip4,
Ipaddr.V6.of_string_exn ip6)
[
"a.root-servers.net", "198.41.0.4", "2001:503:ba3e::2:30" ; (* VeriSign, Inc. *)
"b.root-servers.net", "170.247.170.2", "2801:1b8:10::b" ; (* University of Southern California (ISI) *)
"c.root-servers.net", "192.33.4.12", "2001:500:2::c" ; (* Cogent Communications *)
"d.root-servers.net", "199.7.91.13", "2001:500:2d::d" ; (* University of Maryland *)
"e.root-servers.net", "192.203.230.10", "2001:500:a8::e" ; (* NASA (Ames Research Center) *)
"f.root-servers.net", "192.5.5.241", "2001:500:2f::f" ; (* Internet Systems Consortium, Inc. *)
"g.root-servers.net", "192.112.36.4", "2001:500:12::d0d" ; (* US Department of Defense (NIC) *)
"h.root-servers.net", "198.97.190.53", "2001:500:1::53" ; (* US Army (Research Lab) *)
"i.root-servers.net", "192.36.148.17", "2001:7fe::53" ; (* Netnod *)
"j.root-servers.net", "192.58.128.30", "2001:503:c27::2:30" ; (* VeriSign, Inc. *)
"k.root-servers.net", "193.0.14.129", "2001:7fd::1" ; (* RIPE NCC *)
"l.root-servers.net", "199.7.83.42", "2001:500:9f::42" ; (* ICANN *)
"m.root-servers.net", "202.12.27.33", "2001:dc3::35" ; (* WIDE Project *)
]
let a_ttl = 3600000l
let ns_ttl = 518400l
let ns_records =
let ns =
let add_to_set set (name, _, _) = Domain_name.Host_set.add name set in
List.fold_left add_to_set Domain_name.Host_set.empty root_servers
in
(ns_ttl, ns)
let a_records =
List.map (fun (name, ip, _) ->
Domain_name.raw name, (a_ttl, Ipaddr.V4.Set.singleton ip))
root_servers
let aaaa_records =
List.map (fun (name, _, ip) ->
Domain_name.raw name, (a_ttl, Ipaddr.V6.Set.singleton ip))
root_servers
let ips protocol =
List.fold_left (fun acc (_, ip4, ip6) ->
match protocol with
| `Both -> Ipaddr.V4 ip4 :: Ipaddr.V6 ip6 :: acc
| `Ipv4_only -> Ipaddr.V4 ip4 :: acc
| `Ipv6_only -> Ipaddr.V6 ip6 :: acc)
[] root_servers
let reserved_zone_records =
let n = Domain_name.of_string_exn in
(* RFC 6761, avoid them to get out of here + multicast DNS 6762 *)
let zones =
Domain_name.Set.(add (n "local") (* multicast dns, RFC 6762 *)
(add (n "test") (add (n "invalid") (* RFC 6761 *)
(add (n "localhost") (* RFC 6761, draft let-localhost-be-localhost *)
empty))))
in
let local_net_name = "127.in-addr.arpa" in
Domain_name.Set.add (n local_net_name) zones
let stub_soa s =
let nameserver = Domain_name.prepend_label_exn s "ns"
and hostmaster = Domain_name.prepend_label_exn s "hostmaster"
in
{ Soa.nameserver ; hostmaster ; serial = 0l ; refresh = 300l ; retry = 300l ;
expiry = 300l ; minimum = 300l }
let reserved_zones =
let inv s = Rr_map.(B (Soa, stub_soa s)) in
Domain_name.Set.fold (fun n acc -> (n, inv n) :: acc) reserved_zone_records []
let reserved =
Domain_name.Set.fold (fun name trie ->
Dns_trie.insert name Rr_map.Soa (stub_soa name) trie)
reserved_zone_records Dns_trie.empty
let root_servers =
List.map (fun (n, ip4, ip6) -> Domain_name.raw n, ip4, ip6) root_servers

27
unikernel/duniverse/ocaml-dns/resolver/dns_resolver_root.mli Normal file
View file

@ -0,0 +1,27 @@
(* (c) 2018 Hannes Mehnert, all rights reserved *)
open Dns
val root_servers : ([ `raw ] Domain_name.t * Ipaddr.V4.t * Ipaddr.V6.t) list
(** [root_servers] are the root servers. *)
val ns_records : (int32 * Domain_name.Host_set.t)
(** [ns_records] is the root nameserver binding. *)
val a_records : ([ `raw ] Domain_name.t * (int32 * Ipaddr.V4.Set.t)) list
(** [a_records] is a list of names and bindings (A records) for the root
servers. *)
val aaaa_records : ([ `raw ] Domain_name.t * (int32 * Ipaddr.V6.Set.t)) list
(** [aaaa_records] is a list of names and bindings (AAAA records) for the root
servers. *)
val ips : [ `Both | `Ipv4_only | `Ipv6_only ] -> Ipaddr.t list
(** [ips ip_proto] is a list of ip addresses of the root servers. *)
val reserved_zones : ([ `raw ] Domain_name.t * Rr_map.b) list
(** [reserved_zones] is a list of names and bindings for reserved zones
specified by RFCs (private network address ranges, private domains) *)
val reserved : Dns_trie.t
(** [reserved] is a trie with all [reserved_zones]. *)

3
unikernel/duniverse/ocaml-dns/resolver/dns_resolver_shared.ml Normal file
View file

@ -0,0 +1,3 @@
module Root = Dns_resolver_root
module Metrics = Dns_resolver_metrics
module Block = Dns_block

281
unikernel/duniverse/ocaml-dns/resolver/dns_resolver_utils.ml Normal file
View file

@ -0,0 +1,281 @@
(* (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)

16
unikernel/duniverse/ocaml-dns/resolver/dns_resolver_utils.mli Normal file
View file

@ -0,0 +1,16 @@
(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
open Dns
type e = E : 'a Rr_map.key * 'a Dns_cache.entry -> e
val scrub : [ `raw ] Domain_name.t -> signed:bool -> Packet.Question.qtype ->
Packet.t ->
(([ `raw ] Domain_name.t * e * Dns_cache.rank) list, Rcode.t) result
(** [scrub bailiwick packet] returns a list of entries to-be-added to the
cache. This respects only in-bailiwick resources records, and qualifies the
[packet]. The purpose is to avoid cache poisoning by not accepting all
resource records. *)
val invalid_soa : [ `raw ] Domain_name.t -> Soa.t
(** [invalid_soa name] returns a stub SOA for [name]. *)

15
unikernel/duniverse/ocaml-dns/resolver/dune Normal file
View file

@ -0,0 +1,15 @@
(library
(name dns_resolver)
(public_name dns-resolver)
(instrumentation
(backend bisect_ppx))
(wrapped false)
(modules dns_resolver dns_resolver_utils dns_resolver_cache)
(libraries dns dns.cache dns-server lru duration randomconv dnssec logs dns_resolver_shared))
(library
(name dns_resolver_shared)
(public_name dns-resolver.shared)
(wrapped false)
(modules dns_resolver_shared dns_resolver_root dns_block dns_resolver_metrics)
(libraries dns dns-server metrics))