unikernel/duniverse/ocaml-dns/resolver/dns_resolver_cache.ml

@@ -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'