unikernel/duniverse/ocaml-dns/cache/dns_cache.ml

@@ -0,0 +1,378 @@
+(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
+
+open Dns
+
+let src = Logs.Src.create "dns_cache" ~doc:"DNS cache"
+module Log = (val Logs.src_log src : Logs.LOG)
+
+type rank =
+  | ZoneFile
+  | ZoneTransfer
+  | AuthoritativeAnswer of Rrsig.t option
+  | AuthoritativeAuthority of Rrsig.t option
+  | ZoneGlue
+  | NonAuthoritativeAnswer
+  | Additional
+
+let compare_rrsig_opt a b =
+  match a, b with
+  | None, None -> 0
+  | Some _, None -> 1
+  | None, Some _ -> -1
+  | Some a, Some b ->
+    Ptime.compare a.Rrsig.signature_expiration b.Rrsig.signature_expiration
+
+let compare_rank a b = match a, b with
+  | ZoneFile, ZoneFile -> 0
+  | ZoneFile, _ -> 1
+  | _, ZoneFile -> -1
+  | ZoneTransfer, ZoneTransfer -> 0
+  | ZoneTransfer, _ -> 1
+  | _, ZoneTransfer -> -1
+  | AuthoritativeAnswer signed, AuthoritativeAnswer signed' ->
+    compare_rrsig_opt signed signed'
+  | AuthoritativeAnswer _, _ -> 1
+  | _, AuthoritativeAnswer _ -> -1
+  | AuthoritativeAuthority signed, AuthoritativeAuthority signed' ->
+    compare_rrsig_opt signed signed'
+  | AuthoritativeAuthority _, _ -> 1
+  | _, AuthoritativeAuthority _ -> -1
+  | ZoneGlue, ZoneGlue -> 0
+  | ZoneGlue, _ -> 1
+  | _, ZoneGlue -> -1
+  | NonAuthoritativeAnswer, NonAuthoritativeAnswer -> 0
+  | NonAuthoritativeAnswer, _ -> 1
+  | _, NonAuthoritativeAnswer -> -1
+  | Additional, Additional -> 0
+
+let pp_rank ppf = function
+  | ZoneFile -> Fmt.string ppf "zone file data"
+  | ZoneTransfer -> Fmt.string ppf "zone transfer data"
+  | AuthoritativeAnswer signed ->
+    Fmt.pf ppf "authoritative answer data (signed: %a)"
+      Fmt.(option ~none:(any "no") Rrsig.pp) signed
+  | AuthoritativeAuthority signed ->
+    Fmt.pf ppf "authoritative authority data (signed: %a)"
+      Fmt.(option ~none:(any "no") Rrsig.pp) signed
+  | ZoneGlue -> Fmt.string ppf "zone file glue"
+  | NonAuthoritativeAnswer -> Fmt.string ppf "non-authoritative answer"
+  | Additional -> Fmt.string ppf "additional data"
+
+type 'a entry = [
+  | `Entry of 'a
+  | `No_data of [ `raw ] Domain_name.t * Soa.t
+  | `No_domain of [ `raw ] Domain_name.t * Soa.t
+  | `Serv_fail of [ `raw ] Domain_name.t * Soa.t
+]
+
+module RRMap = Map.Make(struct
+    type t = Rr_map.k
+    let compare = Rr_map.comparek
+  end)
+
+module Entry = struct
+  type meta = int64 * rank
+  let pp_meta ppf (ts, rank) =
+    Fmt.pf ppf "%a created %Lu" pp_rank rank ts
+
+  type rr_map_entry =
+    | Entry of Rr_map.b
+    | No_data of [ `raw ] Domain_name.t * Soa.t
+    | Serv_fail of [ `raw ] Domain_name.t * Soa.t
+  let pp_map_entry ppf entry = match entry with
+    | Entry b -> Fmt.pf ppf "entry %a" Rr_map.pp_b b
+    | No_data (name, soa) -> Fmt.pf ppf "no data %a SOA %a" Domain_name.pp name Soa.pp soa
+    | Serv_fail (name, soa) -> Fmt.pf ppf "server fail %a SOA %a" Domain_name.pp name Soa.pp soa
+  let to_entry : type a. a Rr_map.key -> rr_map_entry -> a entry = fun typ r -> match r with
+    | Entry (B (k, v)) -> begin match Rr_map.K.compare typ k with Gmap.Order.Eq -> `Entry v | _ -> assert false end
+    | No_data (name, soa) -> `No_data (name, soa)
+    | Serv_fail (name, soa) -> `Serv_fail (name, soa)
+  let of_entry typ = function
+    | `Entry v -> Entry (B (typ, v))
+    | `No_data (name, soa) -> No_data (name, soa)
+    | `Serv_fail (name, soa) -> Serv_fail (name, soa)
+    | _ -> assert false
+
+  type t =
+    | No_domain of meta * [ `raw ] Domain_name.t * Soa.t
+    | Rr_map of (meta * rr_map_entry) RRMap.t
+
+  (* Part of the LRU.Weighted interface *)
+  let weight = function
+    | No_domain _ -> 1
+    | Rr_map tm -> RRMap.cardinal tm
+
+  let pp_entry ppf (meta, entry) = Fmt.pf ppf "e (%a) %a" pp_meta meta pp_map_entry entry
+
+  let pp ppf = function
+    | No_domain (meta, name, soa) ->
+      Fmt.pf ppf "no domain (%a) %a SOA %a" pp_meta meta Domain_name.pp name Soa.pp soa
+    | Rr_map rr ->
+      Fmt.pf ppf "entries: %a"
+        Fmt.(list ~sep:(any ";@,") (pair Rr_map.ppk pp_entry))
+        (RRMap.bindings rr)
+end
+
+module Key = struct
+  type t = [ `raw ] Domain_name.t
+  let compare = Domain_name.compare
+end
+
+module LRU = Lru.F.Make(Key)(Entry)
+
+type t = LRU.t
+
+let metrics =
+  let f = function
+    | `Lookup -> "lookups"
+    | `Hit -> "hits"
+    | `Miss -> "misses"
+    | `Drop -> "drops"
+    | `Insert -> "insertions"
+  in
+  let incr, get = create_counter ~f in
+  let data (cache, thing) =
+    incr thing;
+    Metrics.Data.v
+      (Metrics.uint "size" (LRU.size cache) ::
+       Metrics.uint "weight" (LRU.weight cache) ::
+       Metrics.uint "capacity" (LRU.capacity cache) ::
+       get ())
+  in
+  let src = Metrics.Src.v ~tags:Metrics.Tags.[] ~data "dns-cache" in
+  (fun cache r -> Metrics.add src (fun x -> x) (fun d -> d (cache, r)))
+
+let empty = LRU.empty
+
+let size = LRU.size
+
+let capacity = LRU.capacity
+
+let pp = LRU.pp Fmt.(pair ~sep:(any ": ") Domain_name.pp Entry.pp)
+
+module N = Domain_name.Set
+
+let compute_updated_ttl ~created ~now ttl =
+  Int32.sub ttl (Int32.of_int (Duration.to_sec (Int64.sub now created)))
+
+let pp_entry key ppf entry =
+  let pp_ns ppf (name, soa) = Fmt.pf ppf "%a SOA %a" Domain_name.pp name Soa.pp soa in
+  match entry with
+  | `Entry v -> Fmt.pf ppf "entry %a" Rr_map.pp_b (B (key, v))
+  | `No_data ns -> Fmt.(append (any "no data ") pp_ns) ppf ns
+  | `No_domain ns -> Fmt.(append (any "no domain ") pp_ns) ppf ns
+  | `Serv_fail ns -> Fmt.(append (any "serv fail ") pp_ns) ppf ns
+
+let get_ttl k = function
+  | `Entry v -> Rr_map.ttl k v
+  | `No_data (_, soa) -> soa.Soa.minimum
+  | `No_domain (_, soa) -> soa.Soa.minimum
+  | `Serv_fail (_, soa) -> soa.Soa.minimum
+
+let with_ttl : type a . a Rr_map.key -> int32 -> a entry -> a entry = fun k ttl r -> match r with
+  | `Entry v ->
+    let v' = Rr_map.with_ttl k v ttl in
+    `Entry v'
+  | `No_data (name, soa) -> `No_data (name, { soa with Soa.minimum = ttl })
+  | `No_domain (name, soa) -> `No_domain (name, { soa with Soa.minimum = ttl })
+  | `Serv_fail (name, soa) -> `Serv_fail (name, { soa with Soa.minimum = ttl })
+
+let rec no_dom_upwards cache name =
+  if Domain_name.count_labels name > 1 then
+    let name' = Domain_name.drop_label_exn name in
+    match LRU.find name' cache with
+    | None -> no_dom_upwards cache name'
+    | Some No_domain (meta, name, soa) -> None, Ok (meta, `No_domain (name, soa))
+    | Some _ -> None, Error `Cache_miss
+  else
+    None, Error `Cache_miss
+
+let find cache name query_type =
+  match LRU.find name cache with
+  | None -> no_dom_upwards cache name
+  | Some No_domain (meta, name, soa) -> None, Ok (meta, `No_domain (name, soa))
+  | Some Rr_map resource_records ->
+    Some resource_records,
+    match RRMap.find_opt (K query_type) resource_records with
+    | Some (meta, entry) -> Ok (meta, Entry.to_entry query_type entry)
+    | None -> Error `Cache_miss
+
+let insert cache ?map ts name query_type rank entry =
+  let meta = ts, rank in
+  let cache = match entry with
+    | `No_domain (name', soa) -> LRU.add name (No_domain (meta, name', soa)) cache
+    | `Entry _ | `No_data _ | `Serv_fail _ ->
+      let map = match map with None -> RRMap.empty | Some x -> x in
+      let map' = RRMap.add (K query_type) (meta, Entry.of_entry query_type entry) map in
+      LRU.add name (Rr_map map') cache
+  in
+  (* Make sure we are within memory bounds *)
+  LRU.trim cache
+
+let update_ttl typ entry ~created ~now =
+  let ttl = get_ttl typ entry in
+  let updated_ttl = compute_updated_ttl ~created ~now ttl in
+  if updated_ttl < 0l then Error `Cache_drop else Ok (with_ttl typ updated_ttl entry)
+
+let get cache ts name query_type =
+  metrics cache `Lookup;
+  match snd (find cache name query_type) with
+  | Error e -> metrics cache `Miss; cache, Error e
+  | Ok ((created, rank), entry) ->
+    match update_ttl query_type entry ~created ~now:ts with
+    | Ok entry' -> metrics cache `Hit; LRU.promote name cache, Ok (entry', rank)
+    | Error e -> metrics cache `Drop; cache, Error e
+
+let find_any cache name =
+  match LRU.find name cache with
+  | None -> Error `Cache_miss
+  | Some No_domain (meta, name, soa) -> Ok (`No_domain (meta, name, soa))
+  | Some Rr_map rrs -> Ok (`Entries rrs)
+
+let get_any cache ts name =
+  metrics cache `Lookup;
+  match find_any cache name with
+  | Error e -> metrics cache `Miss; cache, Error e
+  | Ok r ->
+    let ttl created curr =
+      let ttl = compute_updated_ttl ~created ~now:ts curr in
+      if ttl < 0l then Error `Cache_drop else Ok ttl
+    in
+    LRU.promote name cache,
+    match r with
+    | `No_domain ((created, rank), name, soa) ->
+      begin match ttl created soa.Soa.minimum with
+        | Error _ as e -> metrics cache `Drop; e
+        | Ok minimum ->
+          metrics cache `Hit;
+          Ok (`No_domain (name, { soa with Soa.minimum }), rank)
+      end
+    | `Entries rrs ->
+      let rrs, r =
+        RRMap.fold (fun _k ((created, rank), v) (acc, r) ->
+            match v with
+            | Entry.Entry B (k, v) ->
+              begin match ttl created (Rr_map.ttl k v) with
+                | Ok ttl ->
+                  let v' = Rr_map.with_ttl k v ttl in
+                  Rr_map.add k v' acc, rank
+                | Error _ -> acc, r
+              end
+            | _ -> acc, r) rrs (Rr_map.empty, Additional)
+      in
+      match Rr_map.is_empty rrs with
+      | true -> metrics cache `Drop; Error `Cache_drop
+      | false -> metrics cache `Hit; Ok (`Entries rrs, r)
+
+let get_or_cname : type a . t -> int64 -> [`raw] Domain_name.t -> a Rr_map.key ->
+  t * ([ a entry | `Alias of int32 * [`raw] Domain_name.t] * rank,
+       [ `Cache_drop | `Cache_miss ]) result =
+  fun cache ts name query_type ->
+  metrics cache `Lookup;
+  let map_result : _ -> t * ([ a entry | `Alias of int32 * [`raw] Domain_name.t] * rank, [ `Cache_drop | `Cache_miss ]) result = function
+    | Error e -> metrics cache `Miss; cache, Error e
+    | Ok ((created, rank), entry) ->
+      match update_ttl query_type entry ~created ~now:ts with
+      | Ok entry' -> metrics cache `Hit; LRU.promote name cache, Ok ((entry', rank) :> [ _ entry | `Alias of int32 * [`raw] Domain_name.t ] * rank)
+      | Error e -> metrics cache `Drop; cache, Error e
+  in
+  match find cache name query_type with
+  | Some map, r ->
+    begin match RRMap.find_opt (K Cname) map with
+      | Some ((created, rank), Entry.Entry (B (Cname, (ttl, name)))) ->
+        let ttl = compute_updated_ttl ~created ~now:ts ttl in
+        if ttl < 0l then
+          map_result r
+        else begin
+          metrics cache `Hit;
+          LRU.promote name cache, Ok (`Alias (ttl, name), rank)
+        end
+      | _ -> map_result r
+    end
+  | _, e -> map_result e
+
+let get_nsec3 cache ts name =
+  metrics cache `Lookup;
+  let zone_labels = Domain_name.count_labels name in
+  let nsec3_rrs =
+    LRU.fold (fun ename entry acc ->
+        if
+          Domain_name.is_subdomain ~domain:name ~subdomain:ename &&
+          Domain_name.count_labels ename - 1 = zone_labels
+        then
+          match entry with
+          | Rr_map rrs ->
+            begin
+            match RRMap.find_opt (K Nsec3) rrs with
+              | Some ((created, r), (Entry (B (Nsec3, v)) as e)) ->
+                begin match update_ttl Nsec3 (Entry.to_entry Nsec3 e) ~created ~now:ts with
+                  | Ok `Entry (ttl, _) -> (ename, ttl, snd v, r) :: acc
+                  | Ok _ -> acc
+                  | Error _ -> acc
+                end
+              | _ -> acc
+          end
+          | _ -> acc
+        else
+          acc)
+      [] cache
+  in
+  match nsec3_rrs with
+  | [] ->
+    metrics cache `Miss;
+    cache, Error `Cache_miss
+  | xs ->
+    metrics cache `Hit;
+    List.fold_right LRU.promote (List.map (fun (a, _, _, _) -> a) xs) cache,
+    Ok xs
+
+(* XXX: we may want to define a minimum as well (5 minutes? 30 minutes?
+   use SOA expiry?) MS used to use 24 hours in internet explorer
+
+from RFC1034 on this topic:
+The idea is that if cached data is known to come from a particular zone,
+and if an authoritative copy of the zone's SOA is obtained, and if the
+zone's SERIAL has not changed since the data was cached, then the TTL of
+the cached data can be reset to the zone MINIMUM value if it is smaller.
+This usage is mentioned for planning purposes only, and is not
+recommended as yet.
+
+and 2308, Sec 4:
+   Despite being the original defined meaning, the first of these, the
+   minimum TTL value of all RRs in a zone, has never in practice been
+   used and is hereby deprecated.
+
+and 1035 6.2:
+   The MINIMUM value in the SOA should be used to set a floor on the TTL of data
+   distributed from a zone.  This floor function should be done when the data is
+   copied into a response.  This will allow future dynamic update protocols to
+   change the SOA MINIMUM field without ambiguous semantics.
+*)
+(* according to RFC1035, section 7.3, a TTL of a week is a good
+   maximum value! *)
+let week = Int32.of_int Duration.(to_sec (of_day 7))
+
+let clip_ttl_to_week query_type entry =
+  let ttl = get_ttl query_type entry in
+  if ttl < week then entry else with_ttl query_type week entry
+
+let pp_query ppf (name, query_type) =
+  Fmt.pf ppf "%a (%a)" Domain_name.pp name Packet.Question.pp_qtype query_type
+
+let set cache ts name query_type rank entry =
+  let entry' = clip_ttl_to_week query_type entry in
+  let cache' map = insert cache ?map ts name query_type rank entry' in
+  match find cache name query_type with
+  | map, Error _ ->
+    Log.debug (fun m -> m "set: %a nothing found, adding: %a"
+                   pp_query (name, `K (K query_type)) (pp_entry query_type) entry');
+    metrics cache `Insert; cache' map
+  | map, Ok ((created, rank'), entry) ->
+    Log.debug (fun m -> m "set: %a found rank %a insert rank %a: %d"
+                   pp_query (name, `K (K query_type)) pp_rank rank' pp_rank rank (compare_rank rank' rank));
+    match update_ttl query_type entry ~created ~now:ts, compare_rank rank' rank with
+    | Ok _, 1 -> cache
+    | _ -> metrics cache `Insert; cache' map
+
+let remove cache name =
+  LRU.remove name cache

unikernel/duniverse/ocaml-dns/cache/dns_cache.mli

@@ -0,0 +1,90 @@
+(** DNS cache - a least recently used cache of DNS responses
+
+    This data structure allows to insert and retrieve entries into a least
+    recently used data structure. An [`Entry] weights the cardinality of the
+    resource record map, all other entries have a weight of 1.
+
+    The time to live is preserved, and when it is exceeded the entry is no
+    longer returned.
+*)
+
+(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
+open Dns
+
+(** The variant of the rank in the cache. *)
+type rank =
+  | ZoneFile
+  | ZoneTransfer
+  | AuthoritativeAnswer of Rrsig.t option
+  | AuthoritativeAuthority of Rrsig.t option
+  | ZoneGlue
+  | NonAuthoritativeAnswer
+  | Additional
+
+val pp_rank : rank Fmt.t
+(** [pp_rank ppf rank] pretty-prints the [rank] on [ppf]. *)
+
+val compare_rank : rank -> rank -> int
+(** [compare_rank a b] compares the ranks [a] with [b]. *)
+
+(** The type of a DNS cache. *)
+type t
+
+val empty : int -> t
+(** [empty maximum_size] is an empty DNS cache with the maximum size as
+    capacity. *)
+
+val size : t -> int
+(** [size cache] is the number of bindings currently in the [cache]. *)
+
+val capacity : t -> int
+(** [capacity cache] is the used weight. *)
+
+val pp : t Fmt.t
+(** [pp ppf t] pretty prints the cache [t] on [ppf]. *)
+
+(** The polymorphic variant of an entry: a resource record, or no data,
+    no domain, or a server failure. *)
+type 'a entry = [
+  | `Entry of 'a
+  | `No_data of [ `raw ] Domain_name.t * Soa.t
+  | `No_domain of [ `raw ] Domain_name.t * Soa.t
+  | `Serv_fail of [ `raw ] Domain_name.t * Soa.t
+]
+
+val pp_entry : 'a Rr_map.key -> 'a entry Fmt.t
+(** [pp_entry ppf entry] pretty-prints [entry] on [ppf]. *)
+
+val get : t -> int64 -> [ `raw ] Domain_name.t -> 'a Rr_map.key ->
+  t * ('a entry * rank, [ `Cache_miss | `Cache_drop ]) result
+(** [get cache timestamp type name] retrieves the query [type, name] from the
+    [cache] using [timestamp]. If the time to live is exceeded, a [`Cache_drop]
+    is returned. If there is no entry in the cache, a [`Cache_miss] is
+    returned. *)
+
+val get_or_cname : t -> int64 -> [ `raw ] Domain_name.t -> 'a Rr_map.key ->
+  t * ([ 'a entry | `Alias of int32 * [`raw] Domain_name.t] * rank,
+       [ `Cache_miss | `Cache_drop ]) result
+(** [get_or_cname cache timestamp type name] is the same as [get], but if a
+    [`Cache_miss] is encountered, a lookup for an alias (CNAME) is done. *)
+
+val get_any : t -> int64 -> [ `raw ] Domain_name.t ->
+  t * ([ `Entries of Rr_map.t
+       | `No_domain of [ `raw ] Domain_name.t * Soa.t ] * rank,
+       [ `Cache_miss | `Cache_drop ]) result
+(** [get_any cache timestamp name] retrieves all resource records for [name]
+    in [cache]. *)
+
+val get_nsec3 : t -> int64 -> [ `raw ] Domain_name.t ->
+  t * (([`raw] Domain_name.t * int32 * Nsec3.t * rank) list, [ `Cache_miss | `Cache_drop ]) result
+(** [get_nsec3 cache timestamp name] retrieves all nsec3 resource records for
+    the zone [name]. *)
+
+val set : t -> int64 -> [ `raw ] Domain_name.t -> 'a Rr_map.key -> rank ->
+  'a entry -> t
+(** [set cache timestamp type name rank value] attempts to insert
+    [type, name, value] into the [cache] using the [timestamp] and [rank]. If
+    an entry already exists with a higher [rank], the [cache] is unchanged. *)
+
+val remove : t -> [ `raw ] Domain_name.t -> t
+(** [remove cache name] removes [name] from [cache]. *)

unikernel/duniverse/ocaml-dns/cache/dune

@@ -0,0 +1,6 @@
+(library
+  (name        dns_cache)
+  (public_name dns.cache)
+  (modules     dns_cache)
+  (libraries   domain-name dns duration lru metrics)
+  (wrapped     false))