Skip to content
This repository has been archived by the owner. It is now read-only.
Permalink
master
Switch branches/tags
Go to file
 
 
Cannot retrieve contributors at this time
493 lines (451 sloc) 17 KB
(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
open Dns
module O = struct
type t = string
let compare = Domain_name.compare_sub
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:(unit "@.") 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:(unit ",@,") 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
open Rresult.R.Infix
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 =
check_zone zone >>= fun (z, zmap) ->
guard (not (Rr_map.is_empty m)) (ent z zmap) >>= fun () ->
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 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)) ->
let soa = Rr_map.get Soa map in
Error (`NotFound (name, soa))
end
| x -> go (succ idx) zone x
in
go 0 None t
let lookup_with_cname name ty t =
lookup_aux name t >>= fun (zone, _sub, map) ->
lookup_res zone ty map
let lookup name key t =
match lookup_aux name t with
| Error e -> Error e
| Ok (zone, _sub, map) ->
match Rr_map.find key map with
| Some v -> Ok v
| None -> match zone with
| None -> Error `NotAuthoritative
| Some (`Delegation (name, (ttl, ns))) -> Error (`Delegation (name, (ttl, ns)))
| Some (`Soa (z, zmap)) -> Error (ent z zmap)
let lookup_any name t =
match lookup_aux name t with
| Error e -> Error e
| Ok (zone, _sub, m) ->
check_zone zone >>= fun (z, zmap) ->
Ok (m, to_ns z zmap)
let lookup_glue name t =
match lookup_aux 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 name t with
| 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 =
(* TODO: do not cross zone boundaries! or maybe not!? *)
let collect_map name rrmap =
(* collecting rr out of rrmap + name, no SOA! *)
Rr_map.fold (fun v acc ->
match v with
| Rr_map.(B (Soa, _)) -> acc
| v -> (name, v) :: acc)
rrmap []
in
let rec go name sub map =
let entries = collect_map name map in
List.fold_left
(fun acc (pre, N (sub, map)) ->
acc @ go (Domain_name.prepend_label_exn name pre) sub map)
entries (M.bindings sub)
in
go 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.(equal root name) ->
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 map in
let map =
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, map)
let entries name t =
let name = Domain_name.raw name in
lookup_aux name t >>= fun (zone, sub, map) ->
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_ns of [ `raw ] 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_ns name -> Fmt.pf ppf "%a nameserver of SOA is not in nameserver set" 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
guard ((Rr_map.mem Cname map && Rr_map.cardinal map = 1) ||
not (Rr_map.mem Cname map)) (`Cname_other name) >>= fun () ->
Rr_map.fold (fun v r ->
r >>= fun () ->
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 ->
r >>= fun () ->
if Domain_name.sub ~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 ->
r >>= fun () ->
if Domain_name.sub ~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 Rr_map.find Ns map with
| Some (_, names) ->
begin match Domain_name.host soa.nameserver with
| Error (`Msg m) -> Error (`Soa_not_a_host (soa.nameserver, m))
| Ok host when Domain_name.Host_set.mem host names -> Ok ()
| Ok _ -> Error (`Soa_not_ns soa.nameserver)
end
| None -> Ok () (* we're happy to only have a soa, but nothing else -- useful for grounding zones! *)
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 Rr_map.Ipv4_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 Rr_map.Ipv6_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 (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 (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 ()) >>= fun () ->
M.fold (fun lbl (N (sub, map)) r ->
r >>= fun () ->
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 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) name t
let insert name k v t =
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) 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 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 k t
let remove_ty k ty t =
let remove sub map = sub, Rr_map.remove ty map in
find remove k t
let remove_all k t =
let remove sub _ = sub, Rr_map.empty in
find remove 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 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 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))