Skip to content

Commit

Permalink
Merge pull request #325 from hannesm/resolver-dnssec-optional
Browse files Browse the repository at this point in the history 
resolver: do dnssec validation as an option
  • Loading branch information
@reynir
reynir authored Nov 29, 2022
2 parents 710ad14 + 24fe68c commit b1ab0f5
Show file tree
Hide file tree
Showing 5 changed files with 96 additions and 86 deletions.
149 changes: 78 additions & 71 deletions resolver/dns_resolver.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -34,14 +34,15 @@ let retry_interval = Duration.of_ms 500

type t = {
ip_protocol : [ `Both | `Ipv4_only | `Ipv6_only ];
dnssec : bool ;
rng : int -> Cstruct.t ;
primary : Dns_server.Primary.s ;
cache : Dns_cache.t ;
transit : awaiting QM.t ;
queried : awaiting list QM.t ;
}

let create ?(cache_size = 10000) ?(ip_protocol = `Both) now rng primary =
let create ?(cache_size = 10000) ?(ip_protocol = `Both) ?(dnssec = true) now rng primary =
let cache = Dns_cache.empty cache_size in
let cache =
List.fold_left (fun cache (name, b) ->
Expand All @@ -67,7 +68,7 @@ let create ?(cache_size = 10000) ?(ip_protocol = `Both) now rng primary =
Domain_name.root Ds Dns_cache.Additional
(`Entry (Int32.max_int, Dnssec.root_ds))
in
{ ip_protocol ; rng ; cache ; primary ; transit = QM.empty ; queried = QM.empty }
{ ip_protocol ; dnssec ; rng ; cache ; primary ; transit = QM.empty ; queried = QM.empty }

let pick rng = function
| [] -> None
Expand Down Expand Up @@ -104,7 +105,7 @@ let maybe_query ?recursion_desired t ts await retry ip name typ =
None, t
else
(* TODO here we may want to use the _default protocol_ (and edns settings) instead of `Udp *)
let edns = Some (Edns.create ~dnssec_ok:true ()) in
let edns = Some (Edns.create ~dnssec_ok:t.dnssec ()) in
let t, packet = build_query ?recursion_desired t ts `Udp k retry await.zone edns ip in
let t = { t with queried = QM.add k [await] t.queried } in
Logs.debug (fun m -> m "maybe_query: query %a %a" Ipaddr.pp ip pp_key k) ;
Expand Down Expand Up @@ -138,7 +139,7 @@ let handle_query ?(retry = 0) t ts awaiting =
pp_key awaiting.question Ipaddr.pp awaiting.ip awaiting.port);
`Nothing, t
end else
let r, cache = Dns_resolver_cache.handle_query t.cache ~rng:t.rng t.ip_protocol ts awaiting.question in
let r, cache = Dns_resolver_cache.handle_query t.cache ~dnssec:t.dnssec ~rng:t.rng t.ip_protocol ts awaiting.question in
let t = { t with cache } in
match r with
| `Query _ when awaiting.retry >= 30 ->
Expand Down Expand Up @@ -255,13 +256,13 @@ let resolve t ts proto sender sport req =
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; } in
begin match handle_query t ts awaiting with
| `Answer pkt, t ->
Logs.info (fun m -> m "answer %a" Packet.Question.pp req.question) ;
Logs.debug (fun m -> m "answer %a" Packet.Question.pp req.question) ;
t, [ (proto, sender, sport, pkt) ], []
| `Nothing, t ->
Logs.info (fun m -> m "nothing %a" Packet.Question.pp req.question) ;
Logs.debug (fun m -> m "nothing %a" Packet.Question.pp req.question) ;
t, [], [] (* TODO: send a reply!? *)
| `Query pkts, t ->
Logs.info (fun m -> m "query %d %a" (List.length pkts) Packet.Question.pp req.question) ;
Logs.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
| _ ->
Expand All @@ -279,7 +280,7 @@ let handle_reply t now ts proto sender packet reply =
| `Rcode_error (Rcode.NXDomain, Opcode.Query, _), Some qtype
| `Rcode_error (Rcode.ServFail, Opcode.Query, _), Some qtype ->
begin
Logs.info (fun m -> m "handling reply to %a" Packet.Question.pp packet.question);
Logs.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 in
Expand All @@ -288,65 +289,71 @@ let handle_reply t now ts proto sender packet reply =
| None -> Ok (t, [], [])
| Some (zone, edns) ->
(* (b) DNSSec verification of RRs *)
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 packet.data with
| `Answer (a, _) -> Name_rr_map.find zone Rr_map.Dnskey a
| _ -> None
in
let ds_set =
(* RFC 4509 - drop SHA1 DS if SHA2 DS are present *)
if Rr_map.Ds_set.exists (fun ds ->
match ds.Ds.digest_type with
| Ds.SHA256 | Ds.SHA384 -> true | _ -> false)
ds_set
then
Rr_map.Ds_set.filter
(fun ds -> not (ds.Ds.digest_type = SHA1))
ds_set
else
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 ->
Logs.warn (fun m -> m "couldn't validate DS (for %a): %s"
Domain_name.pp zone msg);
acc)
ds_set Rr_map.Dnskey_set.empty)
keys
let* t, packet, signed =
if t.dnssec 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 packet.data with
| `Answer (a, _) -> Name_rr_map.find zone Rr_map.Dnskey a
| _ -> None
in
let ds_set =
(* RFC 4509 - drop SHA1 DS if SHA2 DS are present *)
if Rr_map.Ds_set.exists (fun ds ->
match ds.Ds.digest_type with
| Ds.SHA256 | Ds.SHA384 -> true | _ -> false)
ds_set
then
Rr_map.Ds_set.filter
(fun ds -> not (ds.Ds.digest_type = SHA1))
ds_set
else
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 ->
Logs.warn (fun m -> m "couldn't validate DS (for %a): %s"
Domain_name.pp zone msg);
acc)
ds_set Rr_map.Dnskey_set.empty)
keys
| _ ->
Logs.warn (fun m -> m "no DS in cache for %a" Domain_name.pp zone);
None
end
| _ ->
Logs.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
| _ ->
Logs.warn (fun m -> m "no DNSKEYS in cache for %a" Domain_name.pp zone);
None
in
let* packet, signed =
Option.fold
~none:(Ok (packet, false))
~some:(fun dnskeys ->
let* packet =
Result.map_error (fun (`Msg msg) ->
Logs.err (fun m -> m "error %s verifying reply %a"
msg Packet.pp_reply reply))
(Dnssec.verify_packet now dnskeys packet)
in
Ok (packet, true))
dnskeys
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
| _ ->
Logs.warn (fun m -> m "no DNSKEYS in cache for %a" Domain_name.pp zone);
None
in
let* packet, signed =
Option.fold
~none:(Ok (packet, false))
~some:(fun dnskeys ->
let* packet =
Result.map_error (fun (`Msg msg) ->
Logs.err (fun m -> m "error %s verifying reply %a"
msg Packet.pp_reply reply))
(Dnssec.verify_packet now dnskeys packet)
in
Ok (packet, true))
dnskeys
in
Ok (t, packet, signed)
else
Ok (t, packet, false)
in
(* (c) now we scrub and either *)
match scrub_it t.cache proto zone edns ts ~signed qtype packet with
Expand Down Expand Up @@ -464,14 +471,14 @@ let handle_buf t now ts query proto sender sport buf =
in
t, answer, []
| Ok res ->
Logs.info (fun m -> m "reacting to packet from %a:%d"
Ipaddr.pp sender sport) ;
Logs.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 res reply with
| Ok a ->
Logs.info (fun m -> m "handled reply %a:%d"
Logs.debug (fun m -> m "handled reply %a:%d"
Ipaddr.pp sender sport) ;
a
| Error () -> t, [], []
Expand All @@ -480,10 +487,10 @@ let handle_buf t now ts query proto sender sport buf =
begin
match handle_primary t.primary now ts proto sender sport res req buf with
| `Reply (primary, pkt) ->
Logs.info (fun m -> m "handled primary %a:%d" Ipaddr.pp sender sport) ;
Logs.debug (fun m -> m "handled primary %a:%d" Ipaddr.pp sender sport) ;
{ t with primary }, [ proto, sender, sport, pkt ], []
| `Delegation dele ->
Logs.info (fun m -> m "handled delegation %a:%d" Ipaddr.pp sender sport) ;
Logs.debug (fun m -> m "handled delegation %a:%d" Ipaddr.pp sender sport) ;
handle_delegation t ts proto sender sport res dele
| `None ->
Logs.info (fun m -> m "resolving %a:%d" Ipaddr.pp sender sport) ;
Expand Down
13 changes: 8 additions & 5 deletions resolver/dns_resolver.mli
View file
Original file line number Diff line number Diff line change
Expand Up @@ -5,12 +5,15 @@ type t

val create : ?cache_size:int ->
?ip_protocol:[ `Both | `Ipv4_only | `Ipv6_only ] ->
?dnssec:bool ->
int64 -> (int -> Cstruct.t) -> Dns_server.Primary.s -> t
(** [create ~cache_size ~ip_protocol 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. *)
(** [create ~cache_size ~ip_protocol ~dnssec 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 [dnssec] is
provided and [false] (defaults to [true]), DNSSec validation will be
disabled. *)

val handle_buf : t -> Ptime.t -> int64 -> bool -> Dns.proto -> Ipaddr.t ->
int -> Cstruct.t ->
Expand Down
14 changes: 7 additions & 7 deletions resolver/dns_resolver_cache.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -52,7 +52,7 @@ let nsec3_covering t ts name =
in
up name

let find_nearest_ns rng ip_proto ts t name =
let find_nearest_ns rng ip_proto dnssec ts t name =
let pick = function
| [] -> None
| [ x ] -> Some x
Expand Down Expand Up @@ -91,7 +91,7 @@ let find_nearest_ns rng ip_proto ts t name =
| `Ipv6_only -> ip6s
in
let have_ip_or_dnskey name ip =
if not (find_dnskey name) then
if dnssec && not (find_dnskey name) then
`NeedDnskey (name, ip)
else
`HaveIP (name, ip)
Expand All @@ -110,7 +110,7 @@ let find_nearest_ns rng ip_proto ts t name =
| None ->
(* Logs.warn (fun m -> m "go no NS for %a" Domain_name.pp nam); *)
or_root go nam
| Some _ when not (need_to_query_for_ds nam) ->
| Some _ when dnssec && not (need_to_query_for_ds nam) ->
or_root go nam
| Some ns ->
let host = Domain_name.raw ns in
Expand All @@ -134,7 +134,7 @@ let find_nearest_ns rng ip_proto ts t name =
in
go name

let resolve t ~rng ip_proto ts name typ =
let resolve t ~dnssec ~rng 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)]
Expand All @@ -152,7 +152,7 @@ let resolve t ~rng ip_proto ts name typ =
*)
let rec go t types name =
Logs.debug (fun m -> m "go %a" Domain_name.pp name) ;
match find_nearest_ns rng ip_proto ts t (Domain_name.raw name) with
match find_nearest_ns rng ip_proto dnssec ts t (Domain_name.raw name) with
| `NeedAddress ns -> go t addresses ns
| `NeedDnskey (zone, ip) -> zone, zone, [`K (Rr_map.K Dnskey)], ip, t
| `HaveIP (zone, ip) -> zone, name, types, ip, t
Expand Down Expand Up @@ -269,7 +269,7 @@ let answer t ts name typ =
let data = Name_rr_map.singleton name ty v in
`Packet (packet t true Rcode.NoError ~signed:(is_signed r) data Domain_name.Map.empty), t

let handle_query t ~rng ip_proto ts (qname, qtype) =
let handle_query t ~dnssec ~rng ip_proto ts (qname, qtype) =
Logs.info (fun m -> m "handle query %a (%a)"
Domain_name.pp qname Packet.Question.pp_qtype qtype);
match answer t ts qname qtype with
Expand All @@ -286,7 +286,7 @@ let handle_query t ~rng ip_proto ts (qname, qtype) =
else
name, Fun.id
in
let zone, name'', types, ip, t = resolve t ~rng ip_proto ts name' qtype in
let zone, name'', types, ip, t = resolve t ~dnssec ~rng ip_proto ts name' qtype in
let name'' = recover name'' in
Logs.info (fun m -> m "resolve returned zone %a query %a (%a), ip %a"
Domain_name.pp zone Domain_name.pp name''
Expand Down
4 changes: 2 additions & 2 deletions resolver/dns_resolver_cache.mli
View file
Original file line number Diff line number Diff line change
Expand Up @@ -12,10 +12,10 @@ val answer : Dns_cache.t -> int64 -> [ `raw ] Domain_name.t -> Packet.Question.q
[ `Query of [ `raw ] Domain_name.t
| `Packet of Packet.Flags.t * Packet.reply ] * Dns_cache.t

val resolve : Dns_cache.t -> rng:(int -> Cstruct.t) -> [`Both | `Ipv4_only | `Ipv6_only] -> int64 -> [ `raw ] Domain_name.t ->
val resolve : Dns_cache.t -> dnssec:bool -> rng:(int -> Cstruct.t) -> [`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 * Dns_cache.t

val handle_query : Dns_cache.t -> rng:(int -> Cstruct.t) ->
val handle_query : Dns_cache.t -> dnssec:bool -> rng:(int -> Cstruct.t) ->
[`Both | `Ipv4_only | `Ipv6_only ] ->
int64 ->
[ `raw ] Domain_name.t * Packet.Question.qtype ->
Expand Down
2 changes: 1 addition & 1 deletion test/resolver.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -910,7 +910,7 @@ let handle_query_with_cname () =
in
Alcotest.check handle_query_res "..."
(`Query (name "reynir.dk", (name "reynir.dk", [ `K (Rr_map.K A) ]), ip "127.0.0.1"), cache)
(Dns_resolver_cache.handle_query cache ~rng `Ipv4_only 0L (name "www.reynir.dk", `K (Rr_map.K A)))
(Dns_resolver_cache.handle_query cache ~dnssec:true ~rng `Ipv4_only 0L (name "www.reynir.dk", `K (Rr_map.K A)))

let handle_query_tests = [
"cname", `Quick, handle_query_with_cname ;
Expand Down

0 comments on commit b1ab0f5

Please sign in to comment.