unikernel/duniverse/ocaml-dns/server/dns_server.mli

@@ -0,0 +1,238 @@
+(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
+
+open Dns
+
+(** DNS Server implementation *)
+
+(** Authentication, stored in a Dns_trie with privileges to operations embedded in the name. *)
+module Authentication : sig
+  (** A key is a pair of a [`raw Domain_name.t] and a [Dnskey.t]. In the name,
+      operation privileges and potentially IP addresses are encoded, e.g.
+      [foo._transfer.example.com] may do AXFR on [example.com] and any
+      subdomain, e.g. [foo.example.com]. *)
+
+  type operation = [
+    | `Update
+    | `Transfer
+    | `Notify
+  ]
+  (** The type of operations, sorted by highest ot lowest privileges, an
+      [`Update] may as well carry out a [`Transfer]. *)
+
+  val operation_to_string : operation -> string
+  (** [operation_to_string op] is the string representation of [op]. *)
+
+  val all_ops : operation list
+  (** [all_ops] is a list of all operations. *)
+
+  val access_granted : required:operation -> operation -> bool
+  (** [access_granted ~required key_operation] is [true] if [key_operation] is
+      authorised for [required] operation. *)
+
+  val zone_and_operation : 'a Domain_name.t -> ([`host] Domain_name.t * operation) option
+  (** [zone_and_operation key] is [Some (zone, op)], the [zone] of the [key],
+      and its operation [op]. If the [key] is not in the expected format, [None]
+      is returned. *)
+
+  val access : ?key:'a Domain_name.t -> zone:'b Domain_name.t -> operation -> bool
+  (** [access op ~key ~zone] checks whether [key] is authorised for [op] on
+      [zone]. *)
+
+  type t
+  (** Opaque type for storing authentication keys. *)
+end
+
+type t = private {
+  data : Dns_trie.t ;
+  auth : Authentication.t ;
+  unauthenticated_zone_transfer : bool ;
+  rng : int -> string ;
+  tsig_verify : Tsig_op.verify ;
+  tsig_sign : Tsig_op.sign ;
+}
+(** The state of a DNS server. *)
+
+val create : ?unauthenticated_zone_transfer:bool ->
+  ?tsig_verify:Tsig_op.verify ->
+  ?tsig_sign:Tsig_op.sign ->
+  ?auth:Authentication.t ->
+  Dns_trie.t ->
+  (int -> string) ->
+  t
+(** [create ~unauthenticated_zone_transfer ~tsig_verify ~tsig_sign ~auth data rng]
+    constructs a [t]. See {!Primary.create} and {!Secondary.create} for the
+    logic running a primary or secondary server. *)
+
+val with_data : t -> Dns_trie.t -> t
+(** [with_data t data] is [t'] where the [data] field is updated with the
+    provided value. Be aware that this function breaks the semantics of a
+    primary server with secondaries, since secondaries won't be notified and
+    will be out of sync. Use if you know what you do. The data of a secondary
+    will usually come via zone transfer from the primary name services. *)
+
+val text : 'a Domain_name.t -> Dns_trie.t -> (string, [> `Msg of string ]) result
+(** [text name trie] results in a string representation (zonefile) of the trie. *)
+
+val handle_question : t -> Packet.Question.t ->
+  (Packet.Flags.t * Packet.Answer.t * Name_rr_map.t option,
+   Rcode.t * Packet.Answer.t option) result
+(** [handle_question t question] handles the DNS query [question] by looking
+    it up in the trie of [t]. The result is either an answer or an error. *)
+
+val update_data : Dns_trie.t -> 'a Domain_name.t ->
+  Dns.Packet.Update.prereq list Domain_name.Map.t
+  * Dns.Packet.Update.update list Domain_name.Map.t ->
+  ( Dns_trie.t * (Domain_name.Set.elt * Dns.Soa.t) list,
+   Dns.Rcode.t )
+  result
+(** [update_data data domain update_content] applies the [update_content] to
+    the [data] for [domain]. This function breaks the semantics of a primary
+    server with secondaries, since the secondaries won't be notified of the
+    update and will be out of sync. Use if you know what you are doing. *)
+
+val handle_update : t -> proto -> [ `raw ] Domain_name.t option ->
+  Packet.Question.t -> Packet.Update.t ->
+  (Dns_trie.t * ([`raw] Domain_name.t * Soa.t) list, Rcode.t) result
+(** [handle_update t proto keyname question update] authenticates the update
+    request and processes the update. This function breaks the semantics of a
+    primary server with secondaries, since the secondaries won't be notified.
+    Use if you know what you are doing. *)
+
+val handle_axfr_request : t -> proto -> [ `raw ] Domain_name.t option ->
+  Packet.Question.t -> (Packet.Axfr.t, Rcode.t) result
+(** [handle_axfr_request t proto keyname question] authenticates the zone
+    transfer request and processes it. If the request is valid, and the zone
+    available, a zone transfer is returned. *)
+
+type trie_cache
+
+val handle_ixfr_request : t -> trie_cache -> proto -> [ `raw ] Domain_name.t option ->
+  Packet.Question.t -> Soa.t -> (Packet.Ixfr.t, Rcode.t) result
+(** [handle_ixfr_request t cache proto keyname question soa] authenticates the
+    incremental zone transfer request and processes it. If valid, an incremental
+    zone transfer is returned. *)
+
+val handle_tsig : ?mac:string -> t -> Ptime.t -> Packet.t ->
+  string -> (([ `raw ] Domain_name.t * Tsig.t * string * Dnskey.t) option,
+                Tsig_op.e * string option) result
+(** [handle_tsig ~mac t now packet buffer] verifies the tsig
+    signature if present, returning the keyname, tsig, mac, and used key. *)
+
+type packet_callback = Packet.Question.t -> Packet.reply option
+(** [packet_callback question] either returns a reply to a DNS question [Some reply] or [None]. *)
+
+module Primary : sig
+
+  type s
+  (** The state of a primary DNS server. *)
+
+  val server : s -> t
+  (** [server s] is the server of the primary. *)
+
+  val data : s -> Dns_trie.t
+  (** [data s] is the data store of [s]. *)
+
+  val with_data : s -> Ptime.t -> int64 -> Dns_trie.t ->
+    s * (Ipaddr.t * string list) list
+  (** [with_data s now ts trie] replaces the current data with [trie] in [s].
+      The returned notifications should be send out. *)
+
+  val with_keys : s -> Ptime.t -> int64 -> ('a Domain_name.t * Dnskey.t) list ->
+    s * (Ipaddr.t * string list) list
+  (** [with_keys s now ts keys] replaces the current keys with [keys] in [s],
+      and generates notifications. *)
+
+  val trie_cache : s -> trie_cache
+  (** [trie_cache s] is the trie cache of the server. *)
+
+  val create : ?trie_cache_entries:int -> ?keys:('a Domain_name.t * Dnskey.t) list ->
+    ?unauthenticated_zone_transfer:bool ->
+    ?tsig_verify:Tsig_op.verify -> ?tsig_sign:Tsig_op.sign ->
+    rng:(int -> string) -> Dns_trie.t -> s
+  (** [create ~trie_cache_entries ~keys ~unauthenticated_zone_transfer
+      ~tsig_verify ~tsig_sign ~rng data] creates a primary server. If
+      [unauthenticated_zone_transfer] is provided and [true] (defaults to
+      [false]), anyone can transfer the zones. [trie_cache_entries] is the
+      backlog to keep in memory for incremental zone transfers (IXFR, default is 5). This
+      affects memory usage. *)
+
+  val handle_packet : ?packet_callback:packet_callback -> s -> Ptime.t -> int64
+    -> proto -> Ipaddr.t -> int -> Packet.t -> 'a Domain_name.t option ->
+    s * Packet.t option * (Ipaddr.t * string list) list *
+    [> `Notify of Soa.t option | `Keep ] option
+  (** [handle_packet ~packet_callback s now ts src src_port proto key packet]
+      handles the given [packet], returning new state, an answer, and
+      potentially notify packets to secondary name servers. If [packet_callback]
+      is specified, it is called for each incoming query. If it returns
+      [Some reply], this reply is used instead of the usual lookup in the
+      zone data. It can be used for custom query processing, such as for load
+      balancing or transporting data. *)
+
+  val handle_buf : ?packet_callback:packet_callback -> s -> Ptime.t -> int64
+    -> proto -> Ipaddr.t -> int -> string ->
+    s * string list * (Ipaddr.t * string list) list *
+    [ `Notify of Soa.t option | `Signed_notify of Soa.t option | `Keep ] option *
+    [ `raw ] Domain_name.t option
+  (** [handle_buf ~packet_callback s now ts proto src src_port buffer] decodes
+      the [buffer], processes the DNS frame using {!handle_packet}, and encodes
+      the reply. The result is a new state, potentially a list of answers to the
+      requestor, a list of notifications to send out, information whether a
+      notify (or signed notify) was received, and the hmac key used for
+      authentication. If [packet_callback] is specified, it is called for each
+      incoming query. If it returns [Some reply], this reply is used instead of
+      the usual lookup in the zone data. This can be used for custom query
+      processing, such as for load balancing or transporting data. *)
+
+  val closed : s -> Ipaddr.t -> s
+  (** [closed s ip] marks the connection to [ip] closed. *)
+
+  val timer : s -> Ptime.t -> int64 ->
+    s * (Ipaddr.t * string list) list
+  (** [timer s now ts] may encode some notifications to secondary name servers
+     if previous ones were not acknowledged. *)
+
+  val to_be_notified : s -> [ `host ] Domain_name.t ->
+    (Ipaddr.t * [ `raw ] Domain_name.t option) list
+  (** [to_be_notified s zone] returns a list of pairs of IP address and optional
+     tsig key name of the servers to be notified for a zone change.  This list
+     is based on (a) NS entries for the zone, (b) registered TSIG transfer keys,
+     and (c) active connection (which transmitted a signed SOA). *)
+end
+
+module Secondary : sig
+
+  type s
+  (** The state of a secondary DNS server. *)
+
+  val data : s -> Dns_trie.t
+  (** [data s] is the zone data of [s]. *)
+
+  val with_data : s -> Dns_trie.t -> s
+  (** [with_data s trie] is [s] with its data replaced by [trie]. *)
+
+  val create : ?primary:Ipaddr.t ->
+   tsig_verify:Tsig_op.verify -> tsig_sign:Tsig_op.sign ->
+    rng:(int -> string) -> ('a Domain_name.t * Dnskey.t) list -> s
+  (** [create ~primary ~tsig_verify ~tsig_sign ~rng keys] creates a secondary
+     DNS server state. *)
+
+  val handle_packet : ?packet_callback:packet_callback -> s -> Ptime.t -> int64 ->
+    Ipaddr.t -> Packet.t -> 'a Domain_name.t option ->
+    s * Packet.t option * (Ipaddr.t * string) option
+  (** [handle_packet s now ts ip proto key t] handles the incoming packet. *)
+
+  val handle_buf : ?packet_callback:packet_callback -> s -> Ptime.t -> int64 ->
+    proto -> Ipaddr.t -> string ->
+    s * string option * (Ipaddr.t * string) option
+  (** [handle_buf ~packet_callback s now ts proto src buf] decodes [buf], processes with
+      {!handle_packet}, and encodes the results. *)
+
+  val timer : s -> Ptime.t -> int64 ->
+    s * (Ipaddr.t * string list) list
+  (** [timer s now ts] may request SOA or retransmit AXFR. *)
+
+  val closed : s -> Ptime.t -> int64 -> Ipaddr.t ->
+    s * string list
+  (** [closed s now ts ip] marks [ip] as closed, the returned buffers (SOA
+      requests) should be sent to [ip]. *)
+end

unikernel/duniverse/ocaml-dns/server/dns_trie.ml

@@ -0,0 +1,551 @@
+(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
+
+open Dns
+
+module Canonical : sig
+  type 'a t
+  val v : 'a Domain_name.t -> 'a t
+  val d : 'a t -> 'a Domain_name.t
+end = struct
+  type 'a t = 'a Domain_name.t
+  let v n = Domain_name.canonical n
+  let d n = n
+end
+
+module O = struct
+  type t = string
+  let compare = String.compare
+end
+module M = Map.Make(O)
+
+type t = N of t M.t * Rr_map.t
+
+let empty = N (M.empty, Rr_map.empty)
+
+let is_empty (N (sub, map)) = M.is_empty sub && Rr_map.is_empty map
+
+let bindings t =
+  let rec go pre (N (sub, e)) =
+    let subs = M.bindings sub in
+    (pre, e) ::
+    List.fold_left
+      (fun acc (pre', va) ->
+         acc @ go (Domain_name.prepend_label_exn pre pre') va) [] subs
+  in
+  go Domain_name.root t
+
+let pp_map name ppf map =
+  Fmt.(list ~sep:(any "@.") string) ppf
+    (List.map (Rr_map.text_b name) (Rr_map.bindings map))
+
+let pp ppf t = List.iter (fun (name, map) -> pp_map name ppf map) (bindings t)
+
+let rec equal (N (sub, map)) (N (sub', map')) =
+  Rr_map.equal { f = Rr_map.equal_rr } map map' && M.equal equal sub sub'
+
+type e = [ `Delegation of [ `raw ] Domain_name.t * (int32 * Domain_name.Host_set.t)
+         | `EmptyNonTerminal of [ `raw ] Domain_name.t * Soa.t
+         | `NotAuthoritative
+         | `NotFound of [ `raw ] Domain_name.t * Soa.t ]
+
+let pp_e ppf = function
+  | `Delegation (name, (ttl, ns)) ->
+    Fmt.pf ppf "delegation %a to TTL %lu %a" Domain_name.pp name ttl
+      Fmt.(list ~sep:(any ",@,") Domain_name.pp) (Domain_name.Host_set.elements ns)
+  | `EmptyNonTerminal (name, soa) ->
+    Fmt.pf ppf "empty non terminal %a SOA %a" Domain_name.pp name Soa.pp soa
+  | `NotAuthoritative -> Fmt.string ppf "not authoritative"
+  | `NotFound (name, soa) -> Fmt.pf ppf "not found %a soa %a" Domain_name.pp name Soa.pp soa
+
+
+let ( let* ) = Result.bind
+
+let guard p err = if p then Ok () else Error err
+
+let ent name map =
+  let soa = Rr_map.get Soa map in
+  `EmptyNonTerminal (name, soa)
+
+let to_ns name map =
+  let ttl, ns =
+    match Rr_map.find Ns map with
+    | None -> 0l, Domain_name.Host_set.empty
+    | Some (ttl, ns) -> ttl, ns
+  in
+  (name, ttl, ns)
+
+let check_zone = function
+  | None -> Error `NotAuthoritative
+  | Some (`Delegation (name, (ttl, ns))) -> Error (`Delegation (name, (ttl, ns)))
+  | Some (`Soa (z, zmap)) -> Ok (z, zmap)
+
+let lookup_res zone ty m =
+  let* z, zmap = check_zone zone in
+  match Rr_map.find ty m with
+  | Some v -> Ok (Rr_map.B (ty, v), to_ns z zmap)
+  | None -> match Rr_map.find Cname m with
+    | None when Rr_map.cardinal m = 1 && Rr_map.(mem Soa m) ->
+      (* this is primary a hack for localhost, which must be NXDomain,
+         but there's a SOA for localhost (to handle it authoritatively) *)
+      (* TODO should we check that the label-node map is empty?
+         well, if we have a proper authoritative zone, there'll be a NS *)
+      let soa = Rr_map.get Rr_map.Soa zmap in
+      Error (`NotFound (z, soa))
+    | None -> Error (ent z zmap)
+    | Some cname -> Ok (B (Cname, cname), to_ns z zmap)
+
+let lookup_aux name t =
+  let name = Canonical.d name in
+  let k = Domain_name.to_array name in
+  let l = Array.length k in
+  let fzone idx map =
+    let name = Domain_name.(of_array (Array.sub (to_array name) 0 idx)) in
+    match Rr_map.mem Soa map, Rr_map.find Ns map with
+    | true, _ -> Some (`Soa (name, map))
+    | false, Some ns -> Some (`Delegation (name, ns))
+    | false, None -> None
+  in
+  let rec go idx zone = function
+    | N (sub, map) ->
+      let zone = match fzone idx map with None -> zone | Some x -> Some x in
+      if idx = l then Ok (zone, sub, map)
+      else match M.find (Array.get k idx) sub with
+        | exception Not_found ->
+          begin match zone with
+            | None -> Error `NotAuthoritative
+            | Some (`Delegation (name, (ttl, ns))) ->
+              Error (`Delegation (name, (ttl, ns)))
+            | Some (`Soa (name, map)) ->
+              (* may still be a wildcard *)
+              match M.find "*" sub with
+              | exception Not_found ->
+                let soa = Rr_map.get Soa map in
+                Error (`NotFound (name, soa))
+              | N (sub, map) -> Ok (zone, sub, map)
+          end
+        | x -> go (succ idx) zone x
+  in
+  go 0 None t
+
+let lookup_with_cname name ty t =
+  let* zone, _sub, map = lookup_aux (Canonical.v name) t in
+  lookup_res zone ty map
+
+let lookup name key t =
+  let* zone, _sub, map = lookup_aux (Canonical.v name) t in
+  let* z, zmap = check_zone zone in
+  Option.to_result ~none:(ent z zmap) (Rr_map.find key map)
+
+let lookup_any name t =
+  match lookup_aux (Canonical.v name) t with
+  | Error e -> Error e
+  | Ok (zone, _sub, m) ->
+    let* z, zmap = check_zone zone in
+    Ok (m, to_ns z zmap)
+
+let lookup_glue name t =
+  match lookup_aux (Canonical.v name) t with
+  | Error _ -> None, None
+  | Ok (_zone, _sub, map) -> Rr_map.find A map, Rr_map.find Aaaa map
+
+let zone name t =
+  match lookup_aux (Canonical.v name) t with
+  | Error (`NotFound (zone, soa)) -> Ok (zone, soa)
+  | Error e -> Error e
+  | Ok (zone, _, _) ->
+    match check_zone zone with
+    | Error e -> Error e
+    | Ok (name, map) ->
+      (* we ended with `Soa, which checked that map contains a Soa *)
+      Ok (name, Rr_map.get Soa map)
+
+let fold key (N (sub, map)) f s =
+  let get name map acc =
+    match Rr_map.find key map with
+    | Some a -> f name a acc
+    | None -> acc
+  in
+  let rec collect name sub acc =
+    List.fold_left (fun acc (pre, N (sub, map)) ->
+        let n' = Domain_name.prepend_label_exn name pre in
+        let keys = get n' map acc in
+        collect n' sub keys)
+      acc (M.bindings sub)
+  in
+  let name = Domain_name.root in
+  collect name sub (get name map s)
+
+let collect_rrs name sub map =
+  let collect_map top name rrmap =
+    if not top && Rr_map.mem Ns rrmap then
+      (* delegation *)
+      let ns_entries =
+        Option.fold ~none:[]
+          ~some:(fun ns -> [ name, Rr_map.B (Ns, ns) ])
+          (Rr_map.find Ns rrmap)
+      and ds_entries =
+        Option.fold ~none:[]
+          ~some:(fun ds -> [ name, Rr_map.B (Ds, ds) ])
+          (Rr_map.find Ds rrmap)
+      and rrsig_entries =
+        Option.fold ~none:[]
+          ~some:(fun rrsig -> [ name, Rr_map.B (Rrsig, rrsig) ])
+          (Rr_map.find Rrsig rrmap)
+      in
+      ns_entries @ ds_entries @ rrsig_entries, false
+    else
+      Rr_map.fold (fun v acc -> (name, v) :: acc) rrmap [], true
+  in
+  let rec go top name sub map =
+    let entries, recurse = collect_map top name map in
+    if recurse then
+      List.fold_left
+        (fun acc (pre, N (sub, map)) ->
+           acc @ go false (Domain_name.prepend_label_exn name pre) sub map)
+        entries (M.bindings sub)
+    else
+      entries
+  in
+  go true name sub map
+
+let collect_entries name sub map =
+  let ttlsoa =
+    match Rr_map.find Soa map with
+    | Some v -> Some v
+    | None when Domain_name.count_labels name = 0 ->
+      Some { Soa.nameserver = Domain_name.root ;
+             hostmaster = Domain_name.root ;
+             serial = 0l ; refresh = 0l ; retry = 0l ;
+             expiry = 0l ; minimum = 0l }
+    | None -> None
+  in
+  match ttlsoa with
+  | None -> Error `NotAuthoritative
+  | Some soa ->
+    let entries = collect_rrs name sub (Rr_map.remove Soa map) in
+    let res =
+      List.fold_left (fun acc (name, (Rr_map.B (k, v))) ->
+          Name_rr_map.add name k v acc) Domain_name.Map.empty entries
+    in
+    Ok (soa, res)
+
+let entries name t =
+  let name = Domain_name.raw name in
+  let* zone, sub, map = lookup_aux (Canonical.v name) t in
+  match zone with
+  | None -> Error `NotAuthoritative
+  | Some (`Delegation (name, (ttl, ns))) ->
+    Error (`Delegation (name, (ttl, ns)))
+  | Some (`Soa (name', _)) when Domain_name.equal name name' ->
+    collect_entries name sub map
+  | Some (`Soa (_, _)) -> Error `NotAuthoritative
+
+type zone_check = [ `Missing_soa of [ `raw ] Domain_name.t
+                  | `Cname_other of [ `raw ] Domain_name.t
+                  | `Bad_ttl of [ `raw ] Domain_name.t * Rr_map.b
+                  | `Empty of [ `raw ] Domain_name.t * Rr_map.k
+                  | `Missing_address of [ `host ] Domain_name.t
+                  | `Soa_not_a_host of [ `raw ] Domain_name.t * string ]
+
+let pp_zone_check ppf = function
+  | `Missing_soa name -> Fmt.pf ppf "missing soa for %a" Domain_name.pp name
+  | `Cname_other name -> Fmt.pf ppf "%a contains a cname record, and also other entries" Domain_name.pp name
+  | `Bad_ttl (name, v) -> Fmt.pf ppf "bad TTL for %a %a" Domain_name.pp name Rr_map.pp_b v
+  | `Empty (name, typ) -> Fmt.pf ppf "%a empty %a" Domain_name.pp name Rr_map.ppk typ
+  | `Missing_address name -> Fmt.pf ppf "missing address record for %a" Domain_name.pp name
+  | `Soa_not_a_host (name, msg) -> Fmt.pf ppf "%a the SOA nameserver is not a hostname: %s" Domain_name.pp name msg
+
+(* TODO: check for no cname loops? and dangling cname!? *)
+let check trie =
+  let has_address name =
+    match lookup name Rr_map.A trie with
+    | Ok _ -> true
+    | Error (`Delegation _) -> true
+    | _ -> match lookup name Rr_map.Aaaa trie with
+      | Ok _ -> true
+      | _ -> false
+  in
+  let rec check_sub names state sub map =
+    let name = Domain_name.of_strings_exn names in
+    let state' =
+      match Rr_map.find Soa map with
+      | None -> begin match Rr_map.find Ns map with
+          | None -> state
+          | Some _ -> `None
+        end
+      | Some _ -> `Soa name
+    in
+    let* () =
+      guard ((Rr_map.mem Cname map && Rr_map.cardinal map = 1) ||
+             not (Rr_map.mem Cname map)) (`Cname_other name)
+    in
+    let* () =
+      Rr_map.fold (fun v r ->
+          let* () = r in
+          match v with
+          | B (Dnskey, (ttl, keys)) ->
+            if ttl < 0l then Error (`Bad_ttl (name, v))
+            else if Rr_map.Dnskey_set.is_empty keys then
+              Error (`Empty (name, Rr_map.K Dnskey))
+            else Ok ()
+          | B (Ns, (ttl, names)) ->
+            if ttl < 0l then Error (`Bad_ttl (name, v))
+            else if Domain_name.Host_set.is_empty names then
+              Error (`Empty (name, K Ns))
+            else
+              let domain = match state' with `None -> name | `Soa zone -> zone in
+              Domain_name.Host_set.fold (fun name r ->
+                  let* () = r in
+                  if Domain_name.is_subdomain ~subdomain:name ~domain then
+                    guard (has_address name) (`Missing_address name)
+                  else
+                    Ok ()) names (Ok ())
+          | B (Cname, (ttl, _)) ->
+            if ttl < 0l then Error (`Bad_ttl (name, v)) else Ok ()
+          | B (Mx, (ttl, mxs)) ->
+            if ttl < 0l then
+              Error (`Bad_ttl (name, v))
+            else if Rr_map.Mx_set.is_empty mxs then
+              Error (`Empty (name, K Mx))
+            else
+              let domain = match state' with `None -> name | `Soa zone -> zone in
+              Rr_map.Mx_set.fold (fun { mail_exchange ; _ } r ->
+                  let* () = r in
+                  if Domain_name.is_subdomain ~subdomain:mail_exchange ~domain then
+                    guard (has_address mail_exchange) (`Missing_address mail_exchange)
+                  else
+                    Ok ())
+                mxs (Ok ())
+          | B (Ptr, (ttl, name)) ->
+            if ttl < 0l then Error (`Bad_ttl (Domain_name.raw name, v)) else Ok ()
+          | B (Soa, soa) ->
+            begin match Domain_name.host soa.nameserver with
+              | Error (`Msg m) -> Error (`Soa_not_a_host (soa.nameserver, m))
+              | Ok _ -> Ok ()
+            end
+          | B (Txt, (ttl, txts)) ->
+            if ttl < 0l then Error (`Bad_ttl (name, v))
+            else if Rr_map.Txt_set.is_empty txts then
+              Error (`Empty (name, K Txt))
+            else if
+              Rr_map.Txt_set.exists (fun s -> String.length s > 0) txts
+            then
+              Ok ()
+            else
+              Error (`Empty (name, K Txt))
+          | B (A, (ttl, a)) ->
+            if ttl < 0l then Error (`Bad_ttl (name, v))
+            else if Ipaddr.V4.Set.is_empty a then
+              Error (`Empty (name, K A))
+            else Ok ()
+          | B (Aaaa, (ttl, aaaa)) ->
+            if ttl < 0l then Error (`Bad_ttl (name, v))
+            else if Ipaddr.V6.Set.is_empty aaaa then
+              Error (`Empty (name, K Aaaa))
+            else Ok ()
+          | B (Srv, (ttl, srvs)) ->
+            if ttl < 0l then Error (`Bad_ttl (name, v))
+            else if Rr_map.Srv_set.is_empty srvs then
+              Error (`Empty (name, K Srv))
+            else Ok ()
+          | B (Svcb, (ttl, svcbs)) ->
+            if ttl < 0l then Error (`Bad_ttl (name, v))
+            else if Rr_map.Svcb_set.is_empty svcbs then
+              Error (`Empty (name, K Svcb))
+            else Ok ()
+          | B (Https, (ttl, httpss)) ->
+            if ttl < 0l then Error (`Bad_ttl (name, v))
+            else if Rr_map.Https_set.is_empty httpss then
+              Error (`Empty (name, K Https))
+            else Ok ()
+          | B (Caa, (ttl, caas)) ->
+            if ttl < 0l then Error (`Bad_ttl (name, v))
+            else if Rr_map.Caa_set.is_empty caas then
+              Error (`Empty (name, K Caa))
+            else Ok ()
+          | B (Tlsa, (ttl, tlsas)) ->
+            if ttl < 0l then Error (`Bad_ttl (name, v))
+            else if Rr_map.Tlsa_set.is_empty tlsas then
+              Error (`Empty (name, K Tlsa))
+            else Ok ()
+          | B (Sshfp, (ttl, sshfps)) ->
+            if ttl < 0l then Error (`Bad_ttl (name, v))
+            else if Rr_map.Sshfp_set.is_empty sshfps then
+              Error (`Empty (name, K Sshfp))
+            else Ok ()
+          | B (Ds, (ttl, ds)) ->
+            if ttl < 0l then Error (`Bad_ttl (name, v))
+            else if Rr_map.Ds_set.is_empty ds then
+              Error (`Empty (name, K Ds))
+            else Ok ()
+          | B (Rrsig, (ttl, rrs)) ->
+            if ttl < 0l then Error (`Bad_ttl (name, v))
+            else if Rr_map.Rrsig_set.is_empty rrs then
+              Error (`Empty (name, K Rrsig))
+            else Ok ()
+          | B (Nsec, (ttl, _rr)) ->
+            if ttl < 0l then Error (`Bad_ttl (name, v))
+            else Ok ()
+          | B (Nsec3, (ttl, _rr)) ->
+            if ttl < 0l then Error (`Bad_ttl (name, v))
+            else Ok ()
+          | B (Loc, (ttl, locs)) ->
+            if ttl < 0l then Error (`Bad_ttl (name, v))
+            else if Rr_map.Loc_set.is_empty locs then
+              Error (`Empty (name, Rr_map.K Loc))
+            else Ok ()
+          | B (Null, (ttl, nulls)) ->
+            if ttl < 0l then Error (`Bad_ttl (name, v))
+            else if Rr_map.Null_set.is_empty nulls then
+              Error (`Empty (name, Rr_map.K Null))
+            else Ok ()
+          | B (Unknown x, (ttl, datas)) ->
+            if ttl < 0l then Error (`Bad_ttl (name, v))
+            else if Rr_map.Txt_set.is_empty datas then
+              Error (`Empty (name, K (Unknown x)))
+            else Ok ())
+        map (Ok ())
+    in
+    M.fold (fun lbl (N (sub, map)) r ->
+        let* () = r in
+        check_sub (lbl :: names) state' sub map) sub (Ok ())
+  in
+  let (N (sub, map)) = trie in
+  check_sub [] `None sub map
+
+let find f name t =
+  let name = Canonical.d name in
+  let lbls = Domain_name.to_array name in
+  let l = Array.length lbls in
+  let rec go idx (N (sub, map)) =
+    if idx = l then
+      let sub', map' = f sub map in
+      N (sub', map')
+    else
+      let lbl = Array.get lbls idx in
+      let node = match M.find lbl sub with
+        | exception Not_found -> empty
+        | x -> x
+      in
+      let node' = go (succ idx) node in
+      if is_empty node' then
+        N (M.remove lbl sub, map)
+      else
+        N (M.add lbl node' sub, map)
+  in
+  go 0 t
+
+let replace name k v t =
+  find (fun sub map -> sub, Rr_map.add k v map) (Canonical.v name) t
+
+let insert name k v t =
+  let name = Canonical.v name in
+  let merge sub map =
+    let new_v = match Rr_map.find k map with
+      | None -> v
+      | Some v' -> Rr_map.union_rr k v' v
+    in
+    sub, Rr_map.add k new_v map
+  in
+  find merge name t
+
+let replace_map m t =
+  Domain_name.Map.fold (fun name map trie ->
+      find (fun sub _ -> sub, map) (Canonical.v name) trie) m t
+
+let insert_map m t =
+  Domain_name.Map.fold (fun name map trie ->
+      let union sub old = sub, Rr_map.union { f = Rr_map.unionee } old map in
+      find union (Canonical.v name) trie)
+    m t
+
+let remove k ty v t =
+  let remove sub map =
+    let map' = match Rr_map.find ty map with
+      | None -> map
+      | Some old -> match Rr_map.remove_rr ty old v with
+        | None -> Rr_map.remove ty map
+        | Some v' -> Rr_map.add ty v' map
+    in
+    sub, map'
+  in
+  find remove (Canonical.v k) t
+
+let remove_ty k ty t =
+  let remove sub map = sub, Rr_map.remove ty map in
+  find remove (Canonical.v k) t
+
+let remove_all k t =
+  let remove sub _ = sub, Rr_map.empty in
+  find remove (Canonical.v k) t
+
+let remove_map m t =
+  let merge k present remove = match present, remove with
+    | None, None -> None
+    | Some x, None -> Some x
+    | None, Some _ -> None
+    | Some x, Some y -> Rr_map.remove_rr k x y
+  in
+  Domain_name.Map.fold (fun name map trie ->
+      let remove sub old = sub, Rr_map.merge { f = merge } old map in
+      find remove (Canonical.v name) trie)
+    m t
+
+let remove_zone name t =
+  let remove sub _ =
+    (* go through all of sub, and retain those subtrees with Soa *)
+    let rec fold_sub sub =
+      M.fold (fun lbl node acc ->
+          match go node with None -> acc | Some n -> M.add lbl n acc)
+        sub M.empty
+    and go (N (sub, map)) =
+      match Rr_map.find Soa map with
+      | None ->
+        (* no SOA, continue search *)
+        let sub' = fold_sub sub in
+        if M.is_empty sub' then None else Some (N (sub', Rr_map.empty))
+      | Some _ ->
+        (* SOA, retain this submap *)
+        Some (N (sub, map))
+    in
+    fold_sub sub, Rr_map.empty (* drop the initial RRmap in any case! *)
+  in
+  find remove (Canonical.v name) t
+
+let diff zone req_soa ~old current =
+  match entries zone current with
+  | Error _ -> Error (`Msg "couldn't find zone in current trie")
+  | Ok (soa, map) ->
+    if not (Soa.newer ~old:req_soa soa) then
+      Ok (soa, `Empty)
+    else
+      match entries zone old with
+      | Error _ -> Ok (soa, `Full map)
+      | Ok (oldsoa, oldmap) ->
+        (* first, we fold over old map and collect the differences in two maps *)
+        let (to_remove, to_add), names =
+          Domain_name.Map.fold (fun name old ((to_remove, to_add), names) ->
+              let newmap =
+                match Domain_name.Map.find name map with
+                | None -> Rr_map.empty | Some x -> x
+              in
+              (match Rr_map.diff ~old newmap with
+               | None, None -> to_remove, to_add
+               | Some rm, None -> Domain_name.Map.add name rm to_remove, to_add
+               | None, Some add -> to_remove, Domain_name.Map.add name add to_add
+               | Some rm, Some add ->
+                 Domain_name.Map.add name rm to_remove,
+                 Domain_name.Map.add name add to_add),
+              Domain_name.Set.add name names)
+            oldmap Domain_name.((Map.empty, Map.empty), Set.empty)
+        in
+        (* now we fold over newmap and add then unless already handled *)
+        let to_add =
+          Domain_name.Map.fold (fun name newmap to_add ->
+              if Domain_name.Set.mem name names then
+                to_add
+              else
+                Domain_name.Map.add name newmap to_add)
+            map to_add
+        in
+        Ok (soa, `Difference (oldsoa, to_remove, to_add))

unikernel/duniverse/ocaml-dns/server/dns_trie.mli

@@ -0,0 +1,140 @@
+(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
+(** Prefix tree data structure for domain names
+
+    The key is a {!Domain_name}, whereas the value may be any resource record.
+    The representation is a tree, where the edges are domain name labels, and
+    the nodes carry a {{!Dns.Rr_map.t}resource map}.
+    Some special treatment is applied for zones, which must have a start of
+    authority entry and a set of name servers.  End of authority, also known as
+    delegation, is supported.  Aliases (canonical names, CNAME records) are also
+    supported.
+
+    The data structure tries to preserve invariants recommended by the domain
+    name system, such as that for any name there may either be an alias or any
+    other record, there must be a SOA record, and multiple NS records for an
+    authoritative zone, a resource type must have entries of the given type (no
+    NS record for A type, the ttl for all resource records of a rrset is the
+    same.
+*)
+
+open Dns
+
+(** {2 Abstract trie type} *)
+
+type t
+(** The type of the trie. *)
+
+val pp : t Fmt.t
+(** [pp ppf t] pretty prints [t] to [ppf]. *)
+
+val empty : t
+(** [empty] is the empty trie. *)
+
+val equal : t -> t -> bool
+(** [equal a b] compares [a] with [b]. *)
+
+(** {2 Operations to modify the trie} *)
+
+val insert_map : Rr_map.t Domain_name.Map.t -> t -> t
+(** [insert_map m t] inserts all elements of the domain name map [m] into
+    [t], potentially existing are unioned with {!Dns.Rr_map.unionee}. *)
+
+val replace_map : Rr_map.t Domain_name.Map.t -> t -> t
+(** [replace_map m t] replaces in the trie [t] all existing bindings of the
+    domain name map [m] with the provided map. *)
+
+val remove_map : Rr_map.t Domain_name.Map.t -> t -> t
+(** [remove_map m t] removes all elements of the domain name map [m] from
+    [t]. *)
+
+val insert : 'a Domain_name.t -> 'b Rr_map.key -> 'b -> t -> t
+(** [insert n k v t] inserts [k, v] under [n] in [t].  Existing entries are
+    unioneed with {!Dns.Rr_map.union_rr}. *)
+
+val replace : 'a Domain_name.t -> 'b Rr_map.key -> 'b -> t -> t
+(** [replace n k v t] inserts [k, v] under [n] in [t].  Existing entries are
+    replaced. *)
+
+val remove : 'a Domain_name.t -> 'b Rr_map.key -> 'b -> t -> t
+(** [remove k ty v t] removes [ty, v] from [t] at [k].  Beware, this may lead
+    to a [t] where the initially mentioned invariants are violated. *)
+
+val remove_ty : 'a Domain_name.t -> 'b Rr_map.key -> t -> t
+(** [remove_ty k ty t] removes [ty] from [t] at [k]. Beware, this may lead to a
+    [t] where the initially mentioned invariants are violated. *)
+
+val remove_all : 'a Domain_name.t -> t -> t
+(** [remove_all k t] removes all entries of [k] in [t]. Beware, this may lead to
+   a [t] where the initially mentioned invariants are violated. *)
+
+val remove_zone : 'a Domain_name.t -> t -> t
+(** [remove_zone name t] remove the zone [name] from [t], retaining subzones
+    (entries with [Soa] records).  This removes as well any delegations. *)
+
+
+(** {2 Checking invariants} *)
+
+type zone_check = [ `Missing_soa of [ `raw ] Domain_name.t
+                  | `Cname_other of [ `raw ] Domain_name.t
+                  | `Bad_ttl of [ `raw ] Domain_name.t * Rr_map.b
+                  | `Empty of [ `raw ] Domain_name.t * Rr_map.k
+                  | `Missing_address of [ `host ] Domain_name.t
+                  | `Soa_not_a_host of [ `raw ] Domain_name.t * string ]
+
+val pp_zone_check : zone_check Fmt.t
+(** [pp_err ppf err] pretty prints the error [err]. *)
+
+val check : t -> (unit, zone_check) result
+(** [check t] checks all invariants. *)
+
+
+(** {2 Lookup} *)
+
+type e = [ `Delegation of [ `raw ] Domain_name.t * (int32 * Domain_name.Host_set.t)
+         | `EmptyNonTerminal of [ `raw ] Domain_name.t * Soa.t
+         | `NotAuthoritative
+         | `NotFound of [ `raw ] Domain_name.t * Soa.t ]
+(** The type of lookup errors. *)
+
+val pp_e : e Fmt.t
+(** [pp_e ppf e] pretty-prints [e] on [ppf]. *)
+
+val zone : 'a Domain_name.t -> t ->
+  ([ `raw ] Domain_name.t * Soa.t, e) result
+(** [zone k t] returns either the zone and soa for [k] in [t], or an error. *)
+
+val lookup_with_cname : 'a Domain_name.t -> 'b Rr_map.key -> t ->
+  (Rr_map.b * ([ `raw ] Domain_name.t * int32 * Domain_name.Host_set.t), e) result
+(** [lookup_with_cname k ty t] finds [k, ty] in [t]. It either returns the found
+    resource record set and authority information, a cname alias and authority
+    information, or an error. *)
+
+val lookup : 'a Domain_name.t -> 'b Rr_map.key -> t -> ('b, e) result
+(** [lookup k ty t] finds [k, ty] in [t], which may lead to an error. *)
+
+val lookup_any : 'a Domain_name.t -> t ->
+  (Rr_map.t * ([ `raw ] Domain_name.t * int32 * Domain_name.Host_set.t), e) result
+(** [lookup_any k t] looks up all resource records of [k] in [t], and returns
+    that and the authority information. *)
+
+val lookup_glue : 'a Domain_name.t -> t ->
+  (int32 * Ipaddr.V4.Set.t) option * (int32 * Ipaddr.V6.Set.t) option
+(** [lookup_glue k t] finds glue records (A, AAAA) for [k] in [t]. It ignores
+    potential DNS invariants, e.g. that there is no surrounding zone. *)
+
+val entries : 'a Domain_name.t -> t ->
+  (Dns.Soa.t * Rr_map.t Domain_name.Map.t, e) result
+(** [entries name t] returns either the SOA and all entries for the requested
+    [name], or an error. *)
+
+val fold : 'a Rr_map.key -> t -> ([ `raw ] Domain_name.t -> 'a -> 'b -> 'b) -> 'b -> 'b
+(** [fold key t f acc] calls [f] with [dname value acc] element in [t]. *)
+
+val diff : 'a Domain_name.t -> Soa.t -> old:t -> t ->
+  (Soa.t * [ `Empty | `Full of Name_rr_map.t | `Difference of Soa.t * Name_rr_map.t * Name_rr_map.t ],
+   [> `Msg of string ]) result
+(** [diff zone soa ~old trie] computes the difference of [zone] in [old] and
+   [trie], and returns either [`Empty] if [soa] is equal or newer than the one
+   in [trie], [`Full] (the same as [entries]) if [zone] is not present in [old],
+   or [`Difference (old_soa, deleted, added)]. Best used with IXFR. An error
+   occurs if [zone] is not present in [trie]. *)

unikernel/duniverse/ocaml-dns/server/dune

@@ -0,0 +1,5 @@
+(library
+ (name dns_server)
+ (public_name dns-server)
+ (wrapped false)
+ (libraries dns randomconv duration metrics))