2163 lines
100 KiB
OCaml
2163 lines
100 KiB
OCaml
(* (c) 2017 Hannes Mehnert, all rights reserved *)
|
|
|
|
open Dns
|
|
|
|
let n_of_s = Domain_name.of_string_exn
|
|
|
|
module Trie = struct
|
|
open Dns_trie
|
|
|
|
let e =
|
|
let module M = struct
|
|
type t = e
|
|
let pp = Dns_trie.pp_e
|
|
let equal a b = match a, b with
|
|
| `Delegation (na, (ttl, n)), `Delegation (na', (ttl', n')) ->
|
|
Domain_name.equal na na' && ttl = ttl' && Domain_name.Host_set.equal n n'
|
|
| `EmptyNonTerminal (nam, soa), `EmptyNonTerminal (nam', soa') ->
|
|
Domain_name.equal nam nam' && Soa.compare soa soa' = 0
|
|
| `NotFound (nam, soa), `NotFound (nam', soa') ->
|
|
Domain_name.equal nam nam' && Soa.compare soa soa' = 0
|
|
| `NotAuthoritative, `NotAuthoritative -> true
|
|
| _ -> false
|
|
end in
|
|
(module M: Alcotest.TESTABLE with type t = M.t)
|
|
|
|
let b_ok =
|
|
let module M = struct
|
|
type t = Rr_map.b
|
|
let pp = Rr_map.pp_b
|
|
let equal = Rr_map.equalb
|
|
end in
|
|
(module M: Alcotest.TESTABLE with type t = M.t)
|
|
|
|
let glue_ok =
|
|
let module M = struct
|
|
type t = (int32 * Ipaddr.V4.Set.t) option * (int32 * Ipaddr.V6.Set.t) option
|
|
let pp ppf (v4, v6) =
|
|
let pp_v4 ppf v4 =
|
|
Fmt.(list ~sep:(any ",") Ipaddr.V4.pp) ppf (Ipaddr.V4.Set.elements v4)
|
|
and pp_v6 ppf v6 =
|
|
Fmt.(list ~sep:(any ",") Ipaddr.V6.pp) ppf (Ipaddr.V6.Set.elements v6)
|
|
in
|
|
Fmt.pf ppf "V4 %a@ V6 %a"
|
|
Fmt.(option ~none:(any "none") (pair ~sep:(any ", ") int32 pp_v4)) v4
|
|
Fmt.(option ~none:(any "none") (pair ~sep:(any ", ") int32 pp_v6)) v6
|
|
let equal a b = match a, b with
|
|
| (None, None), (None, None) -> true
|
|
| (Some (ttl, v4), None), (Some (ttl', v4'), None) ->
|
|
ttl = ttl' && Ipaddr.V4.Set.equal v4 v4'
|
|
| (None, Some (ttl, v6)), (None, Some (ttl', v6')) ->
|
|
ttl = ttl' && Ipaddr.V6.Set.equal v6 v6'
|
|
| (Some (ttl, v4), Some (ttl6, v6)), (Some (ttl', v4'), Some (ttl6', v6')) ->
|
|
ttl = ttl' && Ipaddr.V4.Set.equal v4 v4' &&
|
|
ttl6 = ttl6' && Ipaddr.V6.Set.equal v6 v6'
|
|
| _ -> false
|
|
end in
|
|
(module M: Alcotest.TESTABLE with type t = M.t)
|
|
|
|
let l_ok =
|
|
let module M = struct
|
|
type t = Rr_map.b * ([ `raw ] Domain_name.t * int32 * Domain_name.Host_set.t)
|
|
let pp ppf (v, (name, ttl, ns)) =
|
|
Fmt.pf ppf "%a auth %a TTL %lu %a" Rr_map.pp_b v Domain_name.pp name ttl
|
|
Fmt.(list ~sep:(any ",@,") Domain_name.pp) (Domain_name.Host_set.elements ns)
|
|
let equal (a, (name, ttl, ns)) (a', (name', ttl', ns')) =
|
|
ttl = ttl' && Domain_name.equal name name' && Domain_name.Host_set.equal ns ns' &&
|
|
Rr_map.equalb a a'
|
|
end in
|
|
(module M: Alcotest.TESTABLE with type t = M.t)
|
|
|
|
let sn a = Domain_name.Host_set.singleton (Domain_name.host_exn a)
|
|
let ip = Ipaddr.V4.of_string_exn
|
|
|
|
let ins_zone name soa ttl ns t =
|
|
insert name Rr_map.Ns (ttl, ns) (insert name Rr_map.Soa soa t)
|
|
|
|
let lookup_b name key t = match lookup name key t with
|
|
| Ok v -> Ok (Rr_map.B (key, v))
|
|
| Error e -> Error e
|
|
|
|
let simple () =
|
|
Alcotest.(check (result l_ok e)
|
|
"lookup for root returns NotAuthoritative"
|
|
(Error `NotAuthoritative)
|
|
(lookup_with_cname Domain_name.root A empty)) ;
|
|
let soa = {
|
|
Soa.nameserver = n_of_s "a" ; hostmaster = n_of_s "hs" ;
|
|
serial = 1l ; refresh = 10l ; retry = 5l ; expiry = 3l ; minimum = 4l
|
|
} in
|
|
let t = ins_zone Domain_name.root soa 6l (sn (Domain_name.host_exn (n_of_s "a"))) empty in
|
|
Alcotest.(check (result l_ok e) "lookup_with_cname for .com is NoDomain"
|
|
(Error (`NotFound (Domain_name.root, soa)))
|
|
(lookup_with_cname (n_of_s "com") A t)) ;
|
|
Alcotest.(check (result b_ok e) "lookup_b for .com is NoDomain"
|
|
(Error (`NotFound (Domain_name.root, soa)))
|
|
(lookup_b (n_of_s "com") A t)) ;
|
|
Alcotest.(check (result l_ok e) "lookup_with_cname for SOA . is SOA"
|
|
(Ok (Rr_map.B (Rr_map.Soa, soa),
|
|
(Domain_name.root, 6l, sn (Domain_name.host_exn (n_of_s "a")))))
|
|
(lookup_with_cname Domain_name.root Soa t)) ;
|
|
Alcotest.(check (result b_ok e) "lookup_b for SOA . is SOA"
|
|
(Ok (Rr_map.B (Rr_map.Soa, soa)))
|
|
(lookup_b Domain_name.root Soa t)) ;
|
|
let a_record = (23l, Ipaddr.V4.Set.singleton (ip "1.4.5.2")) in
|
|
let t = insert (n_of_s "foo.com") Rr_map.A a_record t in
|
|
Alcotest.(check (result l_ok e) "lookup_with_cname for A foo.com is A"
|
|
(Ok (Rr_map.B (Rr_map.A, a_record),
|
|
(Domain_name.root, 6l, sn (Domain_name.host_exn (n_of_s "a")))))
|
|
(lookup_with_cname (n_of_s "foo.com") A t)) ;
|
|
Alcotest.(check (result b_ok e) "lookup_b for A foo.com is A"
|
|
(Ok (Rr_map.B (Rr_map.A, a_record)))
|
|
(lookup_b (n_of_s "foo.com") A t)) ;
|
|
Alcotest.(check (result l_ok e) "lookup_with_cname for SOA com is ENT"
|
|
(Error (`EmptyNonTerminal (Domain_name.root, soa)))
|
|
(lookup_with_cname (n_of_s "com") Soa t)) ;
|
|
Alcotest.(check (result b_ok e) "lookup_b for SOA com is ENT"
|
|
(Error (`EmptyNonTerminal (Domain_name.root, soa)))
|
|
(lookup_b (n_of_s "com") Soa t)) ;
|
|
Alcotest.(check (result l_ok e) "lookup_with_cname for SOA foo.com is NoDomain"
|
|
(Error (`EmptyNonTerminal (Domain_name.root, soa)))
|
|
(lookup_with_cname (n_of_s "foo.com") Soa t));
|
|
Alcotest.(check (result b_ok e) "lookup_b for SOA foo.com is NoDomain"
|
|
(Error (`EmptyNonTerminal (Domain_name.root, soa)))
|
|
(lookup_b (n_of_s "foo.com") Soa t))
|
|
|
|
let basic () =
|
|
let soa = {
|
|
Soa.nameserver = n_of_s "ns1.foo.com" ;
|
|
hostmaster = n_of_s "hs.foo.com" ;
|
|
serial = 1l ; refresh = 10l ; retry = 5l ; expiry = 3l ; minimum = 4l
|
|
} in
|
|
let t =
|
|
ins_zone (n_of_s "foo.com") soa 10l (sn (Domain_name.host_exn (n_of_s "ns1.foo.com"))) empty
|
|
in
|
|
Alcotest.(check (result l_ok e)
|
|
"lookup_with_cname for SOA bar.com is NotAuthoritative"
|
|
(Error `NotAuthoritative)
|
|
(lookup_with_cname (n_of_s "bar.com") Soa t)) ;
|
|
Alcotest.(check (result b_ok e)
|
|
"lookup_b for SOA bar.com is NotAuthoritative"
|
|
(Error `NotAuthoritative)
|
|
(lookup_b (n_of_s "bar.com") Soa t)) ;
|
|
Alcotest.(check (result l_ok e)
|
|
"lookup_with_cname for SOA foo.com (after insert) is good"
|
|
(Ok (Rr_map.B (Rr_map.Soa, soa),
|
|
(n_of_s "foo.com", 10l, sn (Domain_name.host_exn (n_of_s "ns1.foo.com")))))
|
|
(lookup_with_cname (n_of_s "foo.com") Soa t)) ;
|
|
Alcotest.(check (result b_ok e)
|
|
"lookup_b for SOA foo.com (after insert) is good"
|
|
(Ok (Rr_map.B (Rr_map.Soa, soa)))
|
|
(lookup_b (n_of_s "foo.com") Soa t)) ;
|
|
Alcotest.(check (result l_ok e)
|
|
"lookup_with_cname for NS foo.com (after insert) is good"
|
|
(Ok (Rr_map.B (Rr_map.Ns, (10l, sn (Domain_name.host_exn (n_of_s "ns1.foo.com")))),
|
|
(n_of_s "foo.com", 10l, sn (Domain_name.host_exn (n_of_s "ns1.foo.com")))))
|
|
(lookup_with_cname (n_of_s "foo.com") Ns t)) ;
|
|
Alcotest.(check (result b_ok e)
|
|
"lookup_b for NS foo.com (after insert) is good"
|
|
(Ok (Rr_map.B (Rr_map.Ns, (10l, sn (Domain_name.host_exn (n_of_s "ns1.foo.com"))))))
|
|
(lookup_b (n_of_s "foo.com") Ns t)) ;
|
|
Alcotest.(check (result l_ok e)
|
|
"lookup_with_cname for AAAA foo.com (after insert) is NoData"
|
|
(Error (`EmptyNonTerminal (n_of_s "foo.com", soa)))
|
|
(lookup_with_cname (n_of_s "foo.com") Aaaa t)) ;
|
|
Alcotest.(check (result b_ok e)
|
|
"lookup_b for AAAA foo.com (after insert) is NoData"
|
|
(Error (`EmptyNonTerminal (n_of_s "foo.com", soa)))
|
|
(lookup_b (n_of_s "foo.com") Aaaa t)) ;
|
|
Alcotest.(check (result l_ok e)
|
|
"lookup_with_cname for A foo.com (after insert) is NoData"
|
|
(Error (`EmptyNonTerminal (n_of_s "foo.com", soa)))
|
|
(lookup_with_cname (n_of_s "foo.com") A t)) ;
|
|
Alcotest.(check (result b_ok e)
|
|
"lookup_b for A foo.com (after insert) is NoData"
|
|
(Error (`EmptyNonTerminal (n_of_s "foo.com", soa)))
|
|
(lookup_b (n_of_s "foo.com") A t)) ;
|
|
Alcotest.(check (result l_ok e)
|
|
"lookup_with_cname for MX foo.com (after insert) is NoData"
|
|
(Error (`EmptyNonTerminal (n_of_s "foo.com", soa)))
|
|
(lookup_with_cname (n_of_s "foo.com") Mx t)) ;
|
|
Alcotest.(check (result b_ok e)
|
|
"lookup_b for MX foo.com (after insert) is NoData"
|
|
(Error (`EmptyNonTerminal (n_of_s "foo.com", soa)))
|
|
(lookup_b (n_of_s "foo.com") Mx t)) ;
|
|
Alcotest.(check (result l_ok e)
|
|
"lookup_with_cname for MX bar.foo.com (after insert) is NoDomain"
|
|
(Error (`NotFound (n_of_s "foo.com", soa)))
|
|
(lookup_with_cname (n_of_s "bar.foo.com") Mx t)) ;
|
|
Alcotest.(check (result b_ok e)
|
|
"lookup_b for MX bar.foo.com (after insert) is NoDomain"
|
|
(Error (`NotFound (n_of_s "foo.com", soa)))
|
|
(lookup_b (n_of_s "bar.foo.com") Mx t)) ;
|
|
let a_record = (12l, Ipaddr.V4.Set.singleton (ip "1.2.3.4")) in
|
|
let t = insert (n_of_s "foo.com") Rr_map.A a_record t in
|
|
Alcotest.(check (result l_ok e)
|
|
"lookup_with_cname for AAAA foo.com (after insert) is NoData"
|
|
(Error (`EmptyNonTerminal (n_of_s "foo.com", soa)))
|
|
(lookup_with_cname (n_of_s "foo.com") Aaaa t)) ;
|
|
Alcotest.(check (result b_ok e)
|
|
"lookup_b for AAAA foo.com (after insert) is NoData"
|
|
(Error (`EmptyNonTerminal (n_of_s "foo.com", soa)))
|
|
(lookup_b (n_of_s "foo.com") Aaaa t)) ;
|
|
Alcotest.(check (result l_ok e)
|
|
"lookup_with_cname for A foo.com (after insert) is Found"
|
|
(Ok (Rr_map.B (Rr_map.A, a_record),
|
|
(n_of_s "foo.com", 10l, sn (Domain_name.host_exn (n_of_s "ns1.foo.com")))))
|
|
(lookup_with_cname (n_of_s "foo.com") A t)) ;
|
|
Alcotest.(check (result b_ok e)
|
|
"lookup_b for A foo.com (after insert) is Found"
|
|
(Ok (Rr_map.B (Rr_map.A, a_record)))
|
|
(lookup_b (n_of_s "foo.com") A t)) ;
|
|
Alcotest.(check (result l_ok e)
|
|
"lookup_with_cname for MX foo.com (after insert) is NoData"
|
|
(Error (`EmptyNonTerminal (n_of_s "foo.com", soa)))
|
|
(lookup_with_cname (n_of_s "foo.com") Mx t)) ;
|
|
Alcotest.(check (result b_ok e)
|
|
"lookup_b for MX foo.com (after insert) is NoData"
|
|
(Error (`EmptyNonTerminal (n_of_s "foo.com", soa)))
|
|
(lookup_b (n_of_s "foo.com") Mx t)) ;
|
|
let t = remove_ty (n_of_s "foo.com") A t in
|
|
Alcotest.(check (result l_ok e)
|
|
"lookup_with_cname for A foo.com (after insert and remove) is NoData"
|
|
(Error (`EmptyNonTerminal (n_of_s "foo.com", soa)))
|
|
(lookup_with_cname (n_of_s "foo.com") A t)) ;
|
|
Alcotest.(check (result b_ok e)
|
|
"lookup_b for A foo.com (after insert and remove) is NoData"
|
|
(Error (`EmptyNonTerminal (n_of_s "foo.com", soa)))
|
|
(lookup_b (n_of_s "foo.com") A t)) ;
|
|
let t = remove_all (n_of_s "foo.com") t in
|
|
Alcotest.(check (result l_ok e)
|
|
"lookup_with_cname for SOA foo.com (after remove) is NotAuthoritative"
|
|
(Error `NotAuthoritative)
|
|
(lookup_with_cname (n_of_s "foo.com") Soa t)) ;
|
|
Alcotest.(check (result b_ok e)
|
|
"lookup_b for SOA foo.com (after remove) is NotAuthoritative"
|
|
(Error `NotAuthoritative)
|
|
(lookup_b (n_of_s "foo.com") Soa t))
|
|
|
|
let alias () =
|
|
let soa = {
|
|
Soa.nameserver = n_of_s "ns1.foo.com" ;
|
|
hostmaster = n_of_s "hs.foo.com" ;
|
|
serial = 1l ; refresh = 10l ; retry = 5l ; expiry = 3l ; minimum = 4l
|
|
} in
|
|
let t =
|
|
ins_zone (n_of_s "foo.com") soa 10l (sn (Domain_name.host_exn (n_of_s "ns1.foo.com"))) empty
|
|
in
|
|
let t = insert (n_of_s "bar.foo.com") Rr_map.Cname (14l, n_of_s "foo.bar.com") t in
|
|
Alcotest.(check (result l_ok e)
|
|
"lookup_with_cname for SOA bar.foo.com (after insert) is good"
|
|
(Ok (Rr_map.B (Rr_map.Cname, (14l, n_of_s "foo.bar.com")),
|
|
(n_of_s "foo.com", 10l, sn (Domain_name.host_exn (n_of_s "ns1.foo.com")))))
|
|
(lookup_with_cname (n_of_s "bar.foo.com") Soa t)) ;
|
|
Alcotest.(check (result b_ok e)
|
|
"lookup_b for SOA bar.foo.com (after insert) is good"
|
|
(Error (`EmptyNonTerminal (n_of_s "foo.com", soa)))
|
|
(lookup_b (n_of_s "bar.foo.com") Soa t))
|
|
|
|
let dele () =
|
|
let soa = {
|
|
Soa.nameserver = n_of_s "ns1.foo.com" ;
|
|
hostmaster = n_of_s "hs.foo.com" ;
|
|
serial = 1l ; refresh = 10l ; retry = 5l ; expiry = 3l ; minimum = 4l
|
|
} in
|
|
let t =
|
|
ins_zone (n_of_s "foo.com") soa 10l (sn (Domain_name.host_exn (n_of_s "ns1.foo.com"))) empty
|
|
in
|
|
Alcotest.(check (result l_ok e)
|
|
"lookup_with_cname for SOA foo.com (after insert) is good"
|
|
(Ok (Rr_map.B (Rr_map.Soa, soa),
|
|
(n_of_s "foo.com", 10l, sn (Domain_name.host_exn (n_of_s "ns1.foo.com")))))
|
|
(lookup_with_cname (n_of_s "foo.com") Soa t)) ;
|
|
Alcotest.(check (result b_ok e)
|
|
"lookup_b for SOA foo.com (after insert) is good"
|
|
(Ok (Rr_map.B (Rr_map.Soa, soa)))
|
|
(lookup_b (n_of_s "foo.com") Soa t)) ;
|
|
Alcotest.(check (result l_ok e)
|
|
"lookup_with_cname for NS foo.com (after insert) is good"
|
|
(Ok (Rr_map.B (Rr_map.Ns, (10l, sn (Domain_name.host_exn (n_of_s "ns1.foo.com")))),
|
|
(n_of_s "foo.com", 10l, sn (Domain_name.host_exn (n_of_s "ns1.foo.com")))))
|
|
(lookup_with_cname (n_of_s "foo.com") Ns t)) ;
|
|
Alcotest.(check (result b_ok e)
|
|
"lookup_b for NS foo.com (after insert) is good"
|
|
(Ok (Rr_map.B (Rr_map.Ns, (10l, sn (Domain_name.host_exn (n_of_s "ns1.foo.com"))))))
|
|
(lookup_b (n_of_s "foo.com") Ns t)) ;
|
|
let t = insert (n_of_s "bar.foo.com") Rr_map.Ns (12l, sn (Domain_name.host_exn (n_of_s "ns3.bar.com"))) t in
|
|
Alcotest.(check (result l_ok e) "lookup_with_cname for A bar.foo.com is delegated"
|
|
(Error (`Delegation (n_of_s "bar.foo.com", (12l, sn (Domain_name.host_exn (n_of_s "ns3.bar.com"))))))
|
|
(lookup_with_cname (n_of_s "bar.foo.com") A t)) ;
|
|
Alcotest.(check (result b_ok e) "lookup_b for A bar.foo.com is delegated"
|
|
(Error (`Delegation (n_of_s "bar.foo.com", (12l, sn (Domain_name.host_exn (n_of_s "ns3.bar.com"))))))
|
|
(lookup_b (n_of_s "bar.foo.com") A t)) ;
|
|
Alcotest.(check (result l_ok e) "lookup_with_cname for NS foo.bar.foo.com is delegated"
|
|
(Error (`Delegation (n_of_s "bar.foo.com", (12l, sn (Domain_name.host_exn (n_of_s "ns3.bar.com"))))))
|
|
(lookup_with_cname (n_of_s "foo.bar.foo.com") Ns t)) ;
|
|
Alcotest.(check (result b_ok e) "lookup_b for NS foo.bar.foo.com is delegated"
|
|
(Error (`Delegation (n_of_s "bar.foo.com", (12l, sn (Domain_name.host_exn (n_of_s "ns3.bar.com"))))))
|
|
(lookup_b (n_of_s "foo.bar.foo.com") Ns t)) ;
|
|
Alcotest.(check (result l_ok e) "lookup_with_cname for AAAA foobar.boo.bar.foo.com is delegated"
|
|
(Error (`Delegation (n_of_s "bar.foo.com", (12l, sn (Domain_name.host_exn (n_of_s "ns3.bar.com"))))))
|
|
(lookup_with_cname (n_of_s "foobar.boo.bar.foo.com") Aaaa t)) ;
|
|
Alcotest.(check (result b_ok e) "lookup_b for AAAA foobar.boo.bar.foo.com is delegated"
|
|
(Error (`Delegation (n_of_s "bar.foo.com", (12l, sn (Domain_name.host_exn (n_of_s "ns3.bar.com"))))))
|
|
(lookup_b (n_of_s "foobar.boo.bar.foo.com") Aaaa t)) ;
|
|
let t = ins_zone (n_of_s "a.b.bar.foo.com") soa 10l (sn (Domain_name.host_exn (n_of_s "ns1.foo.com"))) t in
|
|
Alcotest.(check (result l_ok e) "lookup_with_cname for NS a.b.bar.foo.com is ns1.foo.com"
|
|
(Ok (Rr_map.B (Rr_map.Ns, (10l, sn (Domain_name.host_exn (n_of_s "ns1.foo.com")))),
|
|
(n_of_s "a.b.bar.foo.com", 10l, sn (Domain_name.host_exn (n_of_s "ns1.foo.com")))))
|
|
(lookup_with_cname (n_of_s "a.b.bar.foo.com") Ns t)) ;
|
|
Alcotest.(check (result b_ok e) "lookup_b for NS a.b.bar.foo.com is ns1.foo.com"
|
|
(Ok (Rr_map.B (Rr_map.Ns, (10l, sn (Domain_name.host_exn (n_of_s "ns1.foo.com"))))))
|
|
(lookup_b (n_of_s "a.b.bar.foo.com") Ns t)) ;
|
|
Alcotest.(check (result l_ok e) "lookup_with_cname for AAAA foobar.boo.bar.foo.com is delegated"
|
|
(Error (`Delegation (n_of_s "bar.foo.com", (12l, sn (Domain_name.host_exn (n_of_s "ns3.bar.com"))))))
|
|
(lookup_with_cname (n_of_s "foobar.boo.bar.foo.com") Aaaa t)) ;
|
|
Alcotest.(check (result b_ok e) "lookup_b for AAAA foobar.boo.bar.foo.com is delegated"
|
|
(Error (`Delegation (n_of_s "bar.foo.com", (12l, sn (Domain_name.host_exn (n_of_s "ns3.bar.com"))))))
|
|
(lookup_b (n_of_s "foobar.boo.bar.foo.com") Aaaa t))
|
|
|
|
let r_fst = function Ok (v, _) -> Ok (v) | Error e -> Error e
|
|
|
|
let rmzone () =
|
|
let soa = {
|
|
Soa.nameserver = n_of_s "ns1.foo.com" ;
|
|
hostmaster = n_of_s "hs.foo.com" ;
|
|
serial = 1l ; refresh = 10l ; retry = 5l ; expiry = 3l ; minimum = 4l
|
|
} in
|
|
let t =
|
|
ins_zone (n_of_s "foo.com") soa 10l (sn (n_of_s "ns1.foo.com")) empty
|
|
in
|
|
Alcotest.(check (result b_ok e) "lookup_with_cname for NS foo.com is good"
|
|
(Ok (Rr_map.B (Rr_map.Ns, (10l, sn (n_of_s "ns1.foo.com")))))
|
|
(r_fst (lookup_with_cname (n_of_s "foo.com") Ns t))) ;
|
|
Alcotest.(check (result b_ok e) "lookup_b for NS foo.com is good"
|
|
(Ok (Rr_map.B (Rr_map.Ns, (10l, sn (n_of_s "ns1.foo.com")))))
|
|
(lookup_b (n_of_s "foo.com") Ns t)) ;
|
|
let t' = remove_zone (n_of_s "foo.com") t in
|
|
Alcotest.(check (result b_ok e)
|
|
"lookup_with_cname for NS foo.com after removing zone is notauthoritative"
|
|
(Error `NotAuthoritative)
|
|
(r_fst (lookup_with_cname (n_of_s "foo.com") Ns t'))) ;
|
|
Alcotest.(check (result b_ok e)
|
|
"lookup_b for NS foo.com after removing zone is notauthoritative"
|
|
(Error `NotAuthoritative)
|
|
(lookup_b (n_of_s "foo.com") Ns t')) ;
|
|
let t =
|
|
ins_zone (n_of_s "bar.foo.com") soa 10l (sn (n_of_s "ns1.foo.com")) t
|
|
in
|
|
Alcotest.(check (result b_ok e) "lookup_with_cname for NS bar.foo.com is good"
|
|
(Ok (Rr_map.B (Rr_map.Ns, (10l, sn (n_of_s "ns1.foo.com")))))
|
|
(r_fst (lookup_with_cname (n_of_s "bar.foo.com") Ns t))) ;
|
|
Alcotest.(check (result b_ok e) "lookup_b for NS bar.foo.com is good"
|
|
(Ok (Rr_map.B (Rr_map.Ns, (10l, sn (n_of_s "ns1.foo.com")))))
|
|
(lookup_b (n_of_s "bar.foo.com") Ns t)) ;
|
|
Alcotest.(check (result b_ok e) "lookup_with_cname for NS foo.com is good"
|
|
(Ok (Rr_map.B (Rr_map.Ns, (10l, sn (n_of_s "ns1.foo.com")))))
|
|
(r_fst (lookup_with_cname (n_of_s "foo.com") Ns t))) ;
|
|
Alcotest.(check (result b_ok e) "lookup_b for NS foo.com is good"
|
|
(Ok (Rr_map.B (Rr_map.Ns, (10l, sn (n_of_s "ns1.foo.com")))))
|
|
(lookup_b (n_of_s "foo.com") Ns t)) ;
|
|
let t' = remove_zone (n_of_s "foo.com") t in
|
|
Alcotest.(check (result b_ok e)
|
|
"lookup_with_cname for NS bar.foo.com is good (after foo.com is removed)"
|
|
(Ok (Rr_map.B (Rr_map.Ns, (10l, sn (n_of_s "ns1.foo.com")))))
|
|
(r_fst (lookup_with_cname (n_of_s "bar.foo.com") Ns t'))) ;
|
|
Alcotest.(check (result b_ok e)
|
|
"lookup_b for NS bar.foo.com is good (after foo.com is removed)"
|
|
(Ok (Rr_map.B (Rr_map.Ns, (10l, sn (n_of_s "ns1.foo.com")))))
|
|
(lookup_b (n_of_s "bar.foo.com") Ns t')) ;
|
|
Alcotest.(check (result b_ok e)
|
|
"lookup_with_cname for NS foo.com is not authoritative"
|
|
(Error `NotAuthoritative)
|
|
(r_fst (lookup_with_cname (n_of_s "foo.com") Ns t'))) ;
|
|
Alcotest.(check (result b_ok e)
|
|
"lookup_b for NS foo.com is not authoritative"
|
|
(Error `NotAuthoritative)
|
|
(lookup_b (n_of_s "foo.com") Ns t')) ;
|
|
let t' = remove_zone (n_of_s "bar.foo.com") t in
|
|
Alcotest.(check (result b_ok e)
|
|
"lookup_with_cname for NS bar.foo.com is not authoritative"
|
|
(Error (`NotFound (n_of_s "foo.com", soa)))
|
|
(r_fst (lookup_with_cname (n_of_s "bar.foo.com") Ns t'))) ;
|
|
Alcotest.(check (result b_ok e)
|
|
"lookup_b for NS bar.foo.com is not authoritative"
|
|
(Error (`NotFound (n_of_s "foo.com", soa)))
|
|
(lookup_b (n_of_s "bar.foo.com") Ns t')) ;
|
|
Alcotest.(check (result b_ok e) "lookup_with_cname for NS foo.com is good"
|
|
(Ok (Rr_map.B (Rr_map.Ns, (10l, sn (n_of_s "ns1.foo.com")))))
|
|
(r_fst (lookup_with_cname (n_of_s "foo.com") Ns t'))) ;
|
|
Alcotest.(check (result b_ok e) "lookup_b for NS foo.com is good"
|
|
(Ok (Rr_map.B (Rr_map.Ns, (10l, sn (n_of_s "ns1.foo.com")))))
|
|
(lookup_b (n_of_s "foo.com") Ns t'))
|
|
|
|
let zone_ok =
|
|
let module M = struct
|
|
type t = [ `raw ] Domain_name.t * Soa.t
|
|
let pp ppf (zone, soa) =
|
|
Fmt.pf ppf "zone %a soa %a" Domain_name.pp zone Soa.pp soa
|
|
let equal (zone, soa) (zone', soa') =
|
|
Domain_name.equal zone zone' && Soa.compare soa soa' = 0
|
|
end in
|
|
(module M: Alcotest.TESTABLE with type t = M.t)
|
|
|
|
let zone () =
|
|
let soa = {
|
|
Soa.nameserver = n_of_s "ns1.foo.com" ;
|
|
hostmaster = n_of_s "hs.foo.com" ;
|
|
serial = 1l ; refresh = 10l ; retry = 5l ; expiry = 3l ; minimum = 4l
|
|
} in
|
|
let myzone = n_of_s "foo.com" in
|
|
let t =
|
|
ins_zone myzone soa 10l (sn (n_of_s "ns1.foo.com")) empty
|
|
in
|
|
Alcotest.(check (result zone_ok e) __LOC__
|
|
(Ok (myzone, soa))
|
|
(zone myzone t));
|
|
Alcotest.(check (result zone_ok e) __LOC__
|
|
(Ok (myzone, soa))
|
|
(zone (n_of_s "foobar.boo.bar.foo.com") t));
|
|
Alcotest.(check (result zone_ok e) __LOC__
|
|
(Ok (myzone, soa))
|
|
(zone (n_of_s "_bar.foo.com") t));
|
|
Alcotest.(check (result zone_ok e) __LOC__
|
|
(Error `NotAuthoritative)
|
|
(zone Domain_name.root t));
|
|
Alcotest.(check (result zone_ok e) __LOC__
|
|
(Error `NotAuthoritative)
|
|
(zone (n_of_s "bar.com") t))
|
|
|
|
let no_soa () =
|
|
let a_record = (23l, Ipaddr.V4.Set.singleton (ip "1.4.5.2")) in
|
|
let t = insert (n_of_s "ns1.foo.com") Rr_map.A a_record empty in
|
|
Alcotest.(check (result b_ok e) "lookup_with_cname for NS foo.com without SOA fails"
|
|
(Error `NotAuthoritative)
|
|
(r_fst (lookup_with_cname (n_of_s "foo.com") Ns t))) ;
|
|
Alcotest.(check (result b_ok e) "lookup_with_cname for A ns1.foo.com without SOA fails"
|
|
(Error `NotAuthoritative)
|
|
(r_fst (lookup_with_cname (n_of_s "ns1.foo.com") A t))) ;
|
|
Alcotest.(check (result b_ok e) "lookup_b for NS foo.com without SOA fails"
|
|
(Error `NotAuthoritative)
|
|
(lookup_b (n_of_s "foo.com") Ns t)) ;
|
|
Alcotest.(check (result b_ok e) "lookup_b for A ns1.foo.com without SOA fails"
|
|
(Error `NotAuthoritative)
|
|
(lookup_b (n_of_s "ns1.foo.com") A t)) ;
|
|
Alcotest.(check glue_ok "lookup_glue for ns1.foo.com without SOA finds ip"
|
|
(Some a_record, None)
|
|
(Dns_trie.lookup_glue (n_of_s "ns1.foo.com") t))
|
|
|
|
let subdomain_zone () =
|
|
let soa = {
|
|
Soa.nameserver = n_of_s "ns1.foo.com" ;
|
|
hostmaster = n_of_s "hs.foo.com" ;
|
|
serial = 1l ; refresh = 10l ; retry = 5l ; expiry = 3l ; minimum = 4l
|
|
} in
|
|
let myzone = n_of_s "foo.com" in
|
|
let t =
|
|
ins_zone myzone soa 10l (sn (n_of_s "ns1.foo.com")) empty
|
|
in
|
|
match Dns_trie.entries myzone t with
|
|
| Error _ -> Alcotest.fail "Expected some entries"
|
|
| Ok (soa, entries) ->
|
|
let sub = n_of_s "bar.foo.com"
|
|
and sub_ns = sn (n_of_s "ns2.foo.com")
|
|
in
|
|
let t = ins_zone sub soa 10l sub_ns t in
|
|
let t =
|
|
insert (n_of_s "foo.bar.foo.com")
|
|
Rr_map.A (10l, Ipaddr.V4.Set.singleton (ip "1.4.5.2")) t
|
|
in
|
|
match Dns_trie.entries myzone t with
|
|
| Error _ -> Alcotest.fail "Expected some entries"
|
|
| Ok (soa', entries') ->
|
|
Alcotest.(check bool "SOA is the same" true (Soa.compare soa' soa = 0));
|
|
let entries'' =
|
|
match Domain_name.Map.find sub entries' with
|
|
| Some rr ->
|
|
Alcotest.(check int "exactly one rr (delegation)" 1 (Rr_map.cardinal rr));
|
|
Alcotest.(check bool "it is the NS" true
|
|
(Rr_map.equal_rr Ns (Rr_map.get Ns rr) (10l, sub_ns)));
|
|
Domain_name.Map.remove sub entries'
|
|
| None -> Alcotest.fail "expected a NS record"
|
|
in
|
|
Alcotest.(check bool "rrs are the same" true
|
|
(Name_rr_map.equal entries entries''))
|
|
|
|
let tests = [
|
|
"simple", `Quick, simple ;
|
|
"basic", `Quick, basic ;
|
|
"alias", `Quick, alias ;
|
|
"delegation", `Quick, dele ;
|
|
"rmzone", `Quick, rmzone ;
|
|
"zone", `Quick, zone ;
|
|
"no soa", `Quick, no_soa ;
|
|
"subdomain and entries", `Quick, subdomain_zone ;
|
|
]
|
|
end
|
|
|
|
module S = struct
|
|
|
|
let ipv4 =
|
|
let module M = struct
|
|
type t = Ipaddr.V4.t
|
|
let pp = Ipaddr.V4.pp
|
|
let equal a b = Ipaddr.V4.compare a b = 0
|
|
end in
|
|
(module M : Alcotest.TESTABLE with type t = M.t)
|
|
|
|
let ip =
|
|
let module M = struct
|
|
type t = Ipaddr.t
|
|
let pp = Ipaddr.pp
|
|
let equal a b = Ipaddr.compare a b = 0
|
|
end in
|
|
(module M : Alcotest.TESTABLE with type t = M.t)
|
|
|
|
let ipset = Alcotest.(slist ip Ipaddr.compare)
|
|
|
|
let ipv4_of_s = Ipaddr.V4.of_string_exn
|
|
|
|
let ip_of_s s = Ipaddr.V4 (ipv4_of_s s)
|
|
|
|
let ts = Duration.of_sec 5
|
|
|
|
let data =
|
|
let ns = Domain_name.host_exn (n_of_s "ns.one.com") in
|
|
let soa = Soa.create ~serial:1l ns in
|
|
Dns_trie.insert (n_of_s "one.com") Rr_map.Soa soa
|
|
(Dns_trie.insert (n_of_s "one.com") Rr_map.Ns (300l, Domain_name.Host_set.singleton ns)
|
|
(Dns_trie.insert ns Rr_map.A (300l, Ipaddr.V4.Set.singleton Ipaddr.V4.localhost)
|
|
Dns_trie.empty))
|
|
|
|
let simple () =
|
|
let server = Dns_server.Primary.create ~rng:Mirage_crypto_rng.generate data in
|
|
let _, notifications = Dns_server.Primary.timer server Ptime.epoch ts in
|
|
Alcotest.(check int __LOC__ 0 (List.length notifications));
|
|
let tbn = Dns_server.Primary.to_be_notified server (Domain_name.host_exn (n_of_s "one.com")) in
|
|
Alcotest.(check int __LOC__ 0 (List.length tbn));
|
|
let tbn = Dns_server.Primary.to_be_notified server Domain_name.(host_exn root) in
|
|
Alcotest.(check int __LOC__ 0 (List.length tbn))
|
|
|
|
let secondary () =
|
|
let data =
|
|
let ns =
|
|
Domain_name.(Host_set.(add (host_exn (n_of_s "ns.one.com"))
|
|
(singleton (host_exn (n_of_s "ns2.one.com")))))
|
|
in
|
|
Dns_trie.insert (n_of_s "one.com") Rr_map.Ns (300l, ns)
|
|
(Dns_trie.insert (n_of_s "ns2.one.com") Rr_map.A
|
|
(300l, Ipaddr.V4.Set.singleton (ipv4_of_s "10.0.0.2")) data)
|
|
in
|
|
let server = Dns_server.Primary.create ~rng:Mirage_crypto_rng.generate data in
|
|
let _, notifications = Dns_server.Primary.timer server Ptime.epoch ts in
|
|
Alcotest.(check int __LOC__ 1 (List.length notifications));
|
|
let tbn = Dns_server.Primary.to_be_notified server (Domain_name.host_exn (n_of_s "one.com")) in
|
|
Alcotest.(check int __LOC__ 1 (List.length tbn));
|
|
Alcotest.check ipset __LOC__ [ip_of_s "10.0.0.2"] (List.map fst tbn)
|
|
|
|
let secondary_in_other_zone () =
|
|
let data =
|
|
let ns =
|
|
Domain_name.(Host_set.(add (host_exn (n_of_s "ns.one.com"))
|
|
(singleton (host_exn (n_of_s "ns2.two.com")))))
|
|
in
|
|
Dns_trie.insert (n_of_s "one.com") Rr_map.Ns (300l, ns)
|
|
(Dns_trie.insert (n_of_s "ns2.two.com") Rr_map.A
|
|
(300l, Ipaddr.V4.Set.singleton (ipv4_of_s "10.0.0.2")) data)
|
|
in
|
|
let server = Dns_server.Primary.create ~rng:Mirage_crypto_rng.generate data in
|
|
let _, notifications = Dns_server.Primary.timer server Ptime.epoch ts in
|
|
Alcotest.(check int __LOC__ 1 (List.length notifications));
|
|
let tbn = Dns_server.Primary.to_be_notified server (Domain_name.host_exn (n_of_s "one.com")) in
|
|
Alcotest.(check int __LOC__ 1 (List.length tbn));
|
|
Alcotest.check ipset __LOC__ [ip_of_s "10.0.0.2"] (List.map fst tbn)
|
|
|
|
let multiple_ips_secondary () =
|
|
let data =
|
|
let ns =
|
|
Domain_name.(Host_set.(add (host_exn (n_of_s "ns.one.com"))
|
|
(singleton (host_exn (n_of_s "ns2.one.com")))))
|
|
and ips =
|
|
Ipaddr.V4.Set.(add (ipv4_of_s "10.0.0.2") (singleton (ipv4_of_s "1.2.3.4")))
|
|
in
|
|
Dns_trie.insert (n_of_s "one.com") Rr_map.Ns (300l, ns)
|
|
(Dns_trie.insert (n_of_s "ns2.one.com") Rr_map.A (300l, ips) data)
|
|
in
|
|
let server = Dns_server.Primary.create ~rng:Mirage_crypto_rng.generate data in
|
|
let _, notifications = Dns_server.Primary.timer server Ptime.epoch ts in
|
|
Alcotest.(check int __LOC__ 2 (List.length notifications));
|
|
let tbn = Dns_server.Primary.to_be_notified server (Domain_name.host_exn (n_of_s "one.com")) in
|
|
Alcotest.(check int __LOC__ 2 (List.length tbn));
|
|
Alcotest.check ipset __LOC__ [ip_of_s "10.0.0.2" ; ip_of_s "1.2.3.4"] (List.map fst tbn)
|
|
|
|
let multiple_secondaries () =
|
|
let data' =
|
|
let ns =
|
|
Domain_name.(Host_set.(add (host_exn (n_of_s "ns.one.com"))
|
|
(add (host_exn (n_of_s "ns2.one.com"))
|
|
(singleton (host_exn (n_of_s "ns3.one.com"))))))
|
|
in
|
|
Dns_trie.insert (n_of_s "one.com") Rr_map.Ns (300l, ns)
|
|
(Dns_trie.insert (n_of_s "ns2.one.com") Rr_map.A
|
|
(300l, Ipaddr.V4.Set.singleton (ipv4_of_s "10.0.0.2"))
|
|
(Dns_trie.insert (n_of_s "ns3.one.com") Rr_map.A
|
|
(300l, Ipaddr.V4.Set.singleton (ipv4_of_s "10.0.0.3"))
|
|
data))
|
|
in
|
|
let server = Dns_server.Primary.create ~rng:Mirage_crypto_rng.generate data' in
|
|
let _, notifications = Dns_server.Primary.timer server Ptime.epoch ts in
|
|
Alcotest.(check int __LOC__ 2 (List.length notifications));
|
|
let tbn = Dns_server.Primary.to_be_notified server (Domain_name.host_exn (n_of_s "one.com")) in
|
|
Alcotest.(check int __LOC__ 2 (List.length tbn));
|
|
Alcotest.check ipset __LOC__ [ip_of_s "10.0.0.2";ip_of_s "10.0.0.3"]
|
|
(List.map fst tbn)
|
|
|
|
let multiple_secondaries_dups () =
|
|
let data' =
|
|
let ns =
|
|
Domain_name.(Host_set.(add (host_exn (n_of_s "ns.one.com"))
|
|
(add (host_exn (n_of_s "ns2.one.com"))
|
|
(singleton (host_exn (n_of_s "ns3.one.com"))))))
|
|
in
|
|
Dns_trie.insert (n_of_s "one.com") Rr_map.Ns (300l, ns)
|
|
(Dns_trie.insert (n_of_s "ns2.one.com") Rr_map.A
|
|
(300l, Ipaddr.V4.Set.(add (ipv4_of_s "10.0.0.2") (singleton (ipv4_of_s "10.0.0.3"))))
|
|
(Dns_trie.insert (n_of_s "ns3.one.com") Rr_map.A
|
|
(300l, Ipaddr.V4.Set.(add (ipv4_of_s "10.0.0.3") (singleton (ipv4_of_s "10.0.0.4"))))
|
|
data))
|
|
in
|
|
let server = Dns_server.Primary.create ~rng:Mirage_crypto_rng.generate data' in
|
|
let _, notifications = Dns_server.Primary.timer server Ptime.epoch ts in
|
|
Alcotest.(check int __LOC__ 3 (List.length notifications));
|
|
let tbn = Dns_server.Primary.to_be_notified server (Domain_name.host_exn (n_of_s "one.com")) in
|
|
Alcotest.(check int __LOC__ 3 (List.length tbn));
|
|
Alcotest.check ipset __LOC__ [ip_of_s "10.0.0.2";ip_of_s "10.0.0.3";ip_of_s "10.0.0.4"]
|
|
(List.map fst tbn)
|
|
|
|
let secondaries_in_other_zone () =
|
|
let data =
|
|
let ns =
|
|
Domain_name.(Host_set.(add (host_exn (n_of_s "ns.one.com"))
|
|
(add (host_exn (n_of_s "ns.foo.com"))
|
|
(singleton (host_exn (n_of_s "ns.bar.com"))))))
|
|
in
|
|
let soa = Soa.create (Domain_name.host_exn (n_of_s "ns.one.com"))
|
|
and soa' = Soa.create (Domain_name.host_exn (n_of_s "ns.foo.com"))
|
|
and soa'' = Soa.create (Domain_name.host_exn (n_of_s "ns.bar.com"))
|
|
in
|
|
Dns_trie.insert (n_of_s "one.com") Rr_map.Ns (300l, ns)
|
|
(Dns_trie.insert (n_of_s "one.com") Rr_map.Soa soa
|
|
(Dns_trie.insert (n_of_s "foo.com") Rr_map.Soa soa'
|
|
(Dns_trie.insert (n_of_s "bar.com") Rr_map.Soa soa''
|
|
(Dns_trie.insert (n_of_s "ns.foo.com") Rr_map.A
|
|
(300l, Ipaddr.V4.Set.singleton (ipv4_of_s "10.0.0.2"))
|
|
(Dns_trie.insert (n_of_s "ns.bar.com") Rr_map.A
|
|
(300l, Ipaddr.V4.Set.singleton (ipv4_of_s "10.0.0.3"))
|
|
(Dns_trie.insert (n_of_s "ns.one.com") Rr_map.A
|
|
(300l, Ipaddr.V4.Set.singleton (ipv4_of_s "10.0.0.4"))
|
|
Dns_trie.empty))))))
|
|
in
|
|
let server = Dns_server.Primary.create ~rng:Mirage_crypto_rng.generate data in
|
|
let _, notifications = Dns_server.Primary.timer server Ptime.epoch ts in
|
|
Alcotest.(check int __LOC__ 2 (List.length notifications));
|
|
let tbn = Dns_server.Primary.to_be_notified server (Domain_name.host_exn (n_of_s "one.com")) in
|
|
Alcotest.(check int __LOC__ 2 (List.length tbn));
|
|
Alcotest.check ipset __LOC__ [ip_of_s "10.0.0.2";ip_of_s "10.0.0.3"]
|
|
(List.map fst tbn)
|
|
|
|
let secondary_via_key () =
|
|
let keys =
|
|
[ n_of_s "1.2.3.4.5.6.7.8._transfer.one.com",
|
|
{ Dnskey.flags = Dnskey.F.empty ; algorithm = SHA256 ; key = String.make 10 '\000' } ]
|
|
in
|
|
let server = Dns_server.Primary.create ~rng:Mirage_crypto_rng.generate ~keys data in
|
|
let _, notifications = Dns_server.Primary.timer server Ptime.epoch ts in
|
|
Alcotest.(check int __LOC__ 1 (List.length notifications));
|
|
let tbn = Dns_server.Primary.to_be_notified server (Domain_name.host_exn (n_of_s "one.com")) in
|
|
Alcotest.(check int __LOC__ 1 (List.length tbn));
|
|
Alcotest.check ipset __LOC__ [ip_of_s "5.6.7.8"] (List.map fst tbn)
|
|
|
|
let secondary_via_root_key () =
|
|
let keys =
|
|
[ n_of_s "1.2.3.4.5.6.7.8._transfer",
|
|
{ Dnskey.flags = Dnskey.F.empty ; algorithm = SHA256 ; key = String.make 10 '\000' } ]
|
|
in
|
|
let server = Dns_server.Primary.create ~rng:Mirage_crypto_rng.generate ~keys data in
|
|
let _, notifications = Dns_server.Primary.timer server Ptime.epoch ts in
|
|
Alcotest.(check int __LOC__ 1 (List.length notifications));
|
|
let tbn = Dns_server.Primary.to_be_notified server (Domain_name.host_exn (n_of_s "one.com")) in
|
|
Alcotest.(check int __LOC__ 1 (List.length tbn));
|
|
Alcotest.check ipset __LOC__ [ip_of_s "5.6.7.8"] (List.map fst tbn)
|
|
|
|
let secondaries_and_keys () =
|
|
let keys =
|
|
[ n_of_s "1.2.3.4.5.6.7.8._transfer.one.com",
|
|
{ Dnskey.flags = Dnskey.F.empty ; algorithm = SHA256 ; key = String.make 10 '\000' } ]
|
|
in
|
|
let data' =
|
|
let ns =
|
|
Domain_name.(Host_set.(add (host_exn (n_of_s "ns3.one.com"))
|
|
(add (host_exn (n_of_s "ns2.one.com"))
|
|
(singleton (host_exn (n_of_s "ns.one.com"))))))
|
|
in
|
|
Dns_trie.insert (n_of_s "one.com") Rr_map.Ns (300l, ns)
|
|
(Dns_trie.insert (n_of_s "ns2.one.com") Rr_map.A
|
|
(300l, Ipaddr.V4.Set.singleton (ipv4_of_s "1.1.1.1"))
|
|
(Dns_trie.insert (n_of_s "ns3.one.com") Rr_map.A
|
|
(300l, Ipaddr.V4.Set.(add (ipv4_of_s "10.0.0.1") (singleton (ipv4_of_s "192.168.1.1"))))
|
|
data))
|
|
in
|
|
let server = Dns_server.Primary.create ~rng:Mirage_crypto_rng.generate ~keys data' in
|
|
let _, notifications = Dns_server.Primary.timer server Ptime.epoch ts in
|
|
Alcotest.(check int __LOC__ 4 (List.length notifications));
|
|
let tbn = Dns_server.Primary.to_be_notified server (Domain_name.host_exn (n_of_s "one.com")) in
|
|
Alcotest.(check int __LOC__ 4 (List.length tbn));
|
|
Alcotest.check ipset __LOC__ [ip_of_s "1.1.1.1" ; ip_of_s "5.6.7.8" ; ip_of_s "10.0.0.1" ; ip_of_s "192.168.1.1"]
|
|
(List.map fst tbn)
|
|
|
|
let secondaries_and_keys_dups () =
|
|
let keys =
|
|
[ n_of_s "1.2.3.4.5.6.7.8._transfer.one.com",
|
|
{ Dnskey.flags = Dnskey.F.empty ; algorithm = SHA256 ; key = String.make 10 '\000' } ]
|
|
in
|
|
let data' =
|
|
let ns =
|
|
Domain_name.(Host_set.(add (host_exn (n_of_s "ns3.one.com"))
|
|
(add (host_exn (n_of_s "ns2.one.com"))
|
|
(singleton (host_exn (n_of_s "ns.one.com"))))))
|
|
in
|
|
Dns_trie.insert (n_of_s "one.com") Rr_map.Ns (300l, ns)
|
|
(Dns_trie.insert (n_of_s "ns2.one.com") Rr_map.A
|
|
(300l, Ipaddr.V4.Set.singleton (ipv4_of_s "5.6.7.8"))
|
|
(Dns_trie.insert (n_of_s "ns3.one.com") Rr_map.A
|
|
(300l, Ipaddr.V4.Set.(add (ipv4_of_s "10.0.0.1") (singleton (ipv4_of_s "192.168.1.1"))))
|
|
data))
|
|
in
|
|
let server = Dns_server.Primary.create ~rng:Mirage_crypto_rng.generate ~keys data' in
|
|
let _, notifications = Dns_server.Primary.timer server Ptime.epoch ts in
|
|
Alcotest.(check int __LOC__ 3 (List.length notifications));
|
|
let tbn = Dns_server.Primary.to_be_notified server (Domain_name.host_exn (n_of_s "one.com")) in
|
|
Alcotest.(check int __LOC__ 3 (List.length tbn));
|
|
Alcotest.check ipset __LOC__ [ip_of_s "5.6.7.8" ; ip_of_s "10.0.0.1" ; ip_of_s "192.168.1.1"]
|
|
(List.map fst tbn)
|
|
|
|
(* TODO more testing:
|
|
- passive secondaries (tsig-signed SOA request)
|
|
- ensure that with_data and update (handle_packet) actually notifies the to-be-notified
|
|
- interaction of/with secondary (bootup, IXFR/AXFR, add/remove zone for root transfer keys, ...)
|
|
*)
|
|
|
|
let multiple_zones () =
|
|
let keys =
|
|
[ n_of_s "1.2.3.4.9.10.11.12._transfer",
|
|
{ Dnskey.flags = Dnskey.F.empty ; algorithm = SHA256 ; key = String.make 10 '\000' } ]
|
|
in
|
|
let data' =
|
|
let ns = Domain_name.(host_exn (n_of_s "ns.one.com")) in
|
|
let ns' = Domain_name.Host_set.singleton ns
|
|
and soa = Soa.create ~serial:1l ns
|
|
in
|
|
Dns_trie.insert (n_of_s "two.com") Rr_map.Ns (300l, ns')
|
|
(Dns_trie.insert (n_of_s "two.com") Rr_map.Soa soa data)
|
|
in
|
|
let server = Dns_server.Primary.create ~rng:Mirage_crypto_rng.generate ~keys data' in
|
|
let s', notifications = Dns_server.Primary.timer server Ptime.epoch ts in
|
|
Alcotest.(check int __LOC__ 1 (List.length notifications));
|
|
Alcotest.(check int __LOC__ 2 (List.length (snd (List.hd notifications))));
|
|
let tbn = Dns_server.Primary.to_be_notified server (Domain_name.host_exn (n_of_s "one.com")) in
|
|
Alcotest.(check int __LOC__ 1 (List.length tbn));
|
|
let tbn = Dns_server.Primary.to_be_notified server (Domain_name.host_exn (n_of_s "two.com")) in
|
|
Alcotest.(check int __LOC__ 1 (List.length tbn));
|
|
let s'', notifications = Dns_server.Primary.timer s' Ptime.epoch (Int64.add ts 1L) in
|
|
Alcotest.(check int __LOC__ 0 (List.length notifications));
|
|
let _, notifications = Dns_server.Primary.timer s' Ptime.epoch (Int64.add ts (Duration.of_ms 700)) in
|
|
Alcotest.(check int __LOC__ 0 (List.length notifications));
|
|
let _, notifications = Dns_server.Primary.timer s' Ptime.epoch (Int64.add ts (Duration.of_sec 1)) in
|
|
Alcotest.(check int __LOC__ 1 (List.length notifications));
|
|
Alcotest.(check int __LOC__ 2 (List.length (snd (List.hd notifications))));
|
|
let _, notifications = Dns_server.Primary.timer s'' Ptime.epoch (Int64.add ts (Duration.of_sec 2)) in
|
|
Alcotest.(check int __LOC__ 1 (List.length notifications));
|
|
Alcotest.(check int __LOC__ 2 (List.length (snd (List.hd notifications))))
|
|
|
|
let test_secondary () =
|
|
let keys =
|
|
let key = String.make 32 '\000' |> Base64.encode_string in
|
|
[ n_of_s "1.2.3.4.9.10.11.12._transfer.one.com",
|
|
{ Dnskey.flags = Dnskey.F.empty ; algorithm = SHA256 ; key } ]
|
|
in
|
|
let s =
|
|
Dns_server.Secondary.create ~rng:Mirage_crypto_rng.generate
|
|
~tsig_verify:Dns_tsig.verify ~tsig_sign:Dns_tsig.sign keys
|
|
in
|
|
let s', reqs = Dns_server.Secondary.timer s Ptime.epoch ts in
|
|
Alcotest.(check int __LOC__ 1 (List.length reqs));
|
|
Alcotest.(check int __LOC__ 1 (List.length (snd (List.hd reqs))));
|
|
let s'', reqs' = Dns_server.Secondary.timer s' Ptime.epoch (Int64.add ts (Duration.of_sec 2)) in
|
|
Alcotest.(check int __LOC__ 0 (List.length reqs'));
|
|
let _s'', reqs'' = Dns_server.Secondary.timer s'' Ptime.epoch (Int64.add ts (Duration.of_sec 3)) in
|
|
Alcotest.(check int __LOC__ 1 (List.length reqs''));
|
|
Alcotest.(check int __LOC__ 1 (List.length (snd (List.hd reqs''))))
|
|
|
|
let tests = [
|
|
"simple", `Quick, simple ;
|
|
"secondary", `Quick, secondary ;
|
|
"secondary in non-authoritative zone", `Quick, secondary_in_other_zone ;
|
|
"multiple IPs of secondary", `Quick, multiple_ips_secondary ;
|
|
"multiple secondaries", `Quick, multiple_secondaries ;
|
|
"multiple secondaries with duplicates", `Quick, multiple_secondaries_dups ;
|
|
"secondaries in other zone", `Quick, secondaries_in_other_zone ;
|
|
"secondary via key", `Quick, secondary_via_key ;
|
|
"secondary via root key", `Quick, secondary_via_root_key ;
|
|
"secondaries and keys", `Quick, secondaries_and_keys ;
|
|
"secondaries and keys dups", `Quick, secondaries_and_keys_dups ;
|
|
"multiple zones", `Quick, multiple_zones ;
|
|
"secondary create", `Quick, test_secondary ;
|
|
]
|
|
end
|
|
|
|
module A = struct
|
|
open Dns_server
|
|
|
|
let access_granted () =
|
|
(* a list of "required" "provided" "expected result" *)
|
|
let operations_and_permissions = [
|
|
`Update, `Update, true ;
|
|
`Transfer, `Update, true ;
|
|
`Notify, `Update, true ;
|
|
|
|
`Update, `Transfer, false ;
|
|
`Transfer, `Transfer, true ;
|
|
`Notify, `Transfer, true ;
|
|
|
|
`Update, `Notify, false ;
|
|
`Transfer, `Notify, false ;
|
|
`Notify, `Notify, true ;
|
|
] in
|
|
List.iteri (fun i (required, provided, exp) ->
|
|
Alcotest.(check bool (__LOC__ ^ " test #" ^ string_of_int i) exp
|
|
(Authentication.access_granted ~required provided)))
|
|
operations_and_permissions
|
|
|
|
let test_zone_op =
|
|
let module M = struct
|
|
type t = [`host] Domain_name.t * Authentication.operation
|
|
let equal (n, op) (n', op') = Domain_name.equal n n' && op = op'
|
|
let pp ppf (n, op) =
|
|
Fmt.pf ppf "zone %a op %s" Domain_name.pp n
|
|
(Authentication.operation_to_string op)
|
|
end in
|
|
(module M: Alcotest.TESTABLE with type t = M.t)
|
|
|
|
let host n = n_of_s n |> Domain_name.host_exn
|
|
|
|
let zone_and_op () =
|
|
(* a list of Domain_name.t and the expected zone and operation, if any *)
|
|
let test_values = [
|
|
Domain_name.root, None ;
|
|
n_of_s "foo.com", None ;
|
|
n_of_s "this.is.my.transfer.or.update.or.notify.foo.com", None ;
|
|
n_of_s "this.is.my.transfer.or._update._or.notify.foo.com", None ;
|
|
n_of_s "this.is.my.transfer.or._update.or.notify.foo.com", Some (host "or.notify.foo.com", `Update) ;
|
|
n_of_s "_transfer.foo.com", Some (host "foo.com", `Transfer) ;
|
|
n_of_s "_update._transfer", Some (host "", `Transfer) ;
|
|
n_of_s "_update.foo._transfer.com", Some (host "com", `Transfer) ;
|
|
n_of_s "_notify.foo._update.com", Some (host "com", `Update) ;
|
|
n_of_s "_update.foo._notify.com", Some (host "com", `Notify) ;
|
|
n_of_s "_transfer.foo._notify.com", Some (host "com", `Notify) ;
|
|
n_of_s "_transfer.foo.notify.com", Some (host "foo.notify.com", `Transfer) ;
|
|
] in
|
|
List.iteri (fun i (name, exp) ->
|
|
Alcotest.(check (option test_zone_op)
|
|
(__LOC__ ^ " test #" ^ string_of_int i) exp
|
|
(Authentication.zone_and_operation name)))
|
|
test_values
|
|
|
|
(* authentication tests *)
|
|
let simple_deny () =
|
|
List.iter (fun zone ->
|
|
List.iter (fun op ->
|
|
Alcotest.(check bool __LOC__ false
|
|
(Authentication.access op ~zone)))
|
|
Authentication.all_ops)
|
|
[ Domain_name.root ; Domain_name.of_string_exn "example.com" ;
|
|
Domain_name.of_string_exn "foo.bar.com" ]
|
|
|
|
let simple_allow () =
|
|
List.iteri (fun i (op, zone, key, res) ->
|
|
Alcotest.(check bool ("simple allow " ^ string_of_int i) res
|
|
(Authentication.access ~key ~zone op)))
|
|
(List.map
|
|
(fun (a, b, c, d) -> a, Domain_name.of_string_exn b, Domain_name.of_string_exn c, d)
|
|
[
|
|
(`Notify, "example.com", "foo._notify", true) ;
|
|
(`Transfer, "example.com", "foo._notify", false) ;
|
|
(`Update, "example.com", "foo._notify", false) ;
|
|
(`Notify, "example.com", "foo._transfer", true) ;
|
|
(`Transfer, "example.com", "foo._transfer", true) ;
|
|
(`Update, "example.com", "foo._transfer", false) ;
|
|
(`Notify, "example.com", "foo._update", true) ;
|
|
(`Transfer, "example.com", "foo._update", true) ;
|
|
(`Update, "example.com", "foo._update", true) ;
|
|
|
|
(`Notify, "example.com", "foo._notify.example.com", true) ;
|
|
(`Transfer, "example.com", "foo._notify.example.com", false) ;
|
|
(`Update, "example.com", "foo._notify.example.com", false) ;
|
|
(`Notify, "example.com", "foo._transfer.example.com", true) ;
|
|
(`Transfer, "example.com", "foo._transfer.example.com", true) ;
|
|
(`Update, "example.com", "foo._transfer.example.com", false) ;
|
|
(`Notify, "example.com", "foo._update.example.com", true) ;
|
|
(`Transfer, "example.com", "foo._update.example.com", true) ;
|
|
(`Update, "example.com", "foo._update.example.com", true) ;
|
|
|
|
(`Notify, "foo.example.com", "foo._notify.example.com", true) ;
|
|
(`Transfer, "foo.example.com", "foo._notify.example.com", false) ;
|
|
(`Update, "foo.example.com", "foo._notify.example.com", false) ;
|
|
(`Notify, "foo.example.com", "foo._transfer.example.com", true) ;
|
|
(`Transfer, "foo.example.com", "foo._transfer.example.com", true) ;
|
|
(`Update, "foo.example.com", "foo._transfer.example.com", false) ;
|
|
(`Notify, "foo.example.com", "foo._update.example.com", true) ;
|
|
(`Transfer, "foo.example.com", "foo._update.example.com", true) ;
|
|
(`Update, "foo.example.com", "foo._update.example.com", true) ;
|
|
|
|
(`Notify, "example2.com", "foo._notify.example.com", false) ;
|
|
(`Transfer, "example2.com", "foo._notify.example.com", false) ;
|
|
(`Update, "example2.com", "foo._notify.example.com", false) ;
|
|
(`Notify, "example2.com", "foo._transfer.example.com", false) ;
|
|
(`Transfer, "example2.com", "foo._transfer.example.com", false) ;
|
|
(`Update, "example2.com", "foo._transfer.example.com", false) ;
|
|
(`Notify, "example2.com", "foo._update.example.com", false) ;
|
|
(`Transfer, "example2.com", "foo._update.example.com", false) ;
|
|
(`Update, "example2.com", "foo._update.example.com", false) ;
|
|
|
|
(`Notify, "com", "foo._notify.example.com", false) ;
|
|
(`Transfer, "com", "foo._notify.example.com", false) ;
|
|
(`Update, "com", "foo._notify.example.com", false) ;
|
|
(`Notify, "com", "foo._transfer.example.com", false) ;
|
|
(`Transfer, "com", "foo._transfer.example.com", false) ;
|
|
(`Update, "com", "foo._transfer.example.com", false) ;
|
|
(`Notify, "com", "foo._update.example.com", false) ;
|
|
(`Transfer, "com", "foo._update.example.com", false) ;
|
|
(`Update, "com", "foo._update.example.com", false) ;
|
|
|
|
(`Notify, "", "foo._notify.example.com", false) ;
|
|
(`Transfer, "", "foo._notify.example.com", false) ;
|
|
(`Update, "", "foo._notify.example.com", false) ;
|
|
(`Notify, "", "foo._transfer.example.com", false) ;
|
|
(`Transfer, "", "foo._transfer.example.com", false) ;
|
|
(`Update, "", "foo._transfer.example.com", false) ;
|
|
(`Notify, "", "foo._update.example.com", false) ;
|
|
(`Transfer, "", "foo._update.example.com", false) ;
|
|
(`Update, "", "foo._update.example.com", false) ;
|
|
])
|
|
|
|
let axfr_test = Alcotest.testable Packet.Axfr.pp Packet.Axfr.equal
|
|
|
|
let rcode_test = Alcotest.testable Rcode.pp (fun a b -> Rcode.compare a b = 0)
|
|
|
|
let ip_of_s = Ipaddr.V4.of_string_exn
|
|
|
|
let soa = Soa.create ~serial:1l (Domain_name.host_exn (n_of_s "ns.one.com"))
|
|
|
|
let example_ns =
|
|
Domain_name.(Host_set.(add (host_exn (n_of_s "ns3.one.com"))
|
|
(add (host_exn (n_of_s "ns2.one.com"))
|
|
(singleton (host_exn (n_of_s "ns.one.com"))))))
|
|
let example_zone =
|
|
Name_rr_map.(add (n_of_s "one.com") Rr_map.Ns (300l, example_ns)
|
|
(add (n_of_s "ns.one.com") Rr_map.A
|
|
(300l, Ipaddr.V4.Set.singleton (ip_of_s "1.2.3.4"))
|
|
(add (n_of_s "ns2.one.com") Rr_map.A
|
|
(300l, Ipaddr.V4.Set.singleton (ip_of_s "5.6.7.8"))
|
|
(add (n_of_s "ns3.one.com") Rr_map.A
|
|
(300l, Ipaddr.V4.Set.(add (ip_of_s "10.0.0.1") (singleton (ip_of_s "192.168.1.1"))))
|
|
empty))))
|
|
|
|
let example_trie =
|
|
Dns_trie.insert (n_of_s "one.com") Soa soa
|
|
(Dns_trie.insert_map example_zone Dns_trie.empty)
|
|
|
|
let server ?unauthenticated_zone_transfer () =
|
|
let p = Primary.create ~rng:Mirage_crypto_rng.generate ?unauthenticated_zone_transfer example_trie in
|
|
Primary.server p
|
|
|
|
let answer_test = Alcotest.testable Packet.Answer.pp Packet.Answer.equal
|
|
|
|
let h_q_test =
|
|
let fl_test =
|
|
let module M = struct
|
|
type t = Packet.Flags.t
|
|
let pp ppf t = Fmt.(list ~sep:(any ",") Packet.Flag.pp) ppf (Packet.Flags.elements t)
|
|
let equal = Packet.Flags.equal
|
|
end in
|
|
(module M: Alcotest.TESTABLE with type t = M.t)
|
|
in
|
|
Alcotest.(result (pair fl_test answer_test)
|
|
(pair rcode_test (option answer_test)))
|
|
|
|
(* TODO test additional as well *)
|
|
let h_q t q =
|
|
match handle_question t q with Ok (a, b, _) -> Ok (a, b) | Error e -> Error e
|
|
|
|
let question () =
|
|
let server = server () in
|
|
let query = Packet.Question.create (n_of_s "one.com") Soa in
|
|
let answer = Name_rr_map.singleton (n_of_s "one.com") Soa soa
|
|
and auth = Name_rr_map.singleton (n_of_s "one.com") Ns (300l, example_ns)
|
|
in
|
|
Alcotest.(check h_q_test __LOC__
|
|
(Ok (Packet.Flags.singleton `Authoritative, (answer, auth)))
|
|
(h_q server query));
|
|
let query = Packet.Question.create (n_of_s "ns.one.com") A in
|
|
let answer =
|
|
Name_rr_map.singleton (n_of_s "ns.one.com") A
|
|
(300l, Ipaddr.V4.Set.singleton (ip_of_s "1.2.3.4"))
|
|
in
|
|
Alcotest.(check h_q_test __LOC__
|
|
(Ok (Packet.Flags.singleton `Authoritative, (answer, auth)))
|
|
(h_q server query));
|
|
let query = Packet.Question.create (n_of_s "one.com") Mx in
|
|
let answer = Name_rr_map.empty
|
|
and auth = Name_rr_map.singleton (n_of_s "one.com") Soa soa
|
|
in
|
|
Alcotest.(check h_q_test __LOC__
|
|
(Ok (Packet.Flags.singleton `Authoritative, (answer, auth)))
|
|
(h_q server query));
|
|
let query = Packet.Question.create (n_of_s "foo.one.com") Mx in
|
|
Alcotest.(check h_q_test __LOC__
|
|
(Error (Rcode.NXDomain, Some (answer, auth)))
|
|
(h_q server query));
|
|
let query = Packet.Question.create (n_of_s "one.com") Ns in
|
|
let answer = Name_rr_map.singleton (n_of_s "one.com") Ns (300l, example_ns)
|
|
and auth = Name_rr_map.empty
|
|
in
|
|
Alcotest.(check h_q_test __LOC__
|
|
(Ok (Packet.Flags.singleton `Authoritative, (answer, auth)))
|
|
(h_q server query));
|
|
let query = Packet.Question.create (n_of_s "two.com") Ns in
|
|
Alcotest.(check h_q_test __LOC__
|
|
(Error (Rcode.NotAuth, None))
|
|
(h_q server query))
|
|
|
|
let axfr () =
|
|
let server = server () in
|
|
let axfr = soa, example_zone in
|
|
let axfr_req = n_of_s "one.com", `Axfr in
|
|
let key = Some (n_of_s "foo._transfer.one.com") in
|
|
Alcotest.(check (result axfr_test rcode_test) __LOC__ (Ok axfr)
|
|
(handle_axfr_request server `Tcp key axfr_req));
|
|
Alcotest.(check (result axfr_test rcode_test) __LOC__ (Error Rcode.Refused)
|
|
(handle_axfr_request server `Udp key axfr_req));
|
|
Alcotest.(check (result axfr_test rcode_test) __LOC__ (Error Rcode.NotAuth)
|
|
(handle_axfr_request server `Tcp None axfr_req));
|
|
let key = Some (n_of_s "foo._notify.one.com") in
|
|
Alcotest.(check (result axfr_test rcode_test) __LOC__ (Error Rcode.NotAuth)
|
|
(handle_axfr_request server `Tcp key axfr_req));
|
|
let key = Some (n_of_s "foo._update.one.com") in
|
|
Alcotest.(check (result axfr_test rcode_test) __LOC__ (Ok axfr)
|
|
(handle_axfr_request server `Tcp key axfr_req));
|
|
let key = Some (n_of_s "foo._transfer.two.com") in
|
|
Alcotest.(check (result axfr_test rcode_test) __LOC__ (Error Rcode.NotAuth)
|
|
(handle_axfr_request server `Tcp key axfr_req));
|
|
let key = Some (n_of_s "foo._transfer.com") in
|
|
Alcotest.(check (result axfr_test rcode_test) __LOC__ (Ok axfr)
|
|
(handle_axfr_request server `Tcp key axfr_req));
|
|
let key = Some (n_of_s "foo._transfer") in
|
|
Alcotest.(check (result axfr_test rcode_test) __LOC__ (Ok axfr)
|
|
(handle_axfr_request server `Tcp key axfr_req));
|
|
let key = Some (n_of_s "foo._transfer.sub.one.com") in
|
|
Alcotest.(check (result axfr_test rcode_test) __LOC__ (Error Rcode.NotAuth)
|
|
(handle_axfr_request server `Tcp key axfr_req))
|
|
|
|
let no_axfr () =
|
|
let server = server () in
|
|
let axfr_req = n_of_s "two.com", `Axfr in
|
|
let key = Some (n_of_s "foo._transfer.one.com") in
|
|
Alcotest.(check (result axfr_test rcode_test) __LOC__ (Error Rcode.NotAuth)
|
|
(handle_axfr_request server `Tcp key axfr_req));
|
|
let key = Some (n_of_s "foo._transfer.two.com") in
|
|
Alcotest.(check (result axfr_test rcode_test) __LOC__ (Error Rcode.NotAuth)
|
|
(handle_axfr_request server `Tcp key axfr_req));
|
|
let key = Some (n_of_s "foo._transfer") in
|
|
Alcotest.(check (result axfr_test rcode_test) __LOC__ (Error Rcode.NotAuth)
|
|
(handle_axfr_request server `Tcp key axfr_req))
|
|
|
|
let unauthenticated_axfr () =
|
|
let server = server ~unauthenticated_zone_transfer:true () in
|
|
let axfr = soa, example_zone in
|
|
let axfr_req = n_of_s "one.com", `Axfr in
|
|
let key = Some (n_of_s "foo._transfer.one.com") in
|
|
Alcotest.(check (result axfr_test rcode_test) __LOC__ (Ok axfr)
|
|
(handle_axfr_request server `Tcp key axfr_req));
|
|
Alcotest.(check (result axfr_test rcode_test) __LOC__ (Error Rcode.Refused)
|
|
(handle_axfr_request server `Udp key axfr_req));
|
|
Alcotest.(check (result axfr_test rcode_test) __LOC__ (Ok axfr)
|
|
(handle_axfr_request server `Tcp None axfr_req))
|
|
|
|
let ixfr_test = Alcotest.testable Packet.Ixfr.pp Packet.Ixfr.equal
|
|
|
|
let ixfr () =
|
|
let primary = Primary.create ~rng:Mirage_crypto_rng.generate example_trie in
|
|
let server = Primary.server primary in
|
|
let cache = Primary.trie_cache primary in
|
|
let key = Some (n_of_s "foo._transfer.one.com") in
|
|
let ixfr_req = Packet.Question.create (n_of_s "one.com") Soa in
|
|
Alcotest.(check (result ixfr_test rcode_test) __LOC__ (Ok (soa, `Empty))
|
|
(handle_ixfr_request server cache `Tcp key ixfr_req soa));
|
|
let soa' = { soa with serial = Int32.succ soa.serial } in
|
|
let foo, entry_k, entry_v = n_of_s "foo.one.com", Rr_map.A, (300l, Ipaddr.V4.Set.singleton (ip_of_s "127.0.0.1")) in
|
|
let trie' =
|
|
Dns_trie.insert (n_of_s "one.com") Soa soa'
|
|
(Dns_trie.insert foo entry_k entry_v (Primary.data primary))
|
|
in
|
|
let primary', _ = Primary.with_data primary Ptime.epoch 0L trie' in
|
|
let server' = Primary.server primary' in
|
|
let cache' = Primary.trie_cache primary' in
|
|
let update =
|
|
`Difference (soa, Name_rr_map.empty, Name_rr_map.singleton foo entry_k entry_v)
|
|
in
|
|
Alcotest.(check (result ixfr_test rcode_test) __LOC__ (Ok (soa', update))
|
|
(handle_ixfr_request server' cache' `Tcp key ixfr_req soa));
|
|
let soa'' = { soa with serial = Int32.succ soa'.serial } in
|
|
let trie'' =
|
|
Dns_trie.insert (n_of_s "one.com") Soa soa''
|
|
(Dns_trie.remove foo entry_k entry_v trie')
|
|
in
|
|
let primary'', _ = Primary.with_data primary' Ptime.epoch 0L trie'' in
|
|
let server'' = Primary.server primary'' in
|
|
let cache'' = Primary.trie_cache primary'' in
|
|
let update = `Difference (soa, Name_rr_map.empty, Name_rr_map.empty) in
|
|
Alcotest.(check (result ixfr_test rcode_test) __LOC__ (Ok (soa'', update))
|
|
(handle_ixfr_request server'' cache'' `Tcp key ixfr_req soa));
|
|
let update' = `Difference (soa', Name_rr_map.singleton foo entry_k entry_v, Name_rr_map.empty) in
|
|
Alcotest.(check (result ixfr_test rcode_test) __LOC__ (Ok (soa'', update'))
|
|
(handle_ixfr_request server'' cache'' `Tcp key ixfr_req soa'));
|
|
let soa''' = { soa with serial = Int32.pred soa.serial } in
|
|
let update'' = `Full example_zone in
|
|
Alcotest.(check (result ixfr_test rcode_test) __LOC__ (Ok (soa'', update''))
|
|
(handle_ixfr_request server'' cache'' `Tcp key ixfr_req soa'''))
|
|
|
|
let trie_test = Alcotest.testable Dns_trie.pp Dns_trie.equal
|
|
|
|
let zone_test =
|
|
let module M = struct
|
|
type t = ([`raw] Domain_name.t * Soa.t) list
|
|
let pp =
|
|
let pp_one ppf (name, soa) =
|
|
Fmt.pf ppf "zone %a soa %a" Domain_name.pp name Soa.pp soa
|
|
in
|
|
Fmt.(list ~sep:(any ", ") pp_one)
|
|
let equal a b =
|
|
List.length a = List.length b &&
|
|
List.for_all2 (fun (n,s) (n',s') ->
|
|
Domain_name.equal n n' && Soa.compare s s' = 0)
|
|
a b
|
|
end in
|
|
(module M: Alcotest.TESTABLE with type t = M.t)
|
|
|
|
let basic_update () =
|
|
let server = server () in
|
|
let q = Packet.Question.create (n_of_s "one.com") Soa in
|
|
let up = Domain_name.Map.empty, Domain_name.Map.empty in
|
|
let key = n_of_s "foo._update.one.com" in
|
|
Alcotest.(check (result (pair trie_test zone_test) rcode_test)
|
|
__LOC__ (Ok (example_trie, []))
|
|
(handle_update server `Udp (Some key) q up));
|
|
let q' = Packet.Question.create (n_of_s "two.com") Soa in
|
|
Alcotest.(check (result (pair trie_test zone_test) rcode_test)
|
|
__LOC__ (Error Rcode.NotAuth)
|
|
(handle_update server `Udp (Some key) q' up));
|
|
let key = n_of_s "foo._update.com" in
|
|
Alcotest.(check (result (pair trie_test zone_test) rcode_test)
|
|
__LOC__ (Ok (example_trie, []))
|
|
(handle_update server `Udp (Some key) q up));
|
|
(* reason for this is the update is empty, and the key may create zones *)
|
|
Alcotest.(check (result (pair trie_test zone_test) rcode_test)
|
|
__LOC__ (Ok (example_trie, []))
|
|
(handle_update server `Udp (Some key) q' up));
|
|
let key = n_of_s "foo._update" in
|
|
Alcotest.(check (result (pair trie_test zone_test) rcode_test)
|
|
__LOC__ (Ok (example_trie, []))
|
|
(handle_update server `Udp (Some key) q up));
|
|
let key = n_of_s "foo._transfer.one.com" in
|
|
Alcotest.(check (result (pair trie_test zone_test) rcode_test)
|
|
__LOC__ (Error Rcode.NotAuth)
|
|
(handle_update server `Udp (Some key) q up));
|
|
let key = n_of_s "foo._notify.one.com" in
|
|
Alcotest.(check (result (pair trie_test zone_test) rcode_test)
|
|
__LOC__ (Error Rcode.NotAuth)
|
|
(handle_update server `Udp (Some key) q up));
|
|
let key = n_of_s "foo._update.two.com" in
|
|
Alcotest.(check (result (pair trie_test zone_test) rcode_test)
|
|
__LOC__ (Error Rcode.NotAuth)
|
|
(handle_update server `Udp (Some key) q up));
|
|
let key = n_of_s "foo._update.two.com" in
|
|
Alcotest.(check (result (pair trie_test zone_test) rcode_test)
|
|
__LOC__ (Error Rcode.NotAuth)
|
|
(handle_update server `Udp (Some key) q up))
|
|
|
|
let actual_update () =
|
|
let server = server () in
|
|
let q = Packet.Question.create (n_of_s "one.com") Soa in
|
|
let foo, entry_key, entry_val =
|
|
n_of_s "foo.one.com", Rr_map.A,
|
|
(300l, Ipaddr.V4.Set.singleton (ip_of_s "127.0.0.1"))
|
|
in
|
|
let up =
|
|
Domain_name.Map.empty,
|
|
Domain_name.Map.singleton foo [
|
|
Packet.Update.Add Rr_map.(B (entry_key, entry_val))
|
|
]
|
|
in
|
|
let key = n_of_s "foo._update.one.com" in
|
|
let soa' = { soa with serial = Int32.succ soa.serial } in
|
|
let trie' =
|
|
Dns_trie.insert (n_of_s "one.com") Rr_map.Soa soa'
|
|
(Dns_trie.insert foo entry_key entry_val example_trie)
|
|
in
|
|
Alcotest.(check (result (pair trie_test zone_test) rcode_test)
|
|
__LOC__ (Ok (trie', [ n_of_s "one.com", soa' ]))
|
|
(handle_update server `Udp (Some key) q up));
|
|
let soa'' = { soa' with serial = Int32.succ soa'.serial } in
|
|
let up' =
|
|
Domain_name.Map.empty,
|
|
Domain_name.Map.singleton foo [ Packet.Update.Remove_all ]
|
|
in
|
|
let server' = with_data server trie' in
|
|
let old_trie = Dns_trie.insert (n_of_s "one.com") Rr_map.Soa soa'' example_trie in
|
|
Alcotest.(check (result (pair trie_test zone_test) rcode_test)
|
|
__LOC__ (Ok (old_trie, [ n_of_s "one.com", soa'' ]))
|
|
(handle_update server' `Udp (Some key) q up'));
|
|
let up' =
|
|
Domain_name.Map.empty,
|
|
Domain_name.Map.singleton foo [ Packet.Update.Remove (Rr_map.K entry_key) ]
|
|
in
|
|
Alcotest.(check (result (pair trie_test zone_test) rcode_test)
|
|
__LOC__ (Ok (old_trie, [ n_of_s "one.com", soa'' ]))
|
|
(handle_update server' `Udp (Some key) q up'));
|
|
let up' =
|
|
Domain_name.Map.empty,
|
|
Domain_name.Map.singleton foo [ Packet.Update.Remove_single (Rr_map.B (entry_key, entry_val)) ]
|
|
in
|
|
Alcotest.(check (result (pair trie_test zone_test) rcode_test)
|
|
__LOC__ (Ok (old_trie, [ n_of_s "one.com", soa'' ]))
|
|
(handle_update server' `Udp (Some key) q up'));
|
|
let up' =
|
|
Domain_name.Map.empty,
|
|
Domain_name.Map.singleton (n_of_s "one.com") [ Packet.Update.Remove (Rr_map.K Soa) ]
|
|
in
|
|
Alcotest.(check (result (pair trie_test zone_test) rcode_test)
|
|
__LOC__ (Ok (Dns_trie.empty, [ n_of_s "one.com", soa'' ]))
|
|
(handle_update server' `Udp (Some key) q up'))
|
|
|
|
let actual_update_hostname_key () =
|
|
let server = server () in
|
|
let q = Packet.Question.create (n_of_s "foo.one.com") Soa in
|
|
let foo, entry_key, entry_val =
|
|
n_of_s "foo.one.com", Rr_map.A,
|
|
(300l, Ipaddr.V4.Set.singleton (ip_of_s "127.0.0.1"))
|
|
in
|
|
let up =
|
|
Domain_name.Map.empty,
|
|
Domain_name.Map.singleton foo [
|
|
Packet.Update.Add Rr_map.(B (entry_key, entry_val))
|
|
]
|
|
in
|
|
let key = n_of_s "mykey._update.foo.one.com" in
|
|
let soa' = { soa with serial = Int32.succ soa.serial } in
|
|
let trie' =
|
|
Dns_trie.insert (n_of_s "one.com") Rr_map.Soa soa'
|
|
(Dns_trie.insert foo entry_key entry_val example_trie)
|
|
in
|
|
Alcotest.(check (result (pair trie_test zone_test) rcode_test)
|
|
__LOC__ (Ok (trie', [ n_of_s "one.com", soa' ]))
|
|
(handle_update server `Udp (Some key) q up))
|
|
|
|
let trie_with_two trie =
|
|
Dns_trie.insert (n_of_s "two.com") Soa soa
|
|
(Dns_trie.insert (n_of_s "two.com") Ns (300l, example_ns) trie)
|
|
|
|
let update_zone_regression () =
|
|
(* implementation incremented serial of all zones for one update *)
|
|
let server =
|
|
let initial_server = server () in
|
|
Dns_server.with_data initial_server (trie_with_two initial_server.data)
|
|
in
|
|
let q = Packet.Question.create (n_of_s "one.com") Soa in
|
|
let foo, entry_key, entry_val =
|
|
n_of_s "foo.one.com", Rr_map.A,
|
|
(300l, Ipaddr.V4.Set.singleton (ip_of_s "127.0.0.1"))
|
|
in
|
|
let up =
|
|
Domain_name.Map.empty,
|
|
Domain_name.Map.singleton foo [
|
|
Packet.Update.Add Rr_map.(B (entry_key, entry_val))
|
|
]
|
|
in
|
|
let key = n_of_s "foo._update.one.com" in
|
|
let soa_plus_1 = { soa with serial = Int32.succ soa.serial } in
|
|
let trie_with_foo =
|
|
Dns_trie.insert (n_of_s "one.com") Rr_map.Soa soa_plus_1
|
|
(Dns_trie.insert foo entry_key entry_val server.data)
|
|
in
|
|
Alcotest.(check (result (pair trie_test zone_test) rcode_test)
|
|
__LOC__ (Ok (trie_with_foo, [ n_of_s "one.com", soa_plus_1 ]))
|
|
(handle_update server `Udp (Some key) q up));
|
|
let server_with_foo = Dns_server.with_data server trie_with_foo in
|
|
let soa_plus_2 = { soa_plus_1 with serial = Int32.succ soa_plus_1.serial } in
|
|
let trie_without_foo_soa_plus_2 =
|
|
Dns_trie.insert (n_of_s "one.com") Rr_map.Soa soa_plus_2 server.data
|
|
in
|
|
let up =
|
|
Domain_name.Map.empty,
|
|
Domain_name.Map.singleton foo [ Packet.Update.Remove (Rr_map.K entry_key) ]
|
|
in
|
|
Alcotest.(check (result (pair trie_test zone_test) rcode_test)
|
|
__LOC__ (Ok (trie_without_foo_soa_plus_2, [ n_of_s "one.com", soa_plus_2 ]))
|
|
(handle_update server_with_foo `Udp (Some key) q up));
|
|
let foo_two = n_of_s "foo.two.com" in
|
|
let key_two = n_of_s "foo._update.two.com" in
|
|
let q_two = Packet.Question.create (n_of_s "two.com") Soa in
|
|
let up =
|
|
Domain_name.Map.empty,
|
|
Domain_name.Map.singleton foo_two [
|
|
Packet.Update.Add Rr_map.(B (entry_key, entry_val))
|
|
]
|
|
in
|
|
let server_without_foo_soa_plus2 =
|
|
Dns_server.with_data server_with_foo trie_without_foo_soa_plus_2
|
|
in
|
|
let trie_with_foo_two =
|
|
Dns_trie.insert (n_of_s "two.com") Rr_map.Soa soa_plus_1
|
|
(Dns_trie.insert foo_two entry_key entry_val trie_without_foo_soa_plus_2)
|
|
in
|
|
Alcotest.(check (result (pair trie_test zone_test) rcode_test)
|
|
__LOC__ (Ok (trie_with_foo_two, [ n_of_s "two.com", soa_plus_1 ]))
|
|
(handle_update server_without_foo_soa_plus2 `Udp (Some key_two) q_two up));
|
|
let q_root = Packet.Question.create Domain_name.root Soa in
|
|
let up =
|
|
Domain_name.Map.empty,
|
|
Domain_name.Map.add foo [ Packet.Update.Remove (Rr_map.K entry_key) ]
|
|
(Domain_name.Map.singleton foo_two [ Packet.Update.Remove (Rr_map.K entry_key) ])
|
|
in
|
|
let server_with_foo_one_and_foo_two =
|
|
Dns_server.with_data server_without_foo_soa_plus2
|
|
(Dns_trie.insert foo entry_key entry_val trie_with_foo_two)
|
|
in
|
|
let key_root = n_of_s "foo._update" in
|
|
let soa_plus_3 = { soa_plus_2 with serial = Int32.succ soa_plus_2.serial } in
|
|
let exp_trie =
|
|
Dns_trie.insert (n_of_s "one.com") Soa soa_plus_3
|
|
(Dns_trie.insert (n_of_s "two.com") Soa soa_plus_2 trie_without_foo_soa_plus_2)
|
|
in
|
|
Alcotest.(check (result (pair trie_test zone_test) rcode_test)
|
|
__LOC__ (Ok (exp_trie, [ n_of_s "two.com", soa_plus_2 ; n_of_s "one.com", soa_plus_3 ]))
|
|
(handle_update server_with_foo_one_and_foo_two `Udp (Some key_root) q_root up))
|
|
|
|
(* TODO test prereq and more updates *)
|
|
|
|
let tests = [
|
|
"access granted", `Quick, access_granted ;
|
|
"zone and operation", `Quick, zone_and_op ;
|
|
"simple deny auth", `Quick, simple_deny ;
|
|
"simple allow auth", `Quick, simple_allow ;
|
|
"question", `Quick, question ;
|
|
"AXFR", `Quick, axfr ;
|
|
"no AXFR", `Quick, no_axfr ;
|
|
"unauthenticated AXFR", `Quick, unauthenticated_axfr ;
|
|
"ixfr", `Quick, ixfr ;
|
|
"basic update", `Quick, basic_update ;
|
|
"actual update", `Quick, actual_update ;
|
|
"actual update with hostname key", `Quick, actual_update_hostname_key ;
|
|
"update zone regression", `Quick, update_zone_regression ;
|
|
]
|
|
end
|
|
|
|
module Axfr = struct
|
|
let buf_axfr_test server axfr_req =
|
|
let req =
|
|
let header = 0x1234, Packet.Flags.empty in
|
|
let res = Packet.create header axfr_req `Axfr_request in
|
|
fst (Packet.encode `Tcp res)
|
|
in
|
|
let _server', answers, _notifies, _notify, _key =
|
|
Dns_server.Primary.handle_buf server Ptime.epoch 0L `Tcp (Ipaddr.V4 Ipaddr.V4.localhost) 1234 req
|
|
in
|
|
answers
|
|
|
|
let p_cs = Alcotest.testable Ohex.pp String.equal
|
|
|
|
let axfr_server ?(trie = A.example_trie) () =
|
|
Dns_server.Primary.create ~rng:Mirage_crypto_rng.generate
|
|
~unauthenticated_zone_transfer:true trie
|
|
|
|
let axfr_encoding () =
|
|
let s = axfr_server () in
|
|
let server = Dns_server.Primary.server s in
|
|
let axfr = A.soa, A.example_zone in
|
|
let axfr_req = n_of_s "one.com", `Axfr in
|
|
Alcotest.(check (result A.axfr_test A.rcode_test) __LOC__ (Ok axfr)
|
|
(Dns_server.handle_axfr_request server `Tcp None axfr_req));
|
|
let cs = Ohex.decode {|
|
|
12 34 84 00 00 01 00 09 00 00 00 00 03 6f 6e 65
|
|
03 63 6f 6d 00 00 fc 00 01 c0 0c 00 06 00 01 00
|
|
00 0e 10 00 26 02 6e 73 c0 0c 0a 68 6f 73 74 6d
|
|
61 73 74 65 72 c0 0c 00 00 00 01 00 01 51 80 00
|
|
00 1c 20 00 36 ee 80 00 00 0e 10 c0 0c 00 02 00
|
|
01 00 00 01 2c 00 02 c0 25 c0 0c 00 02 00 01 00
|
|
00 01 2c 00 06 03 6e 73 32 c0 0c c0 0c 00 02 00
|
|
01 00 00 01 2c 00 06 03 6e 73 33 c0 0c c0 25 00
|
|
01 00 01 00 00 01 2c 00 04 01 02 03 04 c0 65 00
|
|
01 00 01 00 00 01 2c 00 04 05 06 07 08 c0 77 00
|
|
01 00 01 00 00 01 2c 00 04 0a 00 00 01 c0 77 00
|
|
01 00 01 00 00 01 2c 00 04 c0 a8 01 01 c0 0c 00
|
|
06 00 01 00 00 0e 10 00 18 c0 25 c0 2a 00 00 00
|
|
01 00 01 51 80 00 00 1c 20 00 36 ee 80 00 00 0e
|
|
10|}
|
|
in
|
|
Alcotest.(check (list p_cs) __LOC__ [cs] (buf_axfr_test s axfr_req))
|
|
|
|
let big_zone k =
|
|
let big_txt_512 = Rr_map.Txt_set.of_list
|
|
[ "12345678901234567890123456789012345678901234567890 \
|
|
12345678901234567890123456789012345678901234567809 \
|
|
12345678901234567890123456789012345678901234567089 \
|
|
12345678901234567890123456789012345678901234560789 \
|
|
123456789012345678901234567890123456789" ;
|
|
"12345678901234567890123456789012345678901234056789 \
|
|
12345678901234567890123456789012345678901230456789 \
|
|
12345678901234567890123456789012345678901203456789 \
|
|
12345678901234567890123456789012345678901023456789 \
|
|
123456789012345678901234567890123456789"
|
|
]
|
|
in
|
|
let rec fill acc = function
|
|
| 0 -> acc
|
|
| n ->
|
|
(* should lead to 1024 bytes binary size:
|
|
name: yyy.<ptr> (= 4 + 2)
|
|
type, class, ttl, rdlen: 10
|
|
rd: 1 byte len + value (239) -> 240
|
|
--> 256 bytes
|
|
*)
|
|
let name = n_of_s (Printf.sprintf "%03d.one.com" (2 * n + 1)) in
|
|
let acc = Name_rr_map.add name Rr_map.Txt (300l, big_txt_512) acc in
|
|
let name = n_of_s (Printf.sprintf "%03d.one.com" (2 * n)) in
|
|
let acc = Name_rr_map.add name Rr_map.Txt (300l, big_txt_512) acc in
|
|
fill acc (pred n)
|
|
in
|
|
fill A.example_zone k
|
|
|
|
let trie_of_zone zone =
|
|
Dns_trie.insert (n_of_s "one.com") Soa A.soa
|
|
(Dns_trie.insert_map zone Dns_trie.empty)
|
|
|
|
let zone add =
|
|
let more = [
|
|
"foobar00"; "foobar01"; "foobar02"; "foobar03"; "foobar04";
|
|
"foobar05"; "foobar06"; "foobar07"; "foobar08"; "foobar09";
|
|
"foobar10"; "foobar11"; "foobar12"; "foobar13"; "foobar14";
|
|
"foobar15"; "foobar16"; "foobar17"; "foobar18"; "foobar19";
|
|
"foobar20"; "foobar21"; "foobar22"; "foobar23"; "foobar24";
|
|
"foobar25"; "foobar26"; "foobar27"; "foobar28"; "foobar29";
|
|
"foobar30"; "foobar31"; "foobar32"; "foobar33"; "foobar34";
|
|
"foobar35"; "foobar36"; "foobar37"; "foobar38"; "foobar39";
|
|
"foobar40"; "foobar41"; "foobar42"; "foobar43"; "12345foobar44" ^ add
|
|
]
|
|
in
|
|
let z =
|
|
Name_rr_map.add (n_of_s "one.com")
|
|
Rr_map.Txt (300l, Rr_map.Txt_set.of_list more) (big_zone 62)
|
|
in
|
|
trie_of_zone z
|
|
|
|
let axfr_encoding_big_zone_no_split () =
|
|
(* big_zone 63 results in an AXFR which is 65241 bytes big *)
|
|
(* the `more` below extends it to 65535 bytes (max size for a TCP frame) *)
|
|
(* the biggest zone to fit into a single DNS packet *)
|
|
let trie = zone "" in
|
|
let s = axfr_server ~trie () in
|
|
let axfr_req = n_of_s "one.com", `Axfr in
|
|
let bufs = buf_axfr_test s axfr_req in
|
|
Alcotest.(check int __LOC__ 1 (List.length bufs));
|
|
Alcotest.(check int __LOC__ 65535 (String.length (List.hd bufs)));
|
|
match Packet.decode (List.hd bufs) with
|
|
| Ok _ -> ()
|
|
| Error e ->
|
|
Alcotest.fail ("AXFR decoding error " ^ Fmt.to_to_string Packet.pp_err e)
|
|
|
|
let axfr_encoding_big_zone_one_split () =
|
|
(* the first zone to split into multiple packets *)
|
|
let trie = zone "1" in
|
|
let s = axfr_server ~trie () in
|
|
let axfr_req = n_of_s "one.com", `Axfr in
|
|
let bufs = buf_axfr_test s axfr_req in
|
|
Alcotest.(check int __LOC__ 2 (List.length bufs));
|
|
Alcotest.(check int __LOC__ 65500 (String.length (List.hd bufs)));
|
|
Alcotest.(check int __LOC__ 75 (String.length (List.hd (List.tl bufs))))
|
|
|
|
let axfr_encoding_big_zone_multiple_splits () =
|
|
(* a zone split over multiple packages *)
|
|
let trie = trie_of_zone (big_zone 200) in
|
|
let s = axfr_server ~trie () in
|
|
let axfr_req = n_of_s "one.com", `Axfr in
|
|
Alcotest.(check int __LOC__ 4 (List.length (buf_axfr_test s axfr_req)))
|
|
|
|
let signed_zone add =
|
|
let more = [
|
|
"foobar00"; "foobar01"; "foobar02"; "foobar03"; "foobar04";
|
|
"foobar05"; "foobar06"; "foobar07"; "foobar08"; "foobar09";
|
|
"foobar10"; "foobar11"; "foobar12"; "foobar13"; "foobar14";
|
|
"foobar15"; "foobar16"; "foobar17"; "foobar18"; "foobar19";
|
|
"foobar20"; "foobar21"; "foobar22"; "foobar23"; "foobar24";
|
|
"foobar25"; "foobar26"; "foobar27"; "foobar28"; "foobar29";
|
|
"foobar30"; "foobar31"; "foobar32"; "foobar33"; "foobar34";
|
|
"foobar35"; "foobar36"; "foobar37"; "foobar38"; "0foobar39" ^ add
|
|
]
|
|
in
|
|
let z =
|
|
Name_rr_map.add (n_of_s "one.com")
|
|
Rr_map.Txt (300l, Rr_map.Txt_set.of_list more) (big_zone 62)
|
|
in
|
|
trie_of_zone z
|
|
|
|
let signed_buf_axfr_test server keyname key axfr_req =
|
|
let req, mac =
|
|
let header = 0x1234, Packet.Flags.empty in
|
|
let res = Packet.create header axfr_req `Axfr_request in
|
|
match Dns_tsig.encode_and_sign ~proto:`Tcp res Ptime.epoch key keyname with
|
|
| Ok (buf, mac) -> buf, mac
|
|
| Error _ -> assert false
|
|
in
|
|
let _server', answers, _notifies, _notify, keyname' =
|
|
Dns_server.Primary.handle_buf server Ptime.epoch 0L `Tcp (Ipaddr.V4 Ipaddr.V4.localhost) 1234 req
|
|
in
|
|
assert (match keyname' with Some k -> Domain_name.equal k keyname | _ -> false);
|
|
(List.iter (fun answer ->
|
|
match Dns_tsig.decode_and_verify Ptime.epoch key keyname ~mac answer with
|
|
| Ok _ -> ()
|
|
| Error e ->
|
|
Alcotest.fail ("error while verifying " ^ Fmt.to_to_string Dns_tsig.pp_e e))
|
|
answers);
|
|
answers
|
|
|
|
let keyname, key =
|
|
let key = String.make 32 '\000' |> Base64.encode_string in
|
|
n_of_s "1.2.3.4.9.10.11.12._transfer.one.com",
|
|
{ Dnskey.flags = Dnskey.F.empty ; algorithm = SHA256 ; key }
|
|
|
|
let s trie =
|
|
let keys = [ keyname, key ] in
|
|
Dns_server.Primary.create ~rng:Mirage_crypto_rng.generate
|
|
~tsig_verify:Dns_tsig.verify ~tsig_sign:Dns_tsig.sign ~keys trie
|
|
|
|
let axfr_encoding_big_zone_no_split_tsig () =
|
|
let trie = signed_zone "" in
|
|
let s = s trie in
|
|
let axfr_req = n_of_s "one.com", `Axfr in
|
|
let bufs = signed_buf_axfr_test s keyname key axfr_req in
|
|
Alcotest.(check int __LOC__ 1 (List.length bufs));
|
|
Alcotest.(check int __LOC__ 65535 (String.length (List.hd bufs)))
|
|
|
|
let axfr_encoding_big_zone_one_split_tsig () =
|
|
let trie = signed_zone "0" in
|
|
let s = s trie in
|
|
let axfr_req = n_of_s "one.com", `Axfr in
|
|
let bufs = signed_buf_axfr_test s keyname key axfr_req in
|
|
Alcotest.(check int __LOC__ 2 (List.length bufs));
|
|
Alcotest.(check int __LOC__ 65500 (String.length (List.hd bufs)));
|
|
Alcotest.(check int __LOC__ 184 (String.length (List.hd (List.tl bufs))))
|
|
|
|
let tests = [
|
|
"encoding", `Quick, axfr_encoding ;
|
|
"encoding big zone (no split)", `Quick, axfr_encoding_big_zone_no_split ;
|
|
"encoding big zone (one split)", `Quick, axfr_encoding_big_zone_one_split ;
|
|
"encoding big zone (multiple splits)", `Quick, axfr_encoding_big_zone_multiple_splits ;
|
|
"encoding big zone with tsig (no split)", `Quick, axfr_encoding_big_zone_no_split_tsig ;
|
|
"encoding big zone with tsig (one split)", `Quick, axfr_encoding_big_zone_one_split_tsig ;
|
|
]
|
|
end
|
|
|
|
module Zone = struct
|
|
let name_map_ok =
|
|
let module M = struct
|
|
type t = Name_rr_map.t
|
|
let pp = Name_rr_map.pp
|
|
let equal = Name_rr_map.equal
|
|
end in
|
|
(module M: Alcotest.TESTABLE with type t = M.t)
|
|
|
|
let err =
|
|
let module M = struct
|
|
type t = [ `Msg of string ]
|
|
let pp ppf (`Msg s) = Fmt.string ppf s
|
|
let equal _ _ = true
|
|
end in
|
|
(module M: Alcotest.TESTABLE with type t = M.t)
|
|
|
|
let simple_zone = {|
|
|
$ORIGIN example.
|
|
$TTL 2560
|
|
@ SOA ns root 1 86400 10800 1048576 2560
|
|
@ NS ns
|
|
|}
|
|
|
|
let parse_simple_zone () =
|
|
let rrs =
|
|
let z = n_of_s "example" in
|
|
let ns_name = n_of_s "ns.example" in
|
|
let ns = 2560l, Domain_name.(Host_set.singleton (host_exn ns_name)) in
|
|
let soa = { Soa.nameserver = ns_name ; hostmaster = n_of_s "root.example" ;
|
|
serial = 1l ; refresh = 86400l ; retry = 10800l ;
|
|
expiry = 1048576l ; minimum = 2560l }
|
|
in
|
|
Name_rr_map.(add z Rr_map.Ns ns (singleton z Rr_map.Soa soa))
|
|
in
|
|
Alcotest.(check (result name_map_ok err) "parsing simple zone"
|
|
(Ok rrs) (Dns_zone.parse simple_zone))
|
|
|
|
let simple_zone_2 = {|
|
|
$ORIGIN example.
|
|
$TTL 2560
|
|
@ SOA ns root 1 86400 10800 1048576 2560
|
|
@ NS ns
|
|
a A 1.2.3.4
|
|
e A 1.2.3.4
|
|
2m A 1.2.3.4
|
|
2 A 1.2.3.4
|
|
-2 A 1.2.3.4
|
|
TYPE23 A 1.2.3.4
|
|
|}
|
|
|
|
let parse_simple_zone_2 () =
|
|
let rrs =
|
|
let z = n_of_s "example" in
|
|
let ns_name = n_of_s "ns.example" in
|
|
let ns = 2560l, Domain_name.(Host_set.singleton (host_exn ns_name)) in
|
|
let soa = { Soa.nameserver = ns_name ; hostmaster = n_of_s "root.example" ;
|
|
serial = 1l ; refresh = 86400l ; retry = 10800l ;
|
|
expiry = 1048576l ; minimum = 2560l }
|
|
in
|
|
let a = Ipaddr.V4.Set.singleton (Ipaddr.V4.of_string_exn "1.2.3.4") in
|
|
let hs = List.map (fun lbl -> n_of_s (lbl ^ ".example"))
|
|
[ "a" ; "e" ; "2m" ; "2" ; "-2" ; "TYPE23" ]
|
|
in
|
|
List.fold_left (fun rrs dn ->
|
|
Name_rr_map.(add dn Rr_map.A (2560l, a) rrs))
|
|
Name_rr_map.(add z Rr_map.Ns ns (singleton z Rr_map.Soa soa))
|
|
hs
|
|
in
|
|
Alcotest.(check (result name_map_ok err) "parsing simple zone 2"
|
|
(Ok rrs) (Dns_zone.parse simple_zone_2))
|
|
|
|
let simple_zone_3 = {|
|
|
$ORIGIN example.
|
|
$TTL 2560
|
|
@ SOA ns root 1 86400 10800 1048576 2560
|
|
@ NS ns
|
|
A A 1.2.3.4
|
|
NS A 1.2.3.4
|
|
CNAME A 1.2.3.4
|
|
SOA A 1.2.3.4
|
|
PTR A 1.2.3.4
|
|
MX A 1.2.3.4
|
|
TXT A 1.2.3.4
|
|
AAAA A 1.2.3.4
|
|
SRV A 1.2.3.4
|
|
DNSKEY A 1.2.3.4
|
|
CAA A 1.2.3.4
|
|
TLSA A 1.2.3.4
|
|
SSHFP A 1.2.3.4
|
|
DS A 1.2.3.4
|
|
LOC A 1.2.3.4
|
|
IN A 1.2.3.4
|
|
CS A 1.2.3.4
|
|
CH A 1.2.3.4
|
|
HS A 1.2.3.4
|
|
N A 1.2.3.4
|
|
S A 1.2.3.4
|
|
E A 1.2.3.4
|
|
W A 1.2.3.4
|
|
|}
|
|
|
|
let parse_simple_zone_3 () =
|
|
let rrs =
|
|
let z = n_of_s "example" in
|
|
let ns_name = n_of_s "ns.example" in
|
|
let ns = 2560l, Domain_name.(Host_set.singleton (host_exn ns_name)) in
|
|
let soa = { Soa.nameserver = ns_name ; hostmaster = n_of_s "root.example" ;
|
|
serial = 1l ; refresh = 86400l ; retry = 10800l ;
|
|
expiry = 1048576l ; minimum = 2560l }
|
|
in
|
|
let a = Ipaddr.V4.Set.singleton (Ipaddr.V4.of_string_exn "1.2.3.4") in
|
|
let hs =
|
|
List.map (fun lbl -> n_of_s (lbl ^ ".example")) [
|
|
"A"
|
|
; "NS"
|
|
; "CNAME"
|
|
; "SOA"
|
|
; "PTR"
|
|
; "MX"
|
|
; "TXT"
|
|
; "AAAA"
|
|
; "SRV"
|
|
; "DNSKEY"
|
|
; "CAA"
|
|
; "TLSA"
|
|
; "SSHFP"
|
|
; "DS"
|
|
; "LOC"
|
|
; "IN"
|
|
; "CS"
|
|
; "CH"
|
|
; "HS"
|
|
; "N"
|
|
; "S"
|
|
; "E"
|
|
; "W"
|
|
]
|
|
in
|
|
List.fold_left (fun rr_map dn ->
|
|
Name_rr_map.(add dn Rr_map.A (2560l, a) rr_map))
|
|
Name_rr_map.(add z Rr_map.Ns ns (singleton z Rr_map.Soa soa))
|
|
hs
|
|
in
|
|
Alcotest.(check (result name_map_ok err) "parsing simple zone 3"
|
|
(Ok rrs) (Dns_zone.parse simple_zone_3))
|
|
|
|
let simple_zone_no_nl = {|
|
|
$ORIGIN example.
|
|
$TTL 2560
|
|
@ SOA ns root 1 86400 10800 1048576 2560
|
|
@ NS ns|}
|
|
|
|
let parse_simple_zone_without_nl () =
|
|
let rrs =
|
|
let z = n_of_s "example" in
|
|
let ns_name = n_of_s "ns.example" in
|
|
let ns = 2560l, Domain_name.(Host_set.singleton (host_exn ns_name)) in
|
|
let soa = { Soa.nameserver = ns_name ; hostmaster = n_of_s "root.example" ;
|
|
serial = 1l ; refresh = 86400l ; retry = 10800l ;
|
|
expiry = 1048576l ; minimum = 2560l }
|
|
in
|
|
Name_rr_map.(add z Rr_map.Ns ns (singleton z Rr_map.Soa soa))
|
|
in
|
|
Alcotest.(check (result name_map_ok err) "parsing simple zone without newline"
|
|
(Ok rrs) (Dns_zone.parse simple_zone_no_nl))
|
|
|
|
let wildcard_zone = {|
|
|
$ORIGIN example.
|
|
$TTL 2560
|
|
@ SOA ns root 1 86400 10800 1048576 2560
|
|
@ NS ns
|
|
* A 1.2.3.4
|
|
|}
|
|
|
|
let parse_wildcard_zone () =
|
|
let rrs =
|
|
let z = n_of_s "example" in
|
|
let ns_name = n_of_s "ns.example" in
|
|
let minimum = 2560l in
|
|
let ns = Domain_name.(Host_set.singleton (host_exn ns_name)) in
|
|
let soa = { Soa.nameserver = ns_name ; hostmaster = n_of_s "root.example" ;
|
|
serial = 1l ; refresh = 86400l ; retry = 10800l ;
|
|
expiry = 1048576l ; minimum }
|
|
in
|
|
let a = Ipaddr.V4.Set.singleton (Ipaddr.V4.of_string_exn "1.2.3.4") in
|
|
Name_rr_map.(add z Rr_map.Ns (minimum, ns)
|
|
(add z Rr_map.Soa soa
|
|
(singleton (n_of_s "*.example") Rr_map.A (minimum, a))))
|
|
in
|
|
Alcotest.(check (result name_map_ok err) "parsing wildcard zone"
|
|
(Ok rrs) (Dns_zone.parse wildcard_zone))
|
|
|
|
let rfc4592_zone = {|
|
|
$ORIGIN example.
|
|
example. 3600 IN SOA ns.example.com. root 1 86400 10800 1048576 2560
|
|
example. 3600 NS ns.example.com.
|
|
example. 3600 NS ns.example.net.
|
|
*.example. 3600 TXT "this is a wildcard"
|
|
*.example. 3600 MX 10 host1.example.
|
|
sub.*.example. 3600 TXT "this is not a wildcard"
|
|
host1.example. 3600 A 192.0.2.1
|
|
_ssh._tcp.host1.example. 3600 SRV 1 2 3 host1
|
|
_ssh._tcp.host2.example. 3600 SRV 2 3 4 host1
|
|
subdel.example. 3600 NS ns.example.com.
|
|
subdel.example. 3600 NS ns.example.net.
|
|
|}
|
|
|
|
let wc_txt = Rr_map.Txt_set.singleton "this is a wildcard"
|
|
and sub_txt = Rr_map.Txt_set.singleton "this is not a wildcard"
|
|
and wc_mx =
|
|
let mx =
|
|
let mail_exchange = Domain_name.host_exn (n_of_s "host1.example") in
|
|
Mx.{ preference = 10 ; mail_exchange }
|
|
in
|
|
Rr_map.Mx_set.singleton mx
|
|
and soa = { Soa.nameserver = n_of_s "ns.example.com" ; hostmaster = n_of_s "root.example" ;
|
|
serial = 1l ; refresh = 86400l ; retry = 10800l ;
|
|
expiry = 1048576l ; minimum = 2560l }
|
|
and ns = Domain_name.(Host_set.(add (host_exn (n_of_s "ns.example.com"))
|
|
(singleton (host_exn (n_of_s "ns.example.net")))))
|
|
|
|
let parse_rfc4592_zone () =
|
|
let rrs =
|
|
let z = n_of_s "example" in
|
|
let host1 = n_of_s "host1.example" in
|
|
let host1_a = Ipaddr.V4.Set.singleton (Ipaddr.V4.of_string_exn "192.0.2.1")
|
|
and srv1 =
|
|
let srv = Srv.{ priority = 1 ; weight = 2 ; port = 3 ; target = Domain_name.host_exn host1 } in
|
|
Rr_map.Srv_set.singleton srv
|
|
and srv2 =
|
|
let srv = Srv.{ priority = 2 ; weight = 3 ; port = 4 ; target = Domain_name.host_exn host1 } in
|
|
Rr_map.Srv_set.singleton srv
|
|
in
|
|
let ttl = 3600l in
|
|
let wc = n_of_s "*.example" in
|
|
let subdel = n_of_s "subdel.example" in
|
|
Name_rr_map.(add z Rr_map.Ns (ttl, ns)
|
|
(add z Rr_map.Soa soa
|
|
(add wc Rr_map.Txt (ttl, wc_txt)
|
|
(add wc Rr_map.Mx (ttl, wc_mx)
|
|
(add (n_of_s "sub.*.example") Rr_map.Txt (ttl, sub_txt)
|
|
(add host1 Rr_map.A (ttl, host1_a)
|
|
(add (n_of_s "_ssh._tcp.host1.example") Rr_map.Srv (ttl, srv1)
|
|
(add (n_of_s "_ssh._tcp.host2.example") Rr_map.Srv (ttl, srv2)
|
|
(singleton subdel Rr_map.Ns (ttl, ns))))))))))
|
|
in
|
|
Alcotest.(check (result name_map_ok err) "parsing rfc4592 zone"
|
|
(Ok rrs) (Dns_zone.parse rfc4592_zone))
|
|
|
|
let rfc4592_questions () =
|
|
match Dns_zone.parse rfc4592_zone with
|
|
| Error `Msg f -> Alcotest.failf "couldn't parse zone: %s" f
|
|
| Ok data ->
|
|
let trie = Dns_trie.insert_map data Dns_trie.empty in
|
|
match Dns_trie.check trie with
|
|
| Error e ->
|
|
Alcotest.failf "dns trie check failed %a" Dns_trie.pp_zone_check e
|
|
| Ok () ->
|
|
Alcotest.(check (result Trie.b_ok Trie.e) "lookup_b for MX host3 matches wildcard"
|
|
(Ok (Rr_map.B (Rr_map.Mx, (3600l, wc_mx))))
|
|
(Trie.lookup_b (n_of_s "host3.example") Rr_map.Mx trie));
|
|
Alcotest.(check (result Trie.b_ok Trie.e) "lookup_b for A host3 is nodata"
|
|
(Error (`EmptyNonTerminal (n_of_s "example", soa)))
|
|
(Trie.lookup_b (n_of_s "host3.example") Rr_map.A trie));
|
|
Alcotest.(check (result Trie.b_ok Trie.e) "lookup_b for TXT foo.bar matches wildcard"
|
|
(Ok (Rr_map.B (Rr_map.Txt, (3600l, wc_txt))))
|
|
(Trie.lookup_b (n_of_s "foo.bar.example") Rr_map.Txt trie));
|
|
Alcotest.(check (result Trie.b_ok Trie.e) "lookup_b for MX host1 is nodata"
|
|
(Error (`EmptyNonTerminal (n_of_s "example", soa)))
|
|
(Trie.lookup_b (n_of_s "host1.example") Rr_map.Mx trie));
|
|
Alcotest.(check (result Trie.b_ok Trie.e) "lookup_b for MX sub.* is nodata"
|
|
(Error (`EmptyNonTerminal (n_of_s "example", soa)))
|
|
(Trie.lookup_b (n_of_s "sub.*.example") Rr_map.Mx trie));
|
|
Alcotest.(check (result Trie.b_ok Trie.e) "lookup_b for SRV _telnet._tcp.host1 is nodata"
|
|
(Error (`NotFound (n_of_s "example", soa)))
|
|
(Trie.lookup_b (n_of_s "_telnet._tcp.host1.example") Rr_map.Srv trie));
|
|
Alcotest.(check (result Trie.b_ok Trie.e) "lookup_b for A host.subdel is nodata"
|
|
(Error (`Delegation (n_of_s "subdel.example", (3600l, ns))))
|
|
(Trie.lookup_b (n_of_s "host.subdel.example") Rr_map.A trie));
|
|
(* for the curious from RFC 4592, 2.2.1:
|
|
The final example highlights one common misconception about
|
|
wildcards. A wildcard "blocks itself" in the sense that a wildcard
|
|
does not match its own subdomains. That is, "*.example." does not
|
|
match all names in the "example." zone; it fails to match the names
|
|
below "*.example.". To cover names under "*.example.", another
|
|
wildcard domain name is needed--"*.*.example."--which covers all but
|
|
its own subdomains.
|
|
*)
|
|
Alcotest.(check (result Trie.b_ok Trie.e) "lookup_b for MX ghost.* is nodata"
|
|
(Error (`NotFound (n_of_s "example", soa)))
|
|
(Trie.lookup_b (n_of_s "ghost.*.example") Rr_map.Mx trie));
|
|
(* some more checks *)
|
|
Alcotest.(check (result Trie.b_ok Trie.e) "lookup_b for TXT host3 matches wildcard"
|
|
(Ok (Rr_map.B (Rr_map.Txt, (3600l, wc_txt))))
|
|
(Trie.lookup_b (n_of_s "host3.example") Rr_map.Txt trie));
|
|
Alcotest.(check (result Trie.b_ok Trie.e) "lookup_b for TXT foo.host1 is nodata"
|
|
(Error (`NotFound (n_of_s "example", soa)))
|
|
(Trie.lookup_b (n_of_s "foo.host1.example") Rr_map.Txt trie));
|
|
Alcotest.(check (result Trie.b_ok Trie.e) "lookup_b for TXT sub.* is sub_txt"
|
|
(Ok (Rr_map.B (Rr_map.Txt, (3600l, sub_txt))))
|
|
(Trie.lookup_b (n_of_s "sub.*.example") Rr_map.Txt trie));
|
|
Alcotest.(check (result Trie.b_ok Trie.e) "lookup_b for TXT example is nodata"
|
|
(Error (`EmptyNonTerminal (n_of_s "example", soa)))
|
|
(Trie.lookup_b (n_of_s "example") Rr_map.Txt trie))
|
|
|
|
let parse_zone_with_glue () =
|
|
let zone = {|$ORIGIN example.
|
|
$TTL 3600
|
|
@ SOA ns root 1 86400 10800 1048576 3600
|
|
@ NS ns.example.org.
|
|
@ NS ns.example.net.
|
|
|
|
ns.example.net. A 5.6.7.8
|
|
ns.example.org. A 1.2.3.4
|
|
|
|
|
|
|}
|
|
in
|
|
let _, trie = Dns_zone.decode_zones [ "example", zone ] in
|
|
match Dns_trie.lookup (n_of_s "example") Rr_map.Ns trie with
|
|
| Error _ -> Alcotest.fail "couldn't find NS for example"
|
|
| Ok (_, name_servers) ->
|
|
let ns =
|
|
Domain_name.(Host_set.of_list [
|
|
host_exn (n_of_s "ns.example.org");
|
|
host_exn (n_of_s "ns.example.net");
|
|
])
|
|
in
|
|
Alcotest.(check bool "NS for example are correct" true
|
|
(Domain_name.Host_set.equal ns name_servers));
|
|
(match Dns_trie.lookup_glue (n_of_s "ns.example.org") trie with
|
|
| Some (_, ips), None ->
|
|
Alcotest.(check bool "IP for ns.example.org is correct" true
|
|
Ipaddr.V4.Set.(equal (singleton (Ipaddr.V4.of_string_exn "1.2.3.4")) ips))
|
|
| _ -> Alcotest.fail "expected some IPv4 addresses for NS");
|
|
(match Dns_trie.lookup_glue (n_of_s "ns.example.net") trie with
|
|
| Some (_, ips), None ->
|
|
Alcotest.(check bool "IP for ns.example.net is correct" true
|
|
Ipaddr.V4.Set.(equal (singleton (Ipaddr.V4.of_string_exn "5.6.7.8")) ips))
|
|
| _ -> Alcotest.fail "expected some IPv4 addresses for NS");
|
|
match Dns_server.text (n_of_s "example") trie with
|
|
| Ok data ->
|
|
Alcotest.(check string "text (decode_zones z) = z" zone data)
|
|
| Error _ -> Alcotest.fail "failed to encode zone"
|
|
|
|
let parse_zone_with_glue_sub () =
|
|
let zone = {|$ORIGIN example.
|
|
$TTL 3600
|
|
@ SOA ns root 1 86400 10800 1048576 3600
|
|
@ NS ns
|
|
@ NS a.b
|
|
b NS a.b
|
|
ns A 5.6.7.8
|
|
|
|
a.b A 1.2.3.4
|
|
|
|
|
|
|}
|
|
in
|
|
let _, trie = Dns_zone.decode_zones [ "example", zone ] in
|
|
match Dns_trie.lookup (n_of_s "example") Rr_map.Ns trie with
|
|
| Error _ -> Alcotest.fail "couldn't find NS for example"
|
|
| Ok (_, name_servers) ->
|
|
let ns =
|
|
Domain_name.(Host_set.of_list [
|
|
host_exn (n_of_s "ns.example");
|
|
host_exn (n_of_s "a.b.example");
|
|
])
|
|
in
|
|
Alcotest.(check bool "NS for example are correct" true
|
|
(Domain_name.Host_set.equal ns name_servers));
|
|
(match Dns_trie.lookup_glue (n_of_s "ns.example") trie with
|
|
| Some (_, ips), None ->
|
|
Alcotest.(check bool "IP for ns.example is correct" true
|
|
Ipaddr.V4.Set.(equal (singleton (Ipaddr.V4.of_string_exn "5.6.7.8")) ips))
|
|
| _ -> Alcotest.fail "expected some IPv4 addresses for NS");
|
|
(match Dns_trie.lookup_glue (n_of_s "a.b.example") trie with
|
|
| Some (_, ips), None ->
|
|
Alcotest.(check bool "IP for a.b.example is correct" true
|
|
Ipaddr.V4.Set.(equal (singleton (Ipaddr.V4.of_string_exn "1.2.3.4")) ips))
|
|
| _ -> Alcotest.fail "expected some IPv4 addresses for NS");
|
|
(match Dns_trie.lookup (n_of_s "b.example") Rr_map.Soa trie with
|
|
| Error `Delegation _ -> ()
|
|
| _ -> Alcotest.fail "expected delegation for b.example");
|
|
(match Dns_trie.lookup (n_of_s "a.b.example") Rr_map.Soa trie with
|
|
| Error `Delegation _ -> ()
|
|
| _ -> Alcotest.fail "expected delegation for a.b.example");
|
|
match Dns_server.text (n_of_s "example") trie with
|
|
| Ok data ->
|
|
Alcotest.(check string "text (decode_zones z) = z" zone data)
|
|
| Error _ -> Alcotest.fail "failed to encode zone"
|
|
|
|
let numerical_subdomain_zone = {|
|
|
$ORIGIN example.
|
|
example. 3600 IN SOA ns.example.com. root 1 86400 10800 1048576 2560
|
|
1host.example. 3600 A 192.0.2.1
|
|
|}
|
|
|
|
let parse_numerical_subdomain_zone () =
|
|
let rrs =
|
|
let soa = { Soa.nameserver = n_of_s "ns.example.com" ; hostmaster = n_of_s "root.example" ;
|
|
serial = 1l ; refresh = 86400l ; retry = 10800l ;
|
|
expiry = 1048576l ; minimum = 2560l }
|
|
in
|
|
let z = n_of_s "example" in
|
|
let host1 = n_of_s "1host.example" in
|
|
let host1_a = Ipaddr.V4.Set.singleton (Ipaddr.V4.of_string_exn "192.0.2.1") in
|
|
let ttl = 3600l in
|
|
Name_rr_map.(add z Rr_map.Soa soa
|
|
(singleton host1 Rr_map.A (ttl, host1_a)))
|
|
in
|
|
Alcotest.(check (result name_map_ok err) "parsing numerical subdomain zone"
|
|
(Ok rrs) (Dns_zone.parse numerical_subdomain_zone))
|
|
|
|
let parse_locs () =
|
|
let loc_zone = {|
|
|
$ORIGIN example.
|
|
$TTL 2560
|
|
@ SOA ns root 1 86400 10800 1048576 2560
|
|
@ NS ns
|
|
@ LOC |} in
|
|
let loc_strs = [
|
|
(
|
|
"0 0 0 N 0 0 0 E 0m 0m 0m 0m",
|
|
Loc.parse ~latitude:((0l, 0l, 0l), `North) ~longitude:((0l, 0l, 0l), `East) ~altitude:0L ~precision:(0L, 0L, 0L),
|
|
"0 0 0 N 0 0 0 E 0m 0m 0m 0m"
|
|
) ;
|
|
(
|
|
"0 0 0 S 0 0 0 W 0 0 0 0",
|
|
Loc.parse ~latitude:((0l, 0l, 0l), `North) ~longitude:((0l, 0l, 0l), `East) ~altitude:0L ~precision:(0L, 0L, 0L),
|
|
"0 0 0 N 0 0 0 E 0m 0m 0m 0m"
|
|
) ;
|
|
(
|
|
"0 0 0 N 0 0 0 E 0m 0m 0m 0m",
|
|
Loc.parse ~latitude:((0l, 0l, 0l), `North) ~longitude:((0l, 0l, 0l), `East) ~altitude:0L ~precision:(0L, 0L, 0L),
|
|
"0 0 0 N 0 0 0 E 0m 0m 0m 0m"
|
|
) ;
|
|
(
|
|
"0 0 0.0 N 0 0 0.0 E 0.00m 0.00m 0.00m 0.00m",
|
|
Loc.parse ~latitude:((0l, 0l, 0l), `North) ~longitude:((0l, 0l, 0l), `East) ~altitude:0L ~precision:(0L, 0L, 0L),
|
|
"0 0 0 N 0 0 0 E 0m 0m 0m 0m"
|
|
) ;
|
|
(
|
|
"00 00 0.00 N 00 00 0.00 E 0.00 0.00 0.00 0.00",
|
|
Loc.parse ~latitude:((0l, 0l, 0l), `North) ~longitude:((0l, 0l, 0l), `East) ~altitude:0L ~precision:(0L, 0L, 0L),
|
|
"0 0 0 N 0 0 0 E 0m 0m 0m 0m"
|
|
) ;
|
|
(
|
|
"52 12 40.4 N 0 5 31.9 E 22m 10m 10m 10m",
|
|
Loc.parse ~latitude:((52l, 12l, 40400l), `North) ~longitude:((0l, 5l, 31900l), `East) ~altitude:2200L ~precision:(1000L, 1000L, 1000L),
|
|
"52 12 40.4 N 0 5 31.9 E 22m 10m 10m 10m"
|
|
) ;
|
|
(
|
|
"0 0 0 N 0 0 0 E -100000m 0m 0m 0m",
|
|
Loc.parse ~latitude:((0l, 0l, 0l), `North) ~longitude:((0l, 0l, 0l), `East) ~altitude:(Int64.neg 10000000L) ~precision:(0L, 0L, 0L),
|
|
"0 0 0 N 0 0 0 E -100000m 0m 0m 0m"
|
|
) ;
|
|
(
|
|
"0 0 0 S 0 0 0 W -100000 0m 0m 0m",
|
|
Loc.parse ~latitude:((0l, 0l, 0l), `South) ~longitude:((0l, 0l, 0l), `West) ~altitude:(Int64.neg 10000000L) ~precision:(0L, 0L, 0L),
|
|
"0 0 0 N 0 0 0 E -100000m 0m 0m 0m"
|
|
) ;
|
|
(
|
|
"89 59 59.999 N 179 59 59.999 E 21374836.47m 90000000m 90000000m 90000000m",
|
|
Loc.parse ~latitude:((89l, 59l, (59999l)), `North) ~longitude:((179l, 59l, (59999l)), `East) ~altitude:2137483647L ~precision:(9000000000L, 9000000000L, 9000000000L),
|
|
"89 59 59.999 N 179 59 59.999 E 21374836.47m 90000000m 90000000m 90000000m"
|
|
) ;
|
|
(
|
|
"89 59 59.999 S 179 59 59.999 W 21374836.47m 90000000m 90000000m 90000000m",
|
|
Loc.parse ~latitude:((89l, 59l, (59999l)), `South) ~longitude:((179l, 59l, (59999l)), `West) ~altitude:2137483647L ~precision:(9000000000L, 9000000000L, 9000000000L),
|
|
"89 59 59.999 S 179 59 59.999 W 21374836.47m 90000000m 90000000m 90000000m"
|
|
) ;
|
|
(
|
|
"90 0 0 N 180 0 0 E 21374836.47m 90000000m 90000000m 90000000m",
|
|
Loc.parse ~latitude:((90l, 0l, (0l)), `North) ~longitude:((180l, 0l, (0l)), `East) ~altitude:2137483647L ~precision:(9000000000L, 9000000000L, 9000000000L),
|
|
"90 0 0 N 180 0 0 E 21374836.47m 90000000m 90000000m 90000000m"
|
|
) ;
|
|
(
|
|
"90 0 0 S 180 0 0 W 21374836.47m 90000000m 90000000m 90000000m",
|
|
Loc.parse ~latitude:((90l, 0l, (0l)), `South) ~longitude:((180l, 0l, (0l)), `West) ~altitude:2137483647L ~precision:(9000000000L, 9000000000L, 9000000000L),
|
|
"90 0 0 S 180 0 0 W 21374836.47m 90000000m 90000000m 90000000m"
|
|
) ;
|
|
(
|
|
"90 0 0 N 180 0 0 E 21374836.48m 90000000m 90000000m 90000000m",
|
|
Loc.parse ~latitude:((90l, 0l, (0l)), `North) ~longitude:((180l, 0l, (0l)), `East) ~altitude:2137483648L ~precision:(9000000000L, 9000000000L, 9000000000L),
|
|
"90 0 0 N 180 0 0 E 21374836.48m 90000000m 90000000m 90000000m"
|
|
) ;
|
|
(
|
|
"90 0 0 N 180 0 0 E 21374836.49m 90000000m 90000000m 90000000m",
|
|
Loc.parse ~latitude:((90l, 0l, (0l)), `North) ~longitude:((180l, 0l, (0l)), `East) ~altitude:2137483649L ~precision:(9000000000L, 9000000000L, 9000000000L),
|
|
"90 0 0 N 180 0 0 E 21374836.49m 90000000m 90000000m 90000000m"
|
|
) ;
|
|
(
|
|
"90 0 0 N 180 0 0 E 42849672.95m 90000000m 90000000m 90000000m",
|
|
Loc.parse ~latitude:((90l, 0l, (0l)), `North) ~longitude:((180l, 0l, (0l)), `East) ~altitude:4284967295L ~precision:(9000000000L, 9000000000L, 9000000000L),
|
|
"90 0 0 N 180 0 0 E 42849672.95m 90000000m 90000000m 90000000m"
|
|
) ;
|
|
(
|
|
"0 0 0 N 0 0 0 E 0m 0.01m 1.01m 90000000m",
|
|
Loc.parse ~latitude:((0l, 0l, 0l), `North) ~longitude:((0l, 0l, 0l), `East) ~altitude:0L ~precision:(1L, 101L, 9000000000L),
|
|
"0 0 0 N 0 0 0 E 0m 0.01m 1m 90000000m"
|
|
) ;
|
|
(
|
|
"52 12 40 N 0 5 31 W 22.1m 10m 10m 10m",
|
|
Loc.parse ~latitude:((52l, 12l, 40000l), `North) ~longitude:((0l, 5l, 31000l), `West) ~altitude:2210L ~precision:(1000L, 1000L, 1000L),
|
|
"52 12 40 N 0 5 31 W 22.1m 10m 10m 10m"
|
|
) ;(
|
|
"52 12 40.42 N 0 5 31.91 E 22.12m 10m 10m 10m",
|
|
Loc.parse ~latitude:((52l, 12l, 40420l), `North) ~longitude:((0l, 5l, 31910l), `East) ~altitude:2212L ~precision:(1000L, 1000L, 1000L),
|
|
"52 12 40.42 N 0 5 31.91 E 22.12m 10m 10m 10m"
|
|
) ;
|
|
(
|
|
"52 12 40.4 N 0 5 31.9 E 22m 10m 10m",
|
|
Loc.parse ~latitude:((52l, 12l, 40400l), `North) ~longitude:((0l, 5l, 31900l), `East) ~altitude:2200L ~precision:(1000L, 1000L, 1000L),
|
|
"52 12 40.4 N 0 5 31.9 E 22m 10m 10m 10m"
|
|
) ;
|
|
(
|
|
"52 12 40.4 N 0 5 31.9 E 22m 10m",
|
|
Loc.parse ~latitude:((52l, 12l, 40400l), `North) ~longitude:((0l, 5l, 31900l), `East) ~altitude:2200L ~precision:(1000L, 1000000L, 1000L),
|
|
"52 12 40.4 N 0 5 31.9 E 22m 10m 10000m 10m"
|
|
) ;
|
|
(
|
|
"52 12 40.4 N 0 5 31.9 E 22m",
|
|
Loc.parse ~latitude:((52l, 12l, 40400l), `North) ~longitude:((0l, 5l, 31900l), `East) ~altitude:2200L ~precision:(100L, 1000000L, 1000L),
|
|
"52 12 40.4 N 0 5 31.9 E 22m 1m 10000m 10m"
|
|
) ;
|
|
] in
|
|
let parse_loc (loc_str, loc, loc_printed) =
|
|
let rrs =
|
|
let z = n_of_s "example" in
|
|
let ns_name = n_of_s "ns.example" in
|
|
let minimum = 2560l in
|
|
let ns = 2560l, Domain_name.(Host_set.singleton (host_exn ns_name)) in
|
|
let soa = { Soa.nameserver = ns_name ; hostmaster = n_of_s "root.example" ;
|
|
serial = 1l ; refresh = 86400l ; retry = 10800l ;
|
|
expiry = 1048576l ; minimum }
|
|
in
|
|
Name_rr_map.(add z Rr_map.Ns ns
|
|
(add z Rr_map.Soa soa
|
|
(singleton (n_of_s "example") Rr_map.Loc (minimum, Rr_map.Loc_set.singleton loc))
|
|
)
|
|
)
|
|
in
|
|
let _ = Printf.printf "%s" (loc_zone ^ loc_str ^ "\n") in
|
|
Alcotest.(check (result name_map_ok err) "parsing loc zone"
|
|
(Ok rrs) (Dns_zone.parse (loc_zone ^ loc_str ^ "\n"))) ;
|
|
let string_ok =
|
|
let module M = struct
|
|
type t = string
|
|
let pp = Format.pp_print_string
|
|
let equal = String.equal
|
|
end in
|
|
(module M: Alcotest.TESTABLE with type t = M.t)
|
|
in
|
|
Alcotest.(check string_ok "parsing loc zone" (loc_printed) (Loc.to_string loc)) ;
|
|
in List.iter parse_loc loc_strs
|
|
|
|
let tests = [
|
|
"parsing simple zone", `Quick, parse_simple_zone ;
|
|
"parsing simple zone 2", `Quick, parse_simple_zone_2 ;
|
|
"parsing simple zone 3", `Quick, parse_simple_zone_3 ;
|
|
"parsing simple zone without final newline", `Quick, parse_simple_zone_without_nl ;
|
|
"parsing wildcard zone", `Quick, parse_wildcard_zone ;
|
|
"parsing RFC 4592 zone", `Quick, parse_rfc4592_zone ;
|
|
"RFC 4592 questions", `Quick, rfc4592_questions ;
|
|
"parse zone with additional glue", `Quick, parse_zone_with_glue ;
|
|
"parse zone with additional glue and sub", `Quick, parse_zone_with_glue_sub ;
|
|
"parsing numerical subdomain zone", `Quick, parse_numerical_subdomain_zone ;
|
|
"parse locs", `Quick, parse_locs ;
|
|
]
|
|
end
|
|
|
|
let tests = [
|
|
"Trie", Trie.tests ;
|
|
"Server", S.tests ;
|
|
"Authentication", A.tests ;
|
|
"AXFR", Axfr.tests ;
|
|
"Zone", Zone.tests ;
|
|
]
|
|
|
|
let () =
|
|
Mirage_crypto_rng_unix.use_default ();
|
|
Alcotest.run "DNS server tests" tests
|