gazagnaire.org
DNS wire codec, cache, stub resolver and forwarder
dns: one home directory, the eio transport as ocaml-dns/lib/eio
The nox-dns fork and its Eio transport were two top-level directories
(nox-dns/, ocaml-dns-eio/); protocol packages here keep the IO adapter
as a sub-library of the protocol's own directory (ocaml-ttrpc/lib/eio,
ocaml-rego/lib/server), and package directories carry the ocaml- name
even when the opam name is nox- prefixed (ocaml-varint/nox-varint). So:
nox-dns/ becomes ocaml-dns/, the transport moves to lib/eio and its
tests to test/eio, and one dune-project declares both packages
(nox-dns, dns-eio). The fork module drops its now project-prefixed
name: Nox_dns.Dns_client becomes Nox_dns.Client (client.ml), content
unchanged. Opam package names, library names and consumer dune files
are unchanged.
author
Thomas Gazagnaire
date
(Jul 4, 2026, 9:13 PM -0700)
commit
0c9632f2
0c9632f244659b9f57d9d08405ec17549e4875f1
+3689
+1
.ocamlformat
+1
.ocamlformat
···
1
+
profile = default
+23
LICENSE.md
+23
LICENSE.md
···
1
+
Copyright (c) 2017, 2018, Hannes Mehnert
2
+
All rights reserved.
3
+
4
+
Redistribution and use in source and binary forms, with or without modification,
5
+
are permitted provided that the following conditions are met:
6
+
7
+
* Redistributions of source code must retain the above copyright notice, this
8
+
list of conditions and the following disclaimer.
9
+
10
+
* Redistributions in binary form must reproduce the above copyright notice, this
11
+
list of conditions and the following disclaimer in the documentation and/or
12
+
other materials provided with the distribution.
13
+
14
+
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
15
+
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
16
+
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
17
+
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR
18
+
ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
19
+
(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
20
+
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
21
+
ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
22
+
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
23
+
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+114
README.md
+114
README.md
···
1
+
# nox-dns
2
+
3
+
A fork of [ocaml-dns](https://github.com/mirage/ocaml-dns)'s `dns-client` with
4
+
one change: the clock and the RNG are injected rather than fixed by the
5
+
transport.
6
+
7
+
## Why this fork exists
8
+
9
+
`ocaml-dns`'s `Dns_client` is transport-agnostic -- `Dns_client.Make (T)` takes
10
+
a transport `T` that provides the network I/O -- which is the right shape. But
11
+
its transport module type `S` also requires two *module-level* values:
12
+
13
+
```
14
+
val rng : int -> string
15
+
val clock : unit -> int64
16
+
```
17
+
18
+
Because they are module-level, every transport hardcodes them
19
+
(`dns-client.unix`, `.lwt`, `.mirage`, and the direct-style `.miou-unix` all do
20
+
`let clock = Mtime_clock.elapsed_ns` and `let rng = Mirage_crypto_rng.generate`).
21
+
22
+
This is *not* about freestanding being impossible -- it is not. A miou-solo5 (or
23
+
Eio-on-Solo5) transport can run freestanding perfectly well by binding `clock`
24
+
to the runtime's own monotonic source instead of `Mtime_clock`.
25
+
26
+
The mismatch is with the **capability model**. In Eio the clock and the RNG are
27
+
*capabilities* threaded per run from the environment (`Eio.Time.Mono`, the
28
+
process RNG) -- not module globals a library reaches for. Squeezing a per-run
29
+
capability into a module-level `clock : unit -> int64` would force either a
30
+
functor-over-clock or a mutable global inside every transport. It also blocks a
31
+
deterministic clock in tests. So the values want to be *injected*, not fixed by
32
+
the transport module.
33
+
34
+
This fork therefore **lifts `rng` and `clock` out of the transport `S` and into
35
+
`Make.v`** (the constructor, renamed from upstream's `create` to the repo's `v`
36
+
convention):
37
+
38
+
```
39
+
val v :
40
+
?cache_size:int -> ?edns:... -> ?nameservers:... -> ?timeout:int64 ->
41
+
clock:(unit -> int64) -> rng:(int -> string) ->
42
+
T.stack -> t
43
+
```
44
+
45
+
The transport (`S`) becomes pure I/O -- `connect` / `send_recv` / `close` -- and
46
+
the caller injects the clock and RNG. That is the whole diff.
47
+
48
+
## What is unchanged
49
+
50
+
Everything else is upstream's, near-verbatim (so it stays easy to diff and to
51
+
contribute the clock abstraction back): the DNS wire codec is the upstream `dns`
52
+
package (a dependency, not vendored); the query building, CNAME following,
53
+
response matching, RFC 7766 TCP length-prefix framing, RFC 6761 special names,
54
+
and the `Dns_cache` are `Dns_client`'s. The changed lines carry a comment noting
55
+
the difference from upstream, in `lib/client.ml` and `lib/client.mli`.
56
+
57
+
## Usage
58
+
59
+
`nox-dns` is the transport-agnostic core. Provide a transport and inject a
60
+
clock + RNG:
61
+
62
+
```
63
+
module Client = Nox_dns.Client.Make (My_transport)
64
+
65
+
let t = Client.v ~clock ~rng ~nameservers stack in
66
+
Client.getaddrinfo t Dns.Rr_map.A name
67
+
```
68
+
69
+
The Eio transport lives in this directory at `lib/eio`, packaged as
70
+
`dns-eio`: it injects the Eio clock and the process RNG, and its TCP mode
71
+
(RFC 7766) needs only `Eio.Net.connect`, so it resolves over a unikernel's
72
+
TCP-only stack.
73
+
74
+
## dns-eio: the Eio transport
75
+
76
+
Single-shot A / AAAA / TXT queries through the client above, over UDP or
77
+
TCP (`~proto`). A resolver picks up the nameservers from
78
+
`/etc/resolv.conf`, falling back to Cloudflare (`1.1.1.1`) and Google
79
+
(`8.8.8.8`) if that file is missing or empty. The list can be overridden
80
+
at construction:
81
+
82
+
```ocaml
83
+
# let resolver =
84
+
Dns_eio.v
85
+
~nameservers:[ Ipaddr.of_string_exn "1.1.1.1" ]
86
+
~timeout_s:1.0 () in
87
+
List.map Ipaddr.to_string (Dns_eio.nameservers resolver)
88
+
- : string list = ["1.1.1.1"]
89
+
```
90
+
91
+
Each query takes a switch, a net, and a clock so the caller controls
92
+
socket lifetime:
93
+
94
+
```ocaml
95
+
let lookup_txt env name =
96
+
Eio.Switch.run @@ fun sw ->
97
+
let resolver = Dns_eio.v () in
98
+
match
99
+
Dns_eio.txt resolver
100
+
~sw
101
+
~net:(Eio.Stdenv.net env)
102
+
~clock:(Eio.Stdenv.clock env)
103
+
name
104
+
with
105
+
| Ok records -> List.iter print_endline records
106
+
| Error e -> Fmt.pr "DNS error: %a@." Dns_eio.pp_error e
107
+
```
108
+
109
+
The same pattern applies to `Dns_eio.a` (IPv4) and `Dns_eio.aaaa` (IPv6).
110
+
111
+
## License
112
+
113
+
ISC, as upstream ocaml-dns. See [LICENSE.md](LICENSE.md); copyright is the
114
+
upstream authors' plus this fork's changes.
+94
bench/bench.ml
+94
bench/bench.ml
···
1
+
(* Throughput and per-query allocation of the I/O-free forwarder core. The
2
+
decision path -- decode, hosts/cache lookup, reply build -- is pure OCaml with
3
+
no syscalls, so it is measured directly in a tight loop. The forward path also
4
+
builds the upstream queries (0x20 + EDNS) without sending them. *)
5
+
6
+
module F = Nox_dns.Forward
7
+
module C = Nox_dns.Forward_config
8
+
module Hosts = Nox_dns.Hosts
9
+
module Pure = Nox_dns.Client.Pure
10
+
11
+
let dn = Domain_name.of_string_exn
12
+
let rng n = String.make n '\001'
13
+
let clock () = 1_000_000_000L
14
+
15
+
let single_upstream ip =
16
+
{
17
+
C.servers =
18
+
C.Server.Set.singleton
19
+
{
20
+
zones = C.Domain.Set.empty;
21
+
address = { ip = Ipaddr.of_string_exn ip; port = 53 };
22
+
timeout = None;
23
+
order = 0;
24
+
};
25
+
search = [];
26
+
assume_offline_after_drops = Some 4;
27
+
}
28
+
29
+
(* A canned upstream A answer to an attempt's query, used to prime the cache. *)
30
+
let canned_a attempt data =
31
+
match Dns.Packet.decode (F.attempt_query attempt) with
32
+
| Error _ -> failwith "attempt query did not decode"
33
+
| Ok q ->
34
+
let flags =
35
+
Dns.Packet.Flags.of_list [ `Recursion_desired; `Recursion_available ]
36
+
in
37
+
let name, _ = q.Dns.Packet.question in
38
+
let ans =
39
+
(Dns.Name_rr_map.singleton name Dns.Rr_map.A data, Dns.Name_rr_map.empty)
40
+
in
41
+
let reply =
42
+
Dns.Packet.create
43
+
(fst q.Dns.Packet.header, flags)
44
+
q.Dns.Packet.question (`Answer ans)
45
+
in
46
+
fst (Dns.Packet.encode `Udp reply)
47
+
48
+
let measure name n f =
49
+
for _ = 1 to 10_000 do
50
+
ignore (Sys.opaque_identity (f ()))
51
+
done;
52
+
Gc.full_major ();
53
+
let a0 = Gc.allocated_bytes () in
54
+
let t0 = Unix.gettimeofday () in
55
+
for _ = 1 to n do
56
+
ignore (Sys.opaque_identity (f ()))
57
+
done;
58
+
let t1 = Unix.gettimeofday () in
59
+
let a1 = Gc.allocated_bytes () in
60
+
let dt = t1 -. t0 in
61
+
Fmt.pr "%-22s %10.0f q/s %6.0f ns/query %8.1f words/query@." name
62
+
(float_of_int n /. dt)
63
+
(dt *. 1e9 /. float_of_int n)
64
+
((a1 -. a0) /. float_of_int n /. 8.)
65
+
66
+
let () =
67
+
let n = 1_000_000 in
68
+
(* hosts hit: decode + hosts lookup + reply build *)
69
+
let hosts = Hosts.of_string "203.0.113.9 svc.local\n" in
70
+
let fw_hosts = F.v ~hosts ~rng ~clock () in
71
+
let hq, _ = Pure.make_query rng `Udp `None (dn "svc.local") Dns.Rr_map.A in
72
+
measure "hosts hit" n (fun () -> F.decide fw_hosts hq);
73
+
74
+
(* cache hit: decode + cache lookup + reply build *)
75
+
let fw = F.v ~cfg:(single_upstream "1.1.1.1") ~rng ~clock () in
76
+
let cq, _ = Pure.make_query rng `Udp `None (dn "example.com") Dns.Rr_map.A in
77
+
(match F.decide fw cq with
78
+
| F.Forward req ->
79
+
let att = List.hd (List.hd req.groups) in
80
+
let resp =
81
+
canned_a att
82
+
( 300l,
83
+
Ipaddr.V4.Set.singleton (Ipaddr.V4.of_string_exn "93.184.216.34") )
84
+
in
85
+
ignore (F.on_reply fw req att resp)
86
+
| _ -> failwith "priming failed");
87
+
measure "cache hit" n (fun () -> F.decide fw cq);
88
+
89
+
(* forward decision: decode + select + 0x20 + EDNS query build (no I/O) *)
90
+
let fw2 = F.v ~cfg:(single_upstream "1.1.1.1") ~rng ~clock () in
91
+
let mq, _ =
92
+
Pure.make_query rng `Udp `None (dn "miss.example.org") Dns.Rr_map.A
93
+
in
94
+
measure "forward decision" n (fun () -> F.decide fw2 mq)
+3
bench/dune
+3
bench/dune
+42
dns-eio.opam
+42
dns-eio.opam
···
1
+
# This file is generated by dune, edit dune-project instead
2
+
opam-version: "2.0"
3
+
synopsis: "Eio transport for the nox-dns stub resolver"
4
+
maintainer: ["Thomas Gazagnaire <thomas@gazagnaire.org>"]
5
+
authors: ["Thomas Gazagnaire <thomas@gazagnaire.org>"]
6
+
license: "ISC"
7
+
tags: ["org:blacksun" "network" "eio"]
8
+
homepage: "https://tangled.org/gazagnaire.org/ocaml-dns"
9
+
bug-reports: "https://tangled.org/gazagnaire.org/ocaml-dns/issues"
10
+
depends: [
11
+
"dune" {>= "3.21"}
12
+
"ocaml" {>= "5.1"}
13
+
"re" {with-test}
14
+
"nox-dns"
15
+
"dns"
16
+
"eio"
17
+
"ipaddr"
18
+
"cstruct"
19
+
"domain-name"
20
+
"fmt"
21
+
"mtime"
22
+
"alcotest" {with-test}
23
+
"nox-csv" {with-test}
24
+
"mdx" {with-test}
25
+
"odoc" {with-doc}
26
+
]
27
+
build: [
28
+
["dune" "subst"] {dev}
29
+
[
30
+
"dune"
31
+
"build"
32
+
"-p"
33
+
name
34
+
"-j"
35
+
jobs
36
+
"@install"
37
+
"@runtest" {with-test}
38
+
"@doc" {with-doc}
39
+
]
40
+
]
41
+
dev-repo: "git+https://tangled.org/gazagnaire.org/ocaml-dns"
42
+
x-maintenance-intent: ["(latest)"]
+8
dune
+8
dune
+47
dune-project
+47
dune-project
···
1
+
(lang dune 3.21)
2
+
(using mdx 0.4)
3
+
(name nox-dns)
4
+
(source (tangled gazagnaire.org/ocaml-dns))
5
+
(license ISC)
6
+
(authors "Thomas Gazagnaire <thomas@gazagnaire.org>")
7
+
(maintainers "Thomas Gazagnaire <thomas@gazagnaire.org>")
8
+
9
+
(generate_opam_files true)
10
+
(implicit_transitive_deps false)
11
+
12
+
(package
13
+
(name nox-dns)
14
+
(synopsis "Experimental fork of the ocaml-dns stub client with an injected clock")
15
+
(description
16
+
"A near-verbatim fork of ocaml-dns's Dns_client (the transport-agnostic stub resolver: query building, response matching, TCP framing, and a cache, over the upstream dns wire codec). The one change is that the monotonic clock and the RNG are lifted out of the transport module type into explicit parameters of Make.create, rather than being module-level globals every upstream transport binds to Mtime_clock.elapsed_ns and Mirage_crypto_rng. That lets the client run on a caller-supplied clock -- a unikernel's clock with no OS dependency, or a deterministic clock in tests -- so an Eio transport (nox-dns's dns-eio) can be freestanding. The wire format and the client logic are upstream's; the intent is to upstream the clock abstraction back to ocaml-dns.")
17
+
(tags (org:blacksun network))
18
+
(depends
19
+
(ocaml (>= 4.14.0))
20
+
(dune (>= 3.0))
21
+
dns
22
+
randomconv
23
+
domain-name
24
+
ipaddr
25
+
logs
26
+
duration
27
+
ohex
28
+
fmt))
29
+
30
+
(package
31
+
(name dns-eio)
32
+
(synopsis "Eio transport for the nox-dns stub resolver")
33
+
(tags (org:blacksun network eio))
34
+
(depends
35
+
(ocaml (>= 5.1))
36
+
(re :with-test)
37
+
nox-dns
38
+
dns
39
+
eio
40
+
ipaddr
41
+
cstruct
42
+
domain-name
43
+
fmt
44
+
mtime
45
+
(alcotest :with-test)
46
+
(nox-csv :with-test)
47
+
(mdx :with-test)))
+27
lib/case0x20.ml
+27
lib/case0x20.ml
···
1
+
(* DNS 0x20 encoding (draft-vixie-dnsext-dns0x20): randomise the letter-case of
2
+
the query name. A conformant resolver echoes the exact case in its response,
3
+
so an off-path spoofer -- who cannot see the case pattern -- must also guess
4
+
it, adding ~1 bit of entropy per letter on top of the 16-bit id and source
5
+
port. [verify] checks the response echoed the case exactly. *)
6
+
7
+
let encode ~rng name =
8
+
let labels = Domain_name.to_strings name in
9
+
let total = List.fold_left (fun a l -> a + String.length l) 0 labels in
10
+
if total = 0 then name
11
+
else
12
+
let bits = rng total in
13
+
let idx = ref 0 in
14
+
let recase c =
15
+
let up = Char.code bits.[!idx] land 1 = 1 in
16
+
incr idx;
17
+
if (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') then
18
+
if up then Char.uppercase_ascii c else Char.lowercase_ascii c
19
+
else c
20
+
in
21
+
let labels = List.map (String.map recase) labels in
22
+
match Domain_name.of_strings labels with Ok n -> n | Error _ -> name
23
+
24
+
let verify ~sent ~received =
25
+
let ls = Domain_name.to_strings sent
26
+
and lr = Domain_name.to_strings received in
27
+
List.length ls = List.length lr && List.for_all2 String.equal ls lr
+16
lib/case0x20.mli
+16
lib/case0x20.mli
···
1
+
(** DNS 0x20 query-name case randomisation (draft-vixie-dnsext-dns0x20).
2
+
3
+
Randomising the letter-case of the query name adds anti-spoofing entropy: a
4
+
conformant resolver echoes the case exactly, so an off-path attacker must
5
+
guess it as well as the id and source port. *)
6
+
7
+
val encode :
8
+
rng:(int -> string) -> [ `raw ] Domain_name.t -> [ `raw ] Domain_name.t
9
+
(** [encode ~rng name] is [name] with each letter's case chosen at random. The
10
+
name compares equal to the original (domain names are case-insensitive), so
11
+
only {!verify} distinguishes them. *)
12
+
13
+
val verify :
14
+
sent:[ `raw ] Domain_name.t -> received:[ `raw ] Domain_name.t -> bool
15
+
(** [verify ~sent ~received] is whether [received] echoes [sent]'s case exactly,
16
+
label for label. *)
+366
lib/client.ml
+366
lib/client.ml
···
1
+
open Dns
2
+
3
+
let src = Logs.Src.create "dns_client" ~doc:"DNS client"
4
+
5
+
module Log = (val Logs.src_log src : Logs.LOG)
6
+
7
+
let err_msg fmt = Fmt.kstr (fun m -> Error (`Msg m)) fmt
8
+
9
+
module Pure = struct
10
+
type 'key query_state = {
11
+
protocol : Dns.proto;
12
+
key : 'key;
13
+
query : Packet.t;
14
+
}
15
+
constraint 'key = 'a Rr_map.key
16
+
17
+
let make_query rng protocol ?(dnssec = false) edns hostname :
18
+
'xy -> string * 'xy query_state =
19
+
(* SRV records: Service + Protocol are case-insensitive, see RFC2728 pg2. *)
20
+
fun record_type ->
21
+
let edns =
22
+
match edns with
23
+
| `None -> None
24
+
| `Manual e -> Some e
25
+
| `Auto -> (
26
+
match protocol with
27
+
| `Udp -> None
28
+
| `Tcp ->
29
+
Some
30
+
(Edns.create ~extensions:[ Edns.Tcp_keepalive (Some 1200) ] ()))
31
+
in
32
+
let question = Packet.Question.create hostname record_type in
33
+
let header =
34
+
let flags = Packet.Flags.singleton `Recursion_desired in
35
+
let flags =
36
+
if dnssec then Packet.Flags.add `Authentic_data flags else flags
37
+
in
38
+
(Randomconv.int16 rng, flags)
39
+
in
40
+
let query = Packet.create ?edns header question `Query in
41
+
Log.debug (fun m -> m "sending %a" Dns.Packet.pp query);
42
+
let cs, _ = Packet.encode protocol query in
43
+
( begin match protocol with
44
+
| `Udp -> cs
45
+
| `Tcp ->
46
+
let len_field = Bytes.create 2 in
47
+
Bytes.set_uint16_be len_field 0 (String.length cs);
48
+
String.concat "" [ Bytes.unsafe_to_string len_field; cs ]
49
+
end,
50
+
{ protocol; query; key = record_type } )
51
+
52
+
(* name: the originally requested domain name. *)
53
+
(* NOTE that this function compresses answers:
54
+
foo.example CNAME 500 bar.example
55
+
bar.example A 300 1.2.3.4
56
+
is compressed to:
57
+
foo.example A 300 1.2.3.4
58
+
-> which is fine for applications (i think so)
59
+
-> which is struggling for the cache (not entirely sure about this tbh)
60
+
-> it is not clear whether it meets the DNS specifications nicely *)
61
+
let rec follow_cname name ~iterations:iterations_left ~answer ~state =
62
+
if iterations_left <= 0 then Error (`Msg "CNAME recursion too deep")
63
+
else
64
+
match Domain_name.Map.find_opt name answer with
65
+
| None -> Ok (`Need_soa name)
66
+
| Some relevant_map -> (
67
+
match Rr_map.find state.key relevant_map with
68
+
| Some response -> Ok (`Data response)
69
+
| None -> (
70
+
match Rr_map.(find Cname relevant_map) with
71
+
| None -> Error (`Msg "Invalid DNS response")
72
+
| Some (_ttl, redirected_host) ->
73
+
let iterations = pred iterations_left in
74
+
follow_cname redirected_host ~iterations ~answer ~state))
75
+
76
+
let consume_protocol_prefix buf = function
77
+
(* consume TCP two-byte length prefix: *)
78
+
| `Udp -> Ok buf
79
+
| `Tcp -> (
80
+
match String.get_uint16_be buf 0 with
81
+
| exception Invalid_argument _ -> Error () (* TODO *)
82
+
| pkt_len when pkt_len > String.length buf - 2 ->
83
+
Log.debug (fun m ->
84
+
m "Partial: %d >= %d-2" pkt_len (String.length buf));
85
+
Error () (* TODO return remaining # *)
86
+
| pkt_len ->
87
+
if 2 + pkt_len < String.length buf then
88
+
Log.warn (fun m -> m "Extraneous data in DNS response");
89
+
Ok (String.sub buf 2 pkt_len))
90
+
91
+
let find_soa authority =
92
+
Domain_name.Map.fold
93
+
(fun k rr_map acc ->
94
+
match Rr_map.(find Soa rr_map) with
95
+
| Some soa -> Some (Domain_name.raw k, soa)
96
+
| None -> acc)
97
+
authority None
98
+
99
+
let distinguish_answer state =
100
+
let ( let* ) = Result.bind in
101
+
function
102
+
| `Answer (answer, authority) when not (Domain_name.Map.is_empty answer) ->
103
+
begin
104
+
let q = fst state.query.question in
105
+
let* o = follow_cname q ~iterations:20 ~answer ~state in
106
+
match o with
107
+
| `Data x -> Ok (`Data x)
108
+
| `Need_soa _name -> (
109
+
(* should we retain CNAMEs (and send them to the client)? *)
110
+
(* should we 'adjust' the SOA name to be _name? *)
111
+
match find_soa authority with
112
+
| Some soa -> Ok (`No_data soa)
113
+
| None -> Error (`Msg "invalid reply, couldn't find SOA"))
114
+
end
115
+
| `Answer (_, authority) ->
116
+
begin match find_soa authority with
117
+
| Some soa -> Ok (`No_data soa)
118
+
| None -> Error (`Msg "invalid reply, no SOA in no data")
119
+
end
120
+
| `Rcode_error (Rcode.NXDomain, Opcode.Query, Some (_answer, authority)) ->
121
+
begin match find_soa authority with
122
+
| Some soa -> Ok (`No_domain soa)
123
+
| None -> Error (`Msg "invalid reply, no SOA in nodomain")
124
+
end
125
+
| r -> err_msg "Ok %a, expected answer" Packet.pp_reply r
126
+
127
+
let consume_rest_of_buffer state buf =
128
+
let to_msg t =
129
+
Result.map_error (fun e ->
130
+
`Msg
131
+
(Fmt.str
132
+
"QUERY: @[<v>hdr:%a (id: %d = %d) (q=q: %B)@ query:%a%a opt:%a \
133
+
tsig:%B@,\
134
+
failed: %a@,\
135
+
@]"
136
+
Packet.pp_header t (fst t.header) (fst state.query.header)
137
+
(Packet.Question.compare t.question state.query.question = 0)
138
+
Packet.Question.pp t.question Packet.pp_data t.data
139
+
(Fmt.option Dns.Edns.pp) t.edns
140
+
(match t.tsig with None -> false | Some _ -> true)
141
+
Packet.pp_mismatch e))
142
+
in
143
+
match Packet.decode buf with
144
+
| Error `Partial as e -> e
145
+
| Error err -> err_msg "Error parsing response: %a" Packet.pp_err err
146
+
| Ok t ->
147
+
Log.debug (fun m -> m "received %a" Dns.Packet.pp t);
148
+
to_msg t (Packet.reply_matches_request ~request:state.query t)
149
+
150
+
let parse_response (type requested) :
151
+
requested Rr_map.key query_state ->
152
+
string ->
153
+
(Packet.reply, [> `Partial | `Msg of string ]) result =
154
+
fun state buf ->
155
+
match consume_protocol_prefix buf state.protocol with
156
+
| Ok buf -> consume_rest_of_buffer state buf
157
+
| Error () -> Error `Partial
158
+
159
+
let handle_response (type requested) :
160
+
requested Rr_map.key query_state ->
161
+
string ->
162
+
( [ `Data of requested
163
+
| `Partial
164
+
| `No_data of [ `raw ] Domain_name.t * Soa.t
165
+
| `No_domain of [ `raw ] Domain_name.t * Soa.t ],
166
+
[ `Msg of string ] )
167
+
result =
168
+
fun state buf ->
169
+
match parse_response state buf with
170
+
| Error `Partial -> Ok `Partial
171
+
| Error (`Msg _) as e -> e
172
+
| Ok reply -> distinguish_answer state reply
173
+
end
174
+
175
+
(* Anycast address of uncensoreddns.org *)
176
+
let default_resolver_hostname =
177
+
Domain_name.(host_exn (of_string_exn "anycast.uncensoreddns.org"))
178
+
179
+
let default_resolvers =
180
+
[
181
+
Ipaddr.of_string_exn "2001:67c:28a4::";
182
+
Ipaddr.of_string_exn "91.239.100.100";
183
+
]
184
+
185
+
module type S = sig
186
+
type context
187
+
type +'a io
188
+
type io_addr
189
+
type stack
190
+
type t
191
+
192
+
val v : ?nameservers:Dns.proto * io_addr list -> timeout:int64 -> stack -> t
193
+
val nameservers : t -> Dns.proto * io_addr list
194
+
195
+
(* Changed from upstream ocaml-dns: [rng] and [clock] are lifted out of the
196
+
transport into parameters of {!Make.v} below. Upstream requires them as
197
+
module-level transport values, so every transport hardcodes them (unix,
198
+
lwt, mirage and miou-unix all bind [Mtime_clock.elapsed_ns] and
199
+
[Mirage_crypto_rng]). That runs freestanding fine, but under Eio the clock
200
+
and RNG are per-run capabilities from the environment, not module globals;
201
+
injected here they are ordinary values the caller passes -- the runtime's
202
+
clock, or a deterministic one in tests. *)
203
+
204
+
val connect : t -> (Dns.proto * context, [> `Msg of string ]) result io
205
+
val send_recv : context -> string -> (string, [> `Msg of string ]) result io
206
+
val close : context -> unit io
207
+
val bind : 'a io -> ('a -> 'b io) -> 'b io
208
+
val lift : 'a -> 'a io
209
+
end
210
+
211
+
let localhost = Domain_name.of_string_exn "localhost"
212
+
let localsoa = Soa.create (Domain_name.prepend_label_exn localhost "ns")
213
+
let invalid = Domain_name.of_string_exn "invalid"
214
+
let invalidsoa = Soa.create (Domain_name.prepend_label_exn invalid "ns")
215
+
216
+
let rfc6761_special (type req) q_name (q_typ : req Dns.Rr_map.key) :
217
+
(req Dns_cache.entry, unit) result =
218
+
if Domain_name.is_subdomain ~domain:localhost ~subdomain:q_name then
219
+
let open Dns.Rr_map in
220
+
match q_typ with
221
+
| A -> Ok (`Entry (300l, Ipaddr.V4.Set.singleton Ipaddr.V4.localhost))
222
+
| Aaaa -> Ok (`Entry (300l, Ipaddr.V6.Set.singleton Ipaddr.V6.localhost))
223
+
| _ -> Ok (`No_domain (localhost, localsoa))
224
+
else if Domain_name.is_subdomain ~domain:invalid ~subdomain:q_name then
225
+
Ok (`No_domain (invalid, invalidsoa))
226
+
else Error ()
227
+
228
+
module Make =
229
+
functor
230
+
(Transport : S)
231
+
->
232
+
struct
233
+
type t = {
234
+
mutable cache : Dns_cache.t;
235
+
transport : Transport.t;
236
+
edns : [ `None | `Auto | `Manual of Dns.Edns.t ];
237
+
(* Injected via [v], rather than transport-module globals (see [S]). *)
238
+
clock : unit -> int64;
239
+
rng : int -> string;
240
+
}
241
+
242
+
let transport { transport; _ } = transport
243
+
244
+
(* TODO eventually use Auto, and retry without on FormErr *)
245
+
let v ?(cache_size = 32) ?(edns = `None) ?nameservers
246
+
?(timeout = Duration.of_sec 5) ~clock ~rng stack =
247
+
{
248
+
cache = Dns_cache.empty cache_size;
249
+
transport = Transport.v ?nameservers ~timeout stack;
250
+
edns;
251
+
clock;
252
+
rng;
253
+
}
254
+
255
+
let nameservers { transport; _ } = Transport.nameservers transport
256
+
let ( >>= ) = Transport.bind
257
+
258
+
(* result-bind *)
259
+
let ( >>| ) a b =
260
+
a >>= function Ok a' -> b a' | Error e -> Transport.lift (Error e)
261
+
262
+
(* result-bind-and-lift *)
263
+
let ( >>|= ) a f = a >>| fun b -> Transport.lift (f b)
264
+
265
+
let lift_ok (type req) :
266
+
(req Dns_cache.entry, 'a) result ->
267
+
( req,
268
+
[> `Msg of string
269
+
| `No_data of [ `raw ] Domain_name.t * Dns.Soa.t
270
+
| `No_domain of [ `raw ] Domain_name.t * Dns.Soa.t ] )
271
+
result = function
272
+
| Ok (`Entry value) -> Ok value
273
+
| Ok (`No_data _ as nodata) -> Error nodata
274
+
| Ok (`No_domain _ as nodom) -> Error nodom
275
+
| Ok (`Serv_fail _) | Error _ -> Error (`Msg "")
276
+
277
+
let get_raw_reply t query_type name =
278
+
Transport.connect t.transport >>| fun (proto, socket) ->
279
+
Log.debug (fun m -> m "Connected to NS.");
280
+
let tx, state =
281
+
Pure.make_query t.rng proto ~dnssec:true t.edns name query_type
282
+
in
283
+
( Transport.send_recv socket tx >>| fun recv_buffer ->
284
+
Log.debug (fun m ->
285
+
m "Read @[<v>%d bytes@]" (String.length recv_buffer));
286
+
Log.debug (fun m -> m "received: %a" (Ohex.pp_hexdump ()) recv_buffer);
287
+
Transport.lift (Pure.parse_response state recv_buffer) )
288
+
>>= fun r ->
289
+
Transport.close socket >>= fun () -> Transport.lift r
290
+
291
+
let get_resource_record (type requested) t
292
+
(query_type : requested Dns.Rr_map.key) name :
293
+
( requested,
294
+
[> `Msg of string
295
+
| `No_data of [ `raw ] Domain_name.t * Dns.Soa.t
296
+
| `No_domain of [ `raw ] Domain_name.t * Dns.Soa.t ] )
297
+
result
298
+
Transport.io =
299
+
let domain_name = Domain_name.raw name in
300
+
match rfc6761_special domain_name query_type |> lift_ok with
301
+
| Ok _ as ok -> Transport.lift ok
302
+
| Error ((`No_data _ | `No_domain _) as nod) ->
303
+
Error nod |> Transport.lift
304
+
| Error (`Msg _) -> (
305
+
let cache', r =
306
+
Dns_cache.get t.cache (t.clock ()) domain_name query_type
307
+
in
308
+
t.cache <- cache';
309
+
match lift_ok (Result.map fst r) with
310
+
| Ok _ as ok -> Transport.lift ok
311
+
| Error ((`No_data _ | `No_domain _) as nod) ->
312
+
Error nod |> Transport.lift
313
+
| Error (`Msg _) ->
314
+
Transport.connect t.transport >>| fun (proto, socket) ->
315
+
Log.debug (fun m -> m "Connected to NS.");
316
+
let tx, state =
317
+
Pure.make_query t.rng proto t.edns name query_type
318
+
in
319
+
( Transport.send_recv socket tx >>| fun recv_buffer ->
320
+
Log.debug (fun m ->
321
+
m "Read @[<v>%d bytes@]" (String.length recv_buffer));
322
+
let update_cache entry =
323
+
let rank = Dns_cache.NonAuthoritativeAnswer in
324
+
let cache =
325
+
Dns_cache.set t.cache (t.clock ()) domain_name query_type
326
+
rank entry
327
+
in
328
+
t.cache <- cache
329
+
in
330
+
Transport.lift
331
+
(match Pure.handle_response state recv_buffer with
332
+
| Ok (`Data x) ->
333
+
update_cache (`Entry x);
334
+
Ok x
335
+
| Ok ((`No_data _ | `No_domain _) as nodom) ->
336
+
update_cache nodom;
337
+
Error nodom
338
+
| Error (`Msg xxx) -> Error (`Msg xxx)
339
+
| Ok `Partial -> Error (`Msg "Truncated UDP response")) )
340
+
>>= fun r ->
341
+
Transport.close socket >>= fun () -> Transport.lift r)
342
+
343
+
let lift_cache_error query_type m =
344
+
(match m with
345
+
| Ok a -> Ok a
346
+
| Error (`Msg msg) -> Error (`Msg msg)
347
+
| Error (#Dns_cache.entry as e) ->
348
+
err_msg "DNS cache error @[%a@]" (Dns_cache.pp_entry query_type) e)
349
+
|> Transport.lift
350
+
351
+
let getaddrinfo (type requested) t (query_type : requested Dns.Rr_map.key)
352
+
name : (requested, [> `Msg of string ]) result Transport.io =
353
+
get_resource_record t query_type name >>= lift_cache_error query_type
354
+
355
+
let gethostbyname stack domain =
356
+
getaddrinfo stack Dns.Rr_map.A domain >>|= fun (_ttl, resp) ->
357
+
match Ipaddr.V4.Set.choose_opt resp with
358
+
| None -> Error (`Msg "No A record found")
359
+
| Some ip -> Ok ip
360
+
361
+
let gethostbyname6 stack domain =
362
+
getaddrinfo stack Dns.Rr_map.Aaaa domain >>|= fun (_ttl, res) ->
363
+
match Ipaddr.V6.Set.choose_opt res with
364
+
| None -> Error (`Msg "No AAAA record found")
365
+
| Some ip -> Ok ip
366
+
end
+226
lib/client.mli
+226
lib/client.mli
···
1
+
(** The transport-agnostic DNS stub client, forked from ocaml-dns so the clock
2
+
and RNG are injected into {!Make.v} rather than fixed by the transport. See
3
+
the package README for the rationale. The wire format and resolution logic
4
+
are ocaml-dns's; only the clock/RNG plumbing differs. *)
5
+
6
+
val default_resolver_hostname : [ `host ] Domain_name.t
7
+
(** [default_resolver_hostname] is the hostname of the default resolver
8
+
(UncensoredDNS.org). *)
9
+
10
+
val default_resolvers : Ipaddr.t list
11
+
(** [default_resolvers] is a list of IPv6 and IPv4 addresses of the default
12
+
resolver. Currently it is the IP address of the UncensoredDNS.org anycast
13
+
service. *)
14
+
15
+
module type S = sig
16
+
type context
17
+
(** A context is a network connection initialized by {!connect} *)
18
+
19
+
type +'a io
20
+
(** [io] is the type of an effect. ['err] is a polymorphic variant. *)
21
+
22
+
type io_addr
23
+
(** An address for a given context type, usually this will consist of IP
24
+
address + a TCP/IP or UDP/IP port number, but for some context types it
25
+
can carry additional information for purposes of cryptographic
26
+
verification. *)
27
+
28
+
type stack
29
+
(** A stack with which to connect. *)
30
+
31
+
type t
32
+
(** The abstract state of a DNS client. *)
33
+
34
+
val v : ?nameservers:Dns.proto * io_addr list -> timeout:int64 -> stack -> t
35
+
(** [v ~nameservers ~timeout stack] creates the state record of the DNS
36
+
client. We use [timeout] (ns) as a cumulative time budget for connect and
37
+
request timeouts. *)
38
+
39
+
val nameservers : t -> Dns.proto * io_addr list
40
+
(** The address of a nameservers that is supposed to work with the underlying
41
+
context, can be used if the user does not want to bother with configuring
42
+
their own.*)
43
+
44
+
(* Changed from upstream ocaml-dns: [rng : int -> string] and
45
+
[clock : unit -> int64] are removed from the transport and passed to
46
+
{!Make.v} instead. Upstream fixes them as module-level transport values
47
+
bound to [Mtime_clock.elapsed_ns] / [Mirage_crypto_rng]; under Eio the clock
48
+
and RNG are per-run capabilities from the environment, so they are injected
49
+
rather than fixed by the transport. *)
50
+
51
+
val connect : t -> (Dns.proto * context, [> `Msg of string ]) result io
52
+
(** [connect t] is a new connection (a {!type-context}) to [t], or an error.
53
+
*)
54
+
55
+
val send_recv : context -> string -> (string, [> `Msg of string ]) result io
56
+
(** [send_recv context buffer] sends [buffer] to the [context] upstream, and
57
+
then reads a buffer. *)
58
+
59
+
val close : context -> unit io
60
+
(** [close context] closes the [context], freeing up resources. *)
61
+
62
+
val bind : 'a io -> ('a -> 'b io) -> 'b io
63
+
(** [bind] is the monadic bind of {!io}, a.k.a. [>>=]. *)
64
+
65
+
val lift : 'a -> 'a io
66
+
(** [lift x] injects a pure value into {!io}, a.k.a. [return]. *)
67
+
end
68
+
69
+
module Make : functor (T : S) -> sig
70
+
type t
71
+
(** The abstract type of a DNS client. *)
72
+
73
+
val transport : t -> T.t
74
+
(** [transport t] is the transport of [t]. *)
75
+
76
+
val v :
77
+
?cache_size:int ->
78
+
?edns:[ `None | `Auto | `Manual of Dns.Edns.t ] ->
79
+
?nameservers:Dns.proto * T.io_addr list ->
80
+
?timeout:int64 ->
81
+
clock:(unit -> int64) ->
82
+
rng:(int -> string) ->
83
+
T.stack ->
84
+
t
85
+
(** [v ~clock ~rng ~cache_size ~edns ~nameservers ~timeout stack] creates the
86
+
state of the DNS client. We use [timeout] (ns, default 5s) as a time
87
+
budget for connect and request timeouts. To specify a timeout, use
88
+
[create ~timeout:(Duration.of_sec 3)]. Whether or not to use
89
+
{{:https://tools.ietf.org/html/rfc6891}EDNS} in queries is controlled by
90
+
[~edns] (defaults to [`None]): if [None], no EDNS will be present, [`Auto]
91
+
adds TCP Keepalive if protocol is TCP, [`Manual edns] adds the EDNS data
92
+
specified.
93
+
94
+
[clock] (a monotonic clock, ns) and [rng] are injected here rather than
95
+
being module-level values of the transport -- the one change from upstream
96
+
ocaml-dns -- so they are ordinary capabilities the caller supplies: the
97
+
runtime's clock (an Eio [Eio.Time.Mono], say), or a deterministic clock in
98
+
tests. *)
99
+
100
+
val nameservers : t -> Dns.proto * T.io_addr list
101
+
(** [nameservers state] returns the list of nameservers to be used. *)
102
+
103
+
val getaddrinfo :
104
+
t ->
105
+
'response Dns.Rr_map.key ->
106
+
'a Domain_name.t ->
107
+
('response, [> `Msg of string ]) result T.io
108
+
(** [getaddrinfo state query_type name] is the [query_type]-dependent response
109
+
regarding [name], or an [Error _] message. See {!Client.query_state}
110
+
for more information about the result types. *)
111
+
112
+
val gethostbyname :
113
+
t ->
114
+
[ `host ] Domain_name.t ->
115
+
(Ipaddr.V4.t, [> `Msg of string ]) result T.io
116
+
(** [gethostbyname state hostname] is the IPv4 address of [hostname] resolved
117
+
via the [state] specified. If the query fails, or if the [domain] does not
118
+
have any IPv4 addresses, an [Error _] message is returned. Any extraneous
119
+
IPv4 addresses are ignored. For an example of using this API, see
120
+
[unix/ohost.ml] in the distribution of this package. *)
121
+
122
+
val gethostbyname6 :
123
+
t ->
124
+
[ `host ] Domain_name.t ->
125
+
(Ipaddr.V6.t, [> `Msg of string ]) result T.io
126
+
(** [gethostbyname6 state hostname] is the IPv6 address of [hostname] resolved
127
+
via the [state] specified.
128
+
129
+
It is the IPv6 equivalent of {!gethostbyname}. *)
130
+
131
+
val get_resource_record :
132
+
t ->
133
+
'response Dns.Rr_map.key ->
134
+
'a Domain_name.t ->
135
+
( 'response,
136
+
[> `Msg of string
137
+
| `No_data of [ `raw ] Domain_name.t * Dns.Soa.t
138
+
| `No_domain of [ `raw ] Domain_name.t * Dns.Soa.t ] )
139
+
result
140
+
T.io
141
+
(** [get_resource_record state query_type name] resolves [query_type, name]
142
+
via the [state] specified. The behaviour is equivalent to {!getaddrinfo},
143
+
apart from the error return value - [get_resource_record] distinguishes
144
+
some errors, at the moment [No_data] if the [name] exists, but not the
145
+
[query_type], and [No_domain] if the [name] does not exist. This allows
146
+
clients to treat these error conditions explicitly. *)
147
+
148
+
val get_raw_reply :
149
+
t ->
150
+
'response Dns.Rr_map.key ->
151
+
'a Domain_name.t ->
152
+
(Dns.Packet.reply, [> `Partial | `Msg of string ]) result T.io
153
+
(** [get_raw_reply state query_type name] resolves [query_type, name] via the
154
+
[state] specified. The complete DNS reply is returned. CNAME records are
155
+
not followed. This allows DNSSec to process the entire reply. *)
156
+
end
157
+
158
+
module Pure : sig
159
+
(** The pure interface to the client part of uDns.
160
+
161
+
Various helper modules to do with side effects are available from
162
+
{!Dns_client_lwt}, {!Dns_client_unix} and so forth. *)
163
+
164
+
type 'key query_state constraint 'key = 'a Dns.Rr_map.key
165
+
(** [query_state] is parameterized over the query type, so the type of the
166
+
representation of the answer depends on what the name server was asked to
167
+
provide. See {!Dns.Rr_map.k} for a list of response types. The first
168
+
element (the [int32]) in most of the tuples is the Time-To-Live (TTL)
169
+
field returned from the server, which you can use to calculate when you
170
+
should request fresh information in case you are writing a long-running
171
+
application. *)
172
+
173
+
val make_query :
174
+
(int -> string) ->
175
+
Dns.proto ->
176
+
?dnssec:bool ->
177
+
[ `None | `Auto | `Manual of Dns.Edns.t ] ->
178
+
'a Domain_name.t ->
179
+
'query_type Dns.Rr_map.key ->
180
+
string * 'query_type Dns.Rr_map.key query_state
181
+
(** [make_query rng protocol edns name query_type] is [(query, state)] where
182
+
[query] is the serialized DNS query to send to the name server, and
183
+
[state] (a {!type-query_state}) is the information required to validate
184
+
the response. *)
185
+
186
+
val parse_response :
187
+
'query_type Dns.Rr_map.key query_state ->
188
+
string ->
189
+
(Dns.Packet.reply, [ `Partial | `Msg of string ]) result
190
+
(** [parse_response query_state response] is the information contained in
191
+
[response] parsed using [query_state] when the query was successful, or an
192
+
[`Msg message] if the [response] did not match the [query_state] (or if
193
+
the query failed).
194
+
195
+
In a TCP usage context the [`Partial] means there are more bytes to be
196
+
read in order to parse correctly. This can happen due to short reads or if
197
+
the server (or something along the route) chunks its responses into
198
+
multiple individual packets. In that case you should concatenate
199
+
[response] and the next received data and call this function again.
200
+
201
+
In a UDP usage context the [`Partial] means information was lost, due to
202
+
an incomplete packet. *)
203
+
204
+
val handle_response :
205
+
'query_type Dns.Rr_map.key query_state ->
206
+
string ->
207
+
( [ `Data of 'query_type
208
+
| `Partial
209
+
| `No_data of [ `raw ] Domain_name.t * Dns.Soa.t
210
+
| `No_domain of [ `raw ] Domain_name.t * Dns.Soa.t ],
211
+
[ `Msg of string ] )
212
+
result
213
+
(** [handle_response query_state response] is the information contained in
214
+
[response] parsed using [query_state] when the query was successful, or an
215
+
[`Msg message] if the [response] did not match the [query_state] (or if
216
+
the query failed).
217
+
218
+
In a TCP usage context the [`Partial] means there are more bytes to be
219
+
read in order to parse correctly. This can happen due to short reads or if
220
+
the server (or something along the route) chunks its responses into
221
+
multiple individual packets. In that case you should concatenate
222
+
[response] and the next received data and call this function again.
223
+
224
+
In a UDP usage context the [`Partial] means information was lost, due to
225
+
an incomplete packet. *)
226
+
end
+16
lib/dune
+16
lib/dune
···
1
+
; Fork of ocaml-dns's dns-client; see README.md. The one change is that the
2
+
; clock and RNG are injected via Make.v, not fixed by the transport.
3
+
4
+
(library
5
+
(name nox_dns)
6
+
(public_name nox-dns)
7
+
(libraries
8
+
dns
9
+
dns.cache
10
+
randomconv
11
+
domain-name
12
+
ipaddr
13
+
logs
14
+
duration
15
+
ohex
16
+
fmt))
+67
lib/edns_policy.ml
+67
lib/edns_policy.ml
···
1
+
(* EDNS(0) policy for the forwarder (RFC 6891): choose a safe UDP payload size,
2
+
decide when a reply must set TC and fall back to TCP, strip EDNS Client Subnet
3
+
before forwarding (privacy, RFC 7871), and carry DNS Cookies (RFC 7873) for
4
+
off-path spoof resistance. All transforms are over Dns.Edns value types. *)
5
+
6
+
(* DNS flag day 2020: advertise at most 1232 bytes over UDP so a reply never
7
+
fragments at the IP layer (1280 v6 MTU minus headers). Never below the 512
8
+
floor. *)
9
+
let safe_max = 1232
10
+
let min_payload = 512
11
+
12
+
let clamp_payload ?(max = safe_max) client =
13
+
let advertised =
14
+
match client with
15
+
| Some (e : Dns.Edns.t) -> e.payload_size
16
+
| None -> min_payload
17
+
in
18
+
Stdlib.max min_payload (Stdlib.min max advertised)
19
+
20
+
let truncated ~reply_len ~udp_size = reply_len > udp_size
21
+
22
+
(* EDNS Client Subnet is option code 8, which ocaml-dns carries as a generic
23
+
[Extension]. A forwarder must not leak the client's subnet to upstreams, so
24
+
drop it before forwarding. *)
25
+
let ecs_code = 8
26
+
27
+
let rebuild (e : Dns.Edns.t) extensions =
28
+
Dns.Edns.create ~extended_rcode:e.extended_rcode ~version:e.version
29
+
~dnssec_ok:e.dnssec_ok ~payload_size:e.payload_size ~extensions ()
30
+
31
+
let strip_ecs (e : Dns.Edns.t) =
32
+
rebuild e
33
+
(List.filter
34
+
(function Dns.Edns.Extension (c, _) -> c <> ecs_code | _ -> true)
35
+
e.extensions)
36
+
37
+
module Cookie = struct
38
+
(* An 8-byte client cookie, plus the 8-32 byte server cookie once learned from
39
+
a response (RFC 7873). Kept per-upstream by the caller. *)
40
+
type t = { client : string; server : string option }
41
+
42
+
let v ~rng = { client = rng 8; server = None }
43
+
let wire c = c.client ^ Option.value ~default:"" c.server
44
+
45
+
let apply c (e : Dns.Edns.t) =
46
+
let extensions =
47
+
Dns.Edns.Cookie (wire c)
48
+
:: List.filter
49
+
(function Dns.Edns.Cookie _ -> false | _ -> true)
50
+
e.extensions
51
+
in
52
+
rebuild e extensions
53
+
54
+
(* Absorb the server cookie from a response whose client-cookie half echoes
55
+
ours; a mismatched or short cookie is ignored. *)
56
+
let learn c (e : Dns.Edns.t) =
57
+
match
58
+
List.find_map
59
+
(function Dns.Edns.Cookie s -> Some s | _ -> None)
60
+
e.extensions
61
+
with
62
+
| Some s when String.length s >= 16 && String.sub s 0 8 = c.client ->
63
+
{ c with server = Some (String.sub s 8 (String.length s - 8)) }
64
+
| _ -> c
65
+
66
+
let has_server c = Option.is_some c.server
67
+
end
+43
lib/edns_policy.mli
+43
lib/edns_policy.mli
···
1
+
(** EDNS(0) policy for the forwarder (RFC 6891).
2
+
3
+
Choose a safe UDP payload size, decide when a reply must set TC and fall
4
+
back to TCP, strip EDNS Client Subnet before forwarding (privacy, RFC 7871),
5
+
and carry DNS Cookies (RFC 7873) for off-path spoof resistance. All
6
+
transforms are over {!Dns.Edns} value types. *)
7
+
8
+
val safe_max : int
9
+
(** [safe_max] is 1232 bytes -- the DNS flag day 2020 UDP ceiling that avoids IP
10
+
fragmentation. *)
11
+
12
+
val clamp_payload : ?max:int -> Dns.Edns.t option -> int
13
+
(** [clamp_payload ~max client] is the UDP payload size to advertise: the
14
+
client's advertised size (512 if it sent no EDNS) clamped to [[512, max]],
15
+
with [max] defaulting to {!safe_max}. *)
16
+
17
+
val truncated : reply_len:int -> udp_size:int -> bool
18
+
(** [truncated ~reply_len ~udp_size] is whether a [reply_len]-byte reply exceeds
19
+
the negotiated [udp_size], so the UDP answer must set TC and the client
20
+
retry over TCP. *)
21
+
22
+
val strip_ecs : Dns.Edns.t -> Dns.Edns.t
23
+
(** [strip_ecs e] removes any EDNS Client Subnet option, so the client's subnet
24
+
is not leaked to upstream resolvers. *)
25
+
26
+
module Cookie : sig
27
+
type t
28
+
(** A per-upstream DNS Cookie: an 8-byte client cookie and, once learned, the
29
+
server cookie. *)
30
+
31
+
val v : rng:(int -> string) -> t
32
+
(** [v ~rng] is a fresh client cookie with no server cookie yet. *)
33
+
34
+
val apply : t -> Dns.Edns.t -> Dns.Edns.t
35
+
(** [apply c e] sets the Cookie option on [e] to [c]'s wire form. *)
36
+
37
+
val learn : t -> Dns.Edns.t -> t
38
+
(** [learn c e] absorbs the server cookie from a response whose client-cookie
39
+
half echoes [c]; a mismatched or short cookie leaves [c] unchanged. *)
40
+
41
+
val has_server : t -> bool
42
+
(** [has_server c] is whether a server cookie has been learned. *)
43
+
end
+210
lib/eio/dns_eio.ml
+210
lib/eio/dns_eio.ml
···
1
+
type error =
2
+
[ `Msg of string
3
+
| `Timeout
4
+
| `Nxdomain
5
+
| `Servfail of int
6
+
| `Truncated
7
+
| `Malformed of string ]
8
+
9
+
let pp_error ppf = function
10
+
| `Msg s -> Fmt.string ppf s
11
+
| `Timeout -> Fmt.string ppf "DNS: no response within timeout"
12
+
| `Nxdomain -> Fmt.string ppf "DNS: name does not exist (NXDOMAIN)"
13
+
| `Servfail rc -> Fmt.pf ppf "DNS: server failure (RCODE %d)" rc
14
+
| `Truncated -> Fmt.string ppf "DNS: response truncated over UDP"
15
+
| `Malformed s -> Fmt.pf ppf "DNS: malformed response: %s" s
16
+
17
+
(* ----- Nameserver discovery ----- *)
18
+
19
+
let parse_resolv_conf content =
20
+
content |> String.split_on_char '\n'
21
+
|> List.filter_map (fun line ->
22
+
let line =
23
+
match String.index_opt line '#' with
24
+
| None -> line
25
+
| Some i -> String.sub line 0 i
26
+
in
27
+
let tokens =
28
+
line |> String.split_on_char ' ' |> List.filter (fun s -> s <> "")
29
+
in
30
+
match tokens with
31
+
| "nameserver" :: addr :: _ -> Ipaddr.of_string addr |> Result.to_option
32
+
| _ -> None)
33
+
34
+
let default_nameservers () =
35
+
let fallback =
36
+
[ Ipaddr.of_string_exn "1.1.1.1"; Ipaddr.of_string_exn "8.8.8.8" ]
37
+
in
38
+
try
39
+
let ic = open_in "/etc/resolv.conf" in
40
+
let n = in_channel_length ic in
41
+
let s = really_input_string ic n in
42
+
close_in ic;
43
+
match parse_resolv_conf s with [] -> fallback | ns -> ns
44
+
with Sys_error _ | End_of_file -> fallback
45
+
46
+
(* ----- Resolver configuration ----- *)
47
+
48
+
type proto = [ `Udp | `Tcp ]
49
+
50
+
type t = {
51
+
nameservers : Ipaddr.t list;
52
+
port : int;
53
+
timeout_ns : int64;
54
+
proto : proto;
55
+
}
56
+
57
+
let v ?nameservers ?(port = 53) ?(timeout_s = 2.0) ?(proto = `Udp) () =
58
+
let nameservers =
59
+
match nameservers with Some ns -> ns | None -> default_nameservers ()
60
+
in
61
+
{ nameservers; port; timeout_ns = Int64.of_float (timeout_s *. 1e9); proto }
62
+
63
+
let nameservers t = t.nameservers
64
+
65
+
let pp ppf t =
66
+
Fmt.pf ppf "<resolver nameservers=%a port=%d timeout=%Luns>"
67
+
Fmt.(list ~sep:comma Ipaddr.pp)
68
+
t.nameservers t.port t.timeout_ns
69
+
70
+
(* ----- Eio transport for the nox-dns client -----
71
+
72
+
Pure I/O -- [connect] / [send_recv] / [close] over Eio, with a per-request
73
+
timeout. The clock and RNG the DNS client needs are injected through
74
+
{!Nox_dns.Client.Make.v} below, not fixed here, so this transport carries
75
+
no OS-clock dependency and resolves over a unikernel's TCP-only stack. *)
76
+
77
+
let to_eio_ip ip = Eio.Net.Ipaddr.of_raw (Ipaddr.to_octets ip)
78
+
79
+
module Transport = struct
80
+
type io_addr = Ipaddr.t * int
81
+
type +'a io = 'a
82
+
83
+
type stack = {
84
+
net : [ `Generic ] Eio.Net.ty Eio.Resource.t;
85
+
sw : Eio.Switch.t;
86
+
clock : float Eio.Time.clock_ty Eio.Resource.t;
87
+
}
88
+
89
+
type conn =
90
+
| Tcp of [ `Generic ] Eio.Net.stream_socket_ty Eio.Resource.t
91
+
| Udp of
92
+
[ `Generic ] Eio.Net.datagram_socket_ty Eio.Resource.t
93
+
* Eio.Net.Sockaddr.datagram
94
+
95
+
type t = {
96
+
stack : stack;
97
+
protocol : Dns.proto;
98
+
nameservers : io_addr list;
99
+
timeout_ns : int64;
100
+
}
101
+
102
+
type context = { t : t; conn : conn }
103
+
104
+
let default_ns = [ (Ipaddr.of_string_exn "1.1.1.1", 53) ]
105
+
106
+
let v ?nameservers ~timeout stack =
107
+
let protocol, nameservers =
108
+
match nameservers with
109
+
| Some (proto, ns) -> (proto, ns)
110
+
| None -> (`Tcp, default_ns)
111
+
in
112
+
{ stack; protocol; nameservers; timeout_ns = timeout }
113
+
114
+
let nameservers t = (t.protocol, t.nameservers)
115
+
let bind x f = f x
116
+
let lift = Fun.id
117
+
118
+
let connect t =
119
+
match t.nameservers with
120
+
| [] -> Error (`Msg "nox-dns: no nameservers configured")
121
+
| (ip, port) :: _ -> (
122
+
try
123
+
match t.protocol with
124
+
| `Tcp ->
125
+
let flow =
126
+
Eio.Net.connect ~sw:t.stack.sw t.stack.net
127
+
(`Tcp (to_eio_ip ip, port))
128
+
in
129
+
Ok (`Tcp, { t; conn = Tcp flow })
130
+
| `Udp ->
131
+
let sock =
132
+
Eio.Net.datagram_socket ~sw:t.stack.sw t.stack.net `UdpV4
133
+
in
134
+
Ok (`Udp, { t; conn = Udp (sock, `Udp (to_eio_ip ip, port)) })
135
+
with exn -> Error (`Msg (Printexc.to_string exn)))
136
+
137
+
(* The client frames a TCP query with a 2-byte length prefix and strips it
138
+
from the reply, so [send_recv] just moves bytes: for TCP it must return the
139
+
complete framed reply (prefix + body), read by its declared length. *)
140
+
let send_recv ctx str =
141
+
let with_timeout f =
142
+
match
143
+
Eio.Time.with_timeout ctx.t.stack.clock
144
+
(Int64.to_float ctx.t.timeout_ns /. 1e9)
145
+
f
146
+
with
147
+
| Ok _ as ok -> ok
148
+
| Error `Timeout -> Error (`Msg "nox-dns: timeout")
149
+
in
150
+
try
151
+
match ctx.conn with
152
+
| Tcp flow ->
153
+
Eio.Flow.copy_string str flow;
154
+
let r = Eio.Buf_read.of_flow ~max_size:0x10000 flow in
155
+
with_timeout (fun () ->
156
+
let hdr = Eio.Buf_read.take 2 r in
157
+
let len = (Char.code hdr.[0] lsl 8) lor Char.code hdr.[1] in
158
+
Ok (hdr ^ Eio.Buf_read.take len r))
159
+
| Udp (sock, dst) ->
160
+
Eio.Net.send sock ~dst [ Cstruct.of_string str ];
161
+
let buf = Cstruct.create 4096 in
162
+
with_timeout (fun () ->
163
+
let _, n = Eio.Net.recv sock buf in
164
+
Ok (Cstruct.to_string (Cstruct.sub buf 0 n)))
165
+
with exn -> Error (`Msg (Printexc.to_string exn))
166
+
167
+
let close { conn; _ } =
168
+
match conn with
169
+
| Tcp flow -> Eio.Resource.close flow
170
+
| Udp (sock, _) -> Eio.Resource.close sock
171
+
end
172
+
173
+
module Client = Nox_dns.Client.Make (Transport)
174
+
175
+
(* Query ids need only be unpredictable to an off-path attacker; over TCP to a
176
+
trusted resolver, stdlib randomness is adequate and needs no seeding. *)
177
+
let () = Random.self_init ()
178
+
let rng n = String.init n (fun _ -> Char.chr (Random.int 256))
179
+
let clock_ns clock () = Int64.of_float (Eio.Time.now clock *. 1e9)
180
+
181
+
let client ~sw ~net ~clock t =
182
+
let stack =
183
+
{ Transport.net :> [ `Generic ] Eio.Net.ty Eio.Resource.t; sw; clock }
184
+
in
185
+
Client.v ~clock:(clock_ns clock) ~rng
186
+
~nameservers:(t.proto, List.map (fun ip -> (ip, t.port)) t.nameservers)
187
+
~timeout:t.timeout_ns stack
188
+
189
+
let query ~sw ~net ~clock t rr name =
190
+
match Domain_name.of_string name with
191
+
| Error (`Msg _ as e) -> Error (e :> error)
192
+
| Ok dn -> (
193
+
match Client.getaddrinfo (client ~sw ~net ~clock t) rr dn with
194
+
| Ok v -> Ok v
195
+
| Error (`Msg m) -> Error (`Msg m))
196
+
197
+
let a ~sw ~net ~clock t name =
198
+
match query ~sw ~net ~clock t Dns.Rr_map.A name with
199
+
| Ok (_ttl, set) -> Ok (Ipaddr.V4.Set.elements set)
200
+
| Error _ as e -> e
201
+
202
+
let aaaa ~sw ~net ~clock t name =
203
+
match query ~sw ~net ~clock t Dns.Rr_map.Aaaa name with
204
+
| Ok (_ttl, set) -> Ok (Ipaddr.V6.Set.elements set)
205
+
| Error _ as e -> e
206
+
207
+
let txt ~sw ~net ~clock t name =
208
+
match query ~sw ~net ~clock t Dns.Rr_map.Txt name with
209
+
| Ok (_ttl, set) -> Ok (Dns.Rr_map.Txt_set.elements set)
210
+
| Error _ as e -> e
+99
lib/eio/dns_eio.mli
+99
lib/eio/dns_eio.mli
···
1
+
(** Eio-native DNS stub resolver.
2
+
3
+
An Eio transport for {!Nox_dns.Client} (the ocaml-dns stub client,
4
+
forked so the clock and RNG are injected rather than transport-module
5
+
globals -- see [nox-dns]). The query building, response matching, RFC 7766
6
+
TCP framing, and cache come from there; this module supplies the Eio I/O --
7
+
[connect] / [send_recv] / [close] -- and injects the Eio clock and the
8
+
process RNG.
9
+
10
+
The transport is UDP (default) or TCP ([~proto:`Tcp]). TCP needs only
11
+
{!Eio.Net.connect}, so it resolves over a network with no UDP datagram
12
+
support -- a unikernel's TCP-only stack, for instance. Freestanding: the
13
+
clock is an injected {!Eio.Time} capability, with no OS-clock dependency. *)
14
+
15
+
(** {1:errors Errors} *)
16
+
17
+
type error =
18
+
[ `Msg of string (** Local error (encoding, transport setup). *)
19
+
| `Timeout (** No response from any nameserver within the deadline. *)
20
+
| `Nxdomain (** The name does not exist. *)
21
+
| `Servfail of int
22
+
(** Non-NOERROR/NXDOMAIN DNS response code; the int is the raw RCODE. *)
23
+
| `Truncated (** UDP response arrived with the TC flag set. *)
24
+
| `Malformed of string ]
25
+
26
+
val pp_error : error Fmt.t
27
+
(** [pp_error] formats an error for humans. *)
28
+
29
+
(** {1:resolver Resolver configuration} *)
30
+
31
+
type proto = [ `Udp | `Tcp ]
32
+
(** The transport: a UDP datagram exchange, or a TCP connection with
33
+
length-prefixed messages (RFC 7766). *)
34
+
35
+
type t
36
+
(** Resolver configuration (nameservers, port, per-server timeout, transport).
37
+
*)
38
+
39
+
val v :
40
+
?nameservers:Ipaddr.t list ->
41
+
?port:int ->
42
+
?timeout_s:float ->
43
+
?proto:proto ->
44
+
unit ->
45
+
t
46
+
(** [v ()] is a resolver configuration.
47
+
48
+
- {!val-nameservers} defaults to the servers listed in [/etc/resolv.conf];
49
+
if that file is unreadable or empty, falls back to Cloudflare ([1.1.1.1])
50
+
and Google ([8.8.8.8]).
51
+
- [port] defaults to [53].
52
+
- [timeout_s] is the per-nameserver timeout. Default 2 seconds. Each
53
+
nameserver is tried in order; total budget is roughly
54
+
[timeout_s * len nameservers].
55
+
- {!type-proto} defaults to [`Udp]. Use [`Tcp] to resolve over a TCP-only
56
+
network (a unikernel stack with no UDP). *)
57
+
58
+
val nameservers : t -> Ipaddr.t list
59
+
(** [nameservers t] is the list of nameservers the resolver will try, in order.
60
+
*)
61
+
62
+
val pp : Format.formatter -> t -> unit
63
+
(** [pp ppf t] formats [t] as
64
+
[<resolver nameservers=ns,ns,... port=N timeout=Ns>]. *)
65
+
66
+
(** {1:queries Queries}
67
+
68
+
Every query takes [~sw] and [~net] so the caller controls socket lifetime.
69
+
The socket is opened, used for the single query, and closed when the switch
70
+
ends. *)
71
+
72
+
val txt :
73
+
sw:Eio.Switch.t ->
74
+
net:_ Eio.Net.t ->
75
+
clock:float Eio.Time.clock_ty Eio.Resource.t ->
76
+
t ->
77
+
string ->
78
+
(string list, error) result
79
+
(** [txt ~sw ~net ~clock t name] asks for the [TXT] records of [name] and
80
+
returns the list of record strings. Returns [Ok []] when the name exists but
81
+
has no TXT records ([NOERROR] with empty answer). *)
82
+
83
+
val a :
84
+
sw:Eio.Switch.t ->
85
+
net:_ Eio.Net.t ->
86
+
clock:float Eio.Time.clock_ty Eio.Resource.t ->
87
+
t ->
88
+
string ->
89
+
(Ipaddr.V4.t list, error) result
90
+
(** [a ~sw ~net ~clock t name] asks for the [A] records of [name]. *)
91
+
92
+
val aaaa :
93
+
sw:Eio.Switch.t ->
94
+
net:_ Eio.Net.t ->
95
+
clock:float Eio.Time.clock_ty Eio.Resource.t ->
96
+
t ->
97
+
string ->
98
+
(Ipaddr.V6.t list, error) result
99
+
(** [aaaa ~sw ~net ~clock t name] asks for the [AAAA] records of [name]. *)
+5
lib/eio/dune
+5
lib/eio/dune
+103
lib/eio/forward_eio.ml
+103
lib/eio/forward_eio.ml
···
1
+
(* The Eio edge that drives {!Nox_dns.Forward}: it performs the upstream I/O the
2
+
pure core cannot. [resolve] hands a client query to the core, answers locally
3
+
when it can, and otherwise sends the core's per-upstream queries over UDP --
4
+
trying the priority-ordered groups in turn, RTT-fastest first within a group,
5
+
with a per-request timeout -- feeding each reply back to the core until one
6
+
resolves, else SERVFAIL. *)
7
+
8
+
module F = Nox_dns.Forward
9
+
module Cfg = Nox_dns.Forward_config
10
+
11
+
let to_eio_ip ip = Eio.Net.Ipaddr.of_raw (Ipaddr.to_octets ip)
12
+
13
+
type t = {
14
+
core : F.t;
15
+
net : [ `Generic ] Eio.Net.ty Eio.Resource.t;
16
+
clock : Mtime.t Eio.Time.clock_ty Eio.Resource.t;
17
+
sw : Eio.Switch.t;
18
+
timeout_s : float;
19
+
}
20
+
21
+
let mono_ns clock () = Mtime.to_uint64_ns (Eio.Time.Mono.now clock)
22
+
let () = Random.self_init ()
23
+
let rng n = String.init n (fun _ -> Char.chr (Random.int 256))
24
+
25
+
let v ~sw ~net ~clock ?cfg ?hosts ?(timeout_s = 2.0) () =
26
+
let clock = (clock :> Mtime.t Eio.Time.clock_ty Eio.Resource.t) in
27
+
{
28
+
core = F.v ?cfg ?hosts ~proto:`Udp ~rng ~clock:(mono_ns clock) ();
29
+
net;
30
+
clock;
31
+
sw;
32
+
timeout_s;
33
+
}
34
+
35
+
let core t = t.core
36
+
let set_config t cfg = F.set_config t.core cfg
37
+
38
+
(* Read the host's resolver configuration and hosts file into forwarder inputs.
39
+
Missing or unreadable files yield the empty value. *)
40
+
let read_file path =
41
+
try
42
+
let ic = open_in_bin path in
43
+
let n = in_channel_length ic in
44
+
let s = really_input_string ic n in
45
+
close_in ic;
46
+
Some s
47
+
with Sys_error _ | End_of_file -> None
48
+
49
+
let system_config () =
50
+
match read_file "/etc/resolv.conf" with
51
+
| Some s -> (
52
+
match Cfg.of_resolv_conf s with Ok c -> c | Error _ -> Cfg.empty)
53
+
| None -> Cfg.empty
54
+
55
+
let system_hosts () =
56
+
match read_file "/etc/hosts" with
57
+
| Some s -> Nox_dns.Hosts.of_string s
58
+
| None -> Nox_dns.Hosts.empty
59
+
60
+
(* Send one query to an upstream over UDP and await a single datagram, bounded
61
+
by the per-request timeout. [None] on timeout or socket error. *)
62
+
let query_udp t (addr : Cfg.Address.t) query =
63
+
try
64
+
let flavour =
65
+
match addr.ip with Ipaddr.V4 _ -> `UdpV4 | Ipaddr.V6 _ -> `UdpV6
66
+
in
67
+
let sock = Eio.Net.datagram_socket ~sw:t.sw t.net flavour in
68
+
Fun.protect ~finally:(fun () -> Eio.Resource.close sock) @@ fun () ->
69
+
let dst = `Udp (to_eio_ip addr.ip, addr.port) in
70
+
Eio.Net.send sock ~dst [ Cstruct.of_string query ];
71
+
let buf = Cstruct.create 4096 in
72
+
Eio.Fiber.first
73
+
(fun () ->
74
+
let _, n = Eio.Net.recv sock buf in
75
+
Some (Cstruct.to_string (Cstruct.sub buf 0 n)))
76
+
(fun () ->
77
+
Eio.Time.Mono.sleep t.clock t.timeout_s;
78
+
None)
79
+
with Eio.Exn.Io _ -> None
80
+
81
+
let resolve t query =
82
+
let fail () = Option.value ~default:query (F.servfail t.core query) in
83
+
match F.decide t.core query with
84
+
| F.Reply w -> w
85
+
| F.Drop _ -> fail ()
86
+
| F.Forward req ->
87
+
let rec try_attempts = function
88
+
| [] -> None
89
+
| att :: rest -> (
90
+
let server : Cfg.server = F.attempt_server att in
91
+
match query_udp t server.address (F.attempt_query att) with
92
+
| None -> try_attempts rest
93
+
| Some resp -> (
94
+
match F.on_reply t.core req att resp with
95
+
| F.Resolved w | F.Negative w -> Some w
96
+
| F.Failed _ -> try_attempts rest))
97
+
in
98
+
let rec try_groups = function
99
+
| [] -> fail ()
100
+
| g :: rest -> (
101
+
match try_attempts g with Some w -> w | None -> try_groups rest)
102
+
in
103
+
try_groups req.groups
+40
lib/eio/forward_eio.mli
+40
lib/eio/forward_eio.mli
···
1
+
(** The Eio edge for {!Nox_dns.Forward}: a DNS forwarding resolver.
2
+
3
+
[resolve] answers a client query locally when it can, else sends the pure
4
+
core's per-upstream queries over UDP -- trying the priority-ordered groups
5
+
in turn, RTT-fastest first within a group, with a per-request timeout --
6
+
until one resolves, and SERVFAILs when every upstream fails. *)
7
+
8
+
type t
9
+
(** A forwarding resolver bound to an Eio network and clock. *)
10
+
11
+
val v :
12
+
sw:Eio.Switch.t ->
13
+
net:[ `Generic ] Eio.Net.ty Eio.Resource.t ->
14
+
clock:_ Eio.Time.Mono.t ->
15
+
?cfg:Nox_dns.Forward_config.t ->
16
+
?hosts:Nox_dns.Hosts.t ->
17
+
?timeout_s:float ->
18
+
unit ->
19
+
t
20
+
(** [v ~sw ~net ~clock ()] is a resolver forwarding to [cfg]'s upstreams
21
+
(default none), answering [hosts] locally, with a per-request [timeout_s]
22
+
(default 2s). *)
23
+
24
+
val resolve : t -> string -> string
25
+
(** [resolve t query] is the reply wire for the client [query] (a hosts/cache
26
+
answer, a forwarded upstream answer, or SERVFAIL). *)
27
+
28
+
val set_config : t -> Nox_dns.Forward_config.t -> unit
29
+
(** [set_config t cfg] replaces the upstream configuration (a live reload). *)
30
+
31
+
val system_config : unit -> Nox_dns.Forward_config.t
32
+
(** [system_config ()] reads the host's [/etc/resolv.conf] into a forwarder
33
+
configuration ({!Nox_dns.Forward_config.empty} if it is absent). *)
34
+
35
+
val system_hosts : unit -> Nox_dns.Hosts.t
36
+
(** [system_hosts ()] reads the host's [/etc/hosts] into a local names table
37
+
({!Nox_dns.Hosts.empty} if it is absent). *)
38
+
39
+
val core : t -> Nox_dns.Forward.t
40
+
(** [core t] is the underlying pure forwarder. *)
+219
lib/forward.ml
+219
lib/forward.ml
···
1
+
(* The I/O-free DNS forwarder decision core: parse a client query, answer it
2
+
locally from /etc/hosts or the cache, else build 0x20/EDNS-encoded queries for
3
+
the chosen upstreams; and, once the edge has a reply from an upstream,
4
+
validate it, cache it, and build the client's reply. It never performs I/O --
5
+
[decide] returns the upstream queries to race and [on_reply] consumes each
6
+
response -- so the whole forwarder is testable against a canned transport.
7
+
8
+
Reuses ocaml-dns wholesale: the wire codec (Dns.Packet), the TTL/negative
9
+
cache (Dns_cache), and the forked stub client's query build/validate
10
+
(Client.Pure). It composes the pure primitives Forward_config,
11
+
Server_select, Upstream_health, Case0x20, Edns_policy and Hosts. Id_mux (id
12
+
multiplexing over a persistent connection) is the edge transport's concern. *)
13
+
14
+
module Pure = Client.Pure
15
+
module Addr_map = Forward_config.Address.Map
16
+
17
+
(* An in-flight upstream attempt: the query wire to send to [server], and the
18
+
state to validate its response. [key] is packed with [state] (they share the
19
+
record type) so the validated answer can be cached under it. *)
20
+
type attempt =
21
+
| Att : {
22
+
server : Forward_config.server;
23
+
query : string;
24
+
key : 'a Dns.Rr_map.key;
25
+
state : 'a Dns.Rr_map.key Pure.query_state;
26
+
}
27
+
-> attempt
28
+
29
+
type request = {
30
+
client_id : int;
31
+
name : [ `raw ] Domain_name.t;
32
+
question : Dns.Packet.Question.t;
33
+
groups : attempt list list;
34
+
}
35
+
36
+
type decision =
37
+
| Reply of string (** a ready-to-send reply (hosts or cache hit) *)
38
+
| Forward of request
39
+
(** race these upstream groups; feed replies to on_reply *)
40
+
| Drop of string (** a malformed or unsupported query *)
41
+
42
+
(* The classification of one upstream reply, for the edge's racing logic. *)
43
+
type response =
44
+
| Resolved of string (** client reply wire; stop racing *)
45
+
| Negative of string (** authoritative NXDOMAIN/NODATA; stop racing *)
46
+
| Failed of string (** this upstream failed; try the next *)
47
+
48
+
type t = {
49
+
mutable cfg : Forward_config.t;
50
+
mutable cache : Dns_cache.t;
51
+
mutable health : Upstream_health.t Addr_map.t;
52
+
hosts : Hosts.t;
53
+
rng : int -> string;
54
+
clock : unit -> int64;
55
+
proto : Dns.proto;
56
+
}
57
+
58
+
let v ?(cfg = Forward_config.empty) ?(hosts = Hosts.empty) ?(cache_size = 256)
59
+
?(proto = `Udp) ~rng ~clock () =
60
+
{
61
+
cfg;
62
+
cache = Dns_cache.empty cache_size;
63
+
health = Addr_map.empty;
64
+
hosts;
65
+
rng;
66
+
clock;
67
+
proto;
68
+
}
69
+
70
+
let config t = t.cfg
71
+
let set_config t cfg = t.cfg <- cfg
72
+
let attempt_server (Att a) = a.server
73
+
let attempt_query (Att a) = a.query
74
+
75
+
let health_of t addr =
76
+
Option.value ~default:Upstream_health.fresh (Addr_map.find_opt addr t.health)
77
+
78
+
let assume_offline_after t =
79
+
Option.value ~default:max_int t.cfg.Forward_config.assume_offline_after_drops
80
+
81
+
let record_success t addr ~rtt =
82
+
t.health <-
83
+
Addr_map.add addr
84
+
(Upstream_health.record_success (health_of t addr) ~rtt)
85
+
t.health
86
+
87
+
let record_drop t addr =
88
+
let h =
89
+
Upstream_health.record_drop (health_of t addr)
90
+
~assume_offline_after:(assume_offline_after t)
91
+
in
92
+
t.health <- Addr_map.add addr h t.health
93
+
94
+
let response_flags =
95
+
Dns.Packet.Flags.of_list [ `Recursion_desired; `Recursion_available ]
96
+
97
+
(* A positive reply echoing the client's question and id. *)
98
+
let answer_wire t ~client_id ~question ~name ~key data =
99
+
let header = (client_id, response_flags) in
100
+
let answer =
101
+
(Dns.Name_rr_map.singleton name key data, Dns.Name_rr_map.empty)
102
+
in
103
+
let reply = Dns.Packet.create header question (`Answer answer) in
104
+
fst (Dns.Packet.encode t.proto reply)
105
+
106
+
(* An authoritative negative reply carrying the SOA in the authority section:
107
+
NXDOMAIN for an absent name, NoError+empty (NODATA) for a present name with no
108
+
record of the asked type. *)
109
+
let negative_wire t ~client_id ~question ~rcode ~soa_name soa =
110
+
let header = (client_id, response_flags) in
111
+
let authority = Dns.Name_rr_map.singleton soa_name Dns.Rr_map.Soa soa in
112
+
let reply =
113
+
Dns.Packet.create header question
114
+
(`Rcode_error
115
+
(rcode, Dns.Opcode.Query, Some (Dns.Name_rr_map.empty, authority)))
116
+
in
117
+
fst (Dns.Packet.encode t.proto reply)
118
+
119
+
(* Answer (name, key) from hosts or the cache, honouring cached negatives. *)
120
+
let local_answer t ~client_id ~question ~name key =
121
+
match Hosts.lookup t.hosts name key with
122
+
| Some data -> Some (answer_wire t ~client_id ~question ~name ~key data)
123
+
| None -> (
124
+
let cache, res = Dns_cache.get t.cache (t.clock ()) name key in
125
+
t.cache <- cache;
126
+
match res with
127
+
| Ok (`Entry data, _) ->
128
+
Some (answer_wire t ~client_id ~question ~name ~key data)
129
+
| Ok (`No_domain (soa_name, soa), _) ->
130
+
Some
131
+
(negative_wire t ~client_id ~question ~rcode:Dns.Rcode.NXDomain
132
+
~soa_name soa)
133
+
| Ok (`No_data (soa_name, soa), _) ->
134
+
Some
135
+
(negative_wire t ~client_id ~question ~rcode:Dns.Rcode.NoError
136
+
~soa_name soa)
137
+
| Ok (`Serv_fail _, _) | Error (`Cache_miss | `Cache_drop) -> None)
138
+
139
+
(* Build the upstream attempts for (name, key): one per selected server, each an
140
+
independently 0x20-randomised, EDNS-`Auto query with a fresh transaction id. *)
141
+
let build_attempts t ~name key =
142
+
Server_select.choose t.cfg ~health:(health_of t) name
143
+
|> List.map
144
+
(List.map (fun (server : Forward_config.server) ->
145
+
let qname = Case0x20.encode ~rng:t.rng name in
146
+
let query, state = Pure.make_query t.rng t.proto `Auto qname key in
147
+
Att { server; query; key; state }))
148
+
149
+
let decide t query_wire =
150
+
match Dns.Packet.decode query_wire with
151
+
| Error _ -> Drop "undecodable query"
152
+
| Ok packet -> (
153
+
let client_id = fst packet.Dns.Packet.header in
154
+
let name, qtype = packet.Dns.Packet.question in
155
+
match qtype with
156
+
| `K (Dns.Rr_map.K key) -> (
157
+
match
158
+
local_answer t ~client_id ~question:packet.question ~name key
159
+
with
160
+
| Some wire -> Reply wire
161
+
| None ->
162
+
Forward
163
+
{
164
+
client_id;
165
+
name;
166
+
question = packet.question;
167
+
groups = build_attempts t ~name key;
168
+
})
169
+
| `Any | `Axfr | `Ixfr -> Drop "unsupported query type")
170
+
171
+
let on_reply t (req : request) (Att att) response_wire =
172
+
let addr = att.server.Forward_config.address in
173
+
let ts = t.clock () in
174
+
match Pure.handle_response att.state response_wire with
175
+
| Error (`Msg m) ->
176
+
record_drop t addr;
177
+
Failed m
178
+
| Ok `Partial ->
179
+
record_drop t addr;
180
+
Failed "partial response"
181
+
| Ok (`Data data) ->
182
+
record_success t addr ~rtt:0L;
183
+
t.cache <-
184
+
Dns_cache.set t.cache ts req.name att.key
185
+
Dns_cache.NonAuthoritativeAnswer (`Entry data);
186
+
Resolved
187
+
(answer_wire t ~client_id:req.client_id ~question:req.question
188
+
~name:req.name ~key:att.key data)
189
+
| Ok (`No_domain (soa_name, soa)) ->
190
+
record_success t addr ~rtt:0L;
191
+
t.cache <-
192
+
Dns_cache.set t.cache ts req.name att.key
193
+
Dns_cache.NonAuthoritativeAnswer
194
+
(`No_domain (soa_name, soa));
195
+
Negative
196
+
(negative_wire t ~client_id:req.client_id ~question:req.question
197
+
~rcode:Dns.Rcode.NXDomain ~soa_name soa)
198
+
| Ok (`No_data (soa_name, soa)) ->
199
+
record_success t addr ~rtt:0L;
200
+
t.cache <-
201
+
Dns_cache.set t.cache ts req.name att.key
202
+
Dns_cache.NonAuthoritativeAnswer
203
+
(`No_data (soa_name, soa));
204
+
Negative
205
+
(negative_wire t ~client_id:req.client_id ~question:req.question
206
+
~rcode:Dns.Rcode.NoError ~soa_name soa)
207
+
208
+
(* A SERVFAIL reply echoing the client's id and question, for when every
209
+
upstream failed (or the query could not be forwarded). *)
210
+
let servfail t query_wire =
211
+
match Dns.Packet.decode query_wire with
212
+
| Error _ -> None
213
+
| Ok packet ->
214
+
let header = (fst packet.Dns.Packet.header, response_flags) in
215
+
let reply =
216
+
Dns.Packet.create header packet.Dns.Packet.question
217
+
(`Rcode_error (Dns.Rcode.ServFail, Dns.Opcode.Query, None))
218
+
in
219
+
Some (fst (Dns.Packet.encode t.proto reply))
+81
lib/forward.mli
+81
lib/forward.mli
···
1
+
(** The I/O-free DNS forwarder decision core.
2
+
3
+
[decide] parses a client query and either answers it locally (from
4
+
{!Nox_dns.Hosts} or the cache) or returns the 0x20/EDNS-encoded queries to
5
+
race against the chosen upstreams; [on_reply] validates, caches, and turns
6
+
each upstream response into the client's reply. No I/O happens here, so the
7
+
whole forwarder is testable against a canned transport.
8
+
9
+
Reuses ocaml-dns's wire codec, TTL/negative cache and forked stub client,
10
+
and composes {!Forward_config}, {!Server_select}, {!Upstream_health},
11
+
{!Case0x20}, {!Edns_policy} and {!Hosts}. (Transaction-id multiplexing over
12
+
a persistent upstream connection, {!Id_mux}, is the edge transport's
13
+
concern.) *)
14
+
15
+
type t
16
+
(** A forwarder: its config, cache, id allocator, per-upstream health, and local
17
+
names, plus the injected clock and RNG. *)
18
+
19
+
type attempt
20
+
(** One upstream attempt: a query wire and the state to validate its reply. *)
21
+
22
+
type request = {
23
+
client_id : int;
24
+
name : [ `raw ] Domain_name.t;
25
+
question : Dns.Packet.Question.t;
26
+
groups : attempt list list;
27
+
(** priority-ordered groups of upstream attempts; the edge races the
28
+
members of each group and falls to the next group on failure *)
29
+
}
30
+
(** What {!decide} hands the edge to forward a query. *)
31
+
32
+
type decision =
33
+
| Reply of string (** a ready-to-send reply (a hosts or cache hit) *)
34
+
| Forward of request
35
+
(** race these upstream groups; feed replies to {!on_reply} *)
36
+
| Drop of string (** a malformed or unsupported query *)
37
+
38
+
type response =
39
+
| Resolved of string (** the client reply wire; stop racing *)
40
+
| Negative of string
41
+
(** an authoritative NXDOMAIN/NODATA reply; stop racing *)
42
+
| Failed of string (** this upstream failed; try the next attempt *)
43
+
44
+
val v :
45
+
?cfg:Forward_config.t ->
46
+
?hosts:Hosts.t ->
47
+
?cache_size:int ->
48
+
?proto:Dns.proto ->
49
+
rng:(int -> string) ->
50
+
clock:(unit -> int64) ->
51
+
unit ->
52
+
t
53
+
(** [v ~rng ~clock ()] is a forwarder with the given upstream [cfg] (default
54
+
none), local [hosts], cache capacity, and query [proto] (default [`Udp]).
55
+
[clock] is a monotonic ns source for cache TTLs. *)
56
+
57
+
val config : t -> Forward_config.t
58
+
(** [config t] is the current upstream configuration. *)
59
+
60
+
val set_config : t -> Forward_config.t -> unit
61
+
(** [set_config t cfg] replaces the upstream configuration (a live reload). *)
62
+
63
+
val attempt_server : attempt -> Forward_config.server
64
+
(** [attempt_server a] is the upstream this attempt queries. *)
65
+
66
+
val attempt_query : attempt -> string
67
+
(** [attempt_query a] is the query wire the edge sends upstream for [a]. *)
68
+
69
+
val decide : t -> string -> decision
70
+
(** [decide t query] parses [query] and decides how to answer it: a local
71
+
{!Reply}, a {!Forward} to race upstream, or a {!Drop}. *)
72
+
73
+
val on_reply : t -> request -> attempt -> string -> response
74
+
(** [on_reply t req attempt response] validates [response] against [attempt]
75
+
(id, question and 0x20 case), records the upstream's health, caches the
76
+
answer, and builds the client reply. A failed or mismatched response is
77
+
{!Failed} so the edge tries the next attempt. *)
78
+
79
+
val servfail : t -> string -> string option
80
+
(** [servfail t query] is a SERVFAIL reply echoing [query]'s id and question,
81
+
for when every upstream failed; [None] if [query] does not decode. *)
+228
lib/forward_config.ml
+228
lib/forward_config.ml
···
1
+
(* Upstream-resolver configuration for the DNS forwarder: a set of upstream
2
+
servers, each optionally scoped to the zones it is authoritative-ish for, in
3
+
priority order, plus the host search list. The text format round-trips with
4
+
{!to_string} / {!of_string} and follows moby/vpnkit's dns_forward config so a
5
+
vpnkit config file is read unchanged. *)
6
+
7
+
let err_msg fmt = Fmt.kstr (fun m -> Error (`Msg m)) fmt
8
+
9
+
module Address = struct
10
+
type t = { ip : Ipaddr.t; port : int }
11
+
12
+
let compare a b =
13
+
match Ipaddr.compare a.ip b.ip with
14
+
| 0 -> Int.compare a.port b.port
15
+
| c -> c
16
+
17
+
let equal a b = compare a b = 0
18
+
19
+
(* [ip#port]: the '#' separator keeps IPv6 addresses (which contain ':')
20
+
unambiguous, following vpnkit's config grammar. *)
21
+
let to_string t = Fmt.str "%a#%d" Ipaddr.pp t.ip t.port
22
+
let pp ppf t = Fmt.string ppf (to_string t)
23
+
24
+
let of_string s =
25
+
let ip_s, port =
26
+
match String.rindex_opt s '#' with
27
+
| Some i -> (
28
+
let p = String.sub s (i + 1) (String.length s - i - 1) in
29
+
( String.sub s 0 i,
30
+
match int_of_string_opt p with Some p -> p | None -> 53 ))
31
+
| None -> (s, 53)
32
+
in
33
+
match Ipaddr.of_string ip_s with
34
+
| Ok ip -> Ok { ip; port }
35
+
| Error (`Msg _) -> err_msg "invalid address: %s" s
36
+
37
+
module Set = Set.Make (struct
38
+
type nonrec t = t
39
+
40
+
let compare = compare
41
+
end)
42
+
43
+
module Map = Map.Make (struct
44
+
type nonrec t = t
45
+
46
+
let compare = compare
47
+
end)
48
+
end
49
+
50
+
module Domain = struct
51
+
type t = [ `raw ] Domain_name.t
52
+
53
+
let to_string t = Domain_name.to_string t
54
+
let of_string s = Domain_name.of_string s
55
+
let compare a b = Domain_name.compare a b
56
+
57
+
(* [is_subdomain ~subdomain zone] is whether the queried name [subdomain] falls
58
+
within this server's [zone] (so the server is preferred for it). *)
59
+
let is_subdomain ~subdomain zone =
60
+
Domain_name.is_subdomain ~subdomain ~domain:zone
61
+
62
+
module Set = Set.Make (struct
63
+
type nonrec t = t
64
+
65
+
let compare = compare
66
+
end)
67
+
68
+
module Map = Map.Make (struct
69
+
type nonrec t = t
70
+
71
+
let compare = compare
72
+
end)
73
+
end
74
+
75
+
type server = {
76
+
zones : Domain.Set.t;
77
+
address : Address.t;
78
+
timeout : int64 option;
79
+
order : int;
80
+
}
81
+
82
+
module Server = struct
83
+
type t = server
84
+
85
+
(* Address is the primary key (as in vpnkit), then zones, order, timeout, so
86
+
two servers with the same address but different scope stay distinct. *)
87
+
let compare a b =
88
+
match Address.compare a.address b.address with
89
+
| 0 -> (
90
+
match Domain.Set.compare a.zones b.zones with
91
+
| 0 -> (
92
+
match Int.compare a.order b.order with
93
+
| 0 -> Option.compare Int64.compare a.timeout b.timeout
94
+
| c -> c)
95
+
| c -> c)
96
+
| c -> c
97
+
98
+
module Set = Set.Make (struct
99
+
type nonrec t = t
100
+
101
+
let compare = compare
102
+
end)
103
+
end
104
+
105
+
type t = {
106
+
servers : Server.Set.t;
107
+
search : string list;
108
+
assume_offline_after_drops : int option;
109
+
}
110
+
111
+
let empty =
112
+
{ servers = Server.Set.empty; search = []; assume_offline_after_drops = None }
113
+
114
+
(* Equality of the configured upstreams and search list; the offline threshold
115
+
is a tuning knob, not identity (matching vpnkit's compare). *)
116
+
let compare a b =
117
+
match Server.Set.compare a.servers b.servers with
118
+
| 0 -> List.compare String.compare a.search b.search
119
+
| c -> c
120
+
121
+
let ns_of_ms ms = Int64.mul (Int64.of_int ms) 1_000_000L
122
+
let ms_of_ns ns = Int64.to_int (Int64.div ns 1_000_000L)
123
+
124
+
(* Attributes are emitted before the [nameserver] line they scope, since
125
+
{!of_string} binds each accumulated attribute to the nameserver that follows
126
+
it. *)
127
+
let string_of_server s =
128
+
let b = Buffer.create 64 in
129
+
let line k v = Buffer.add_string b (k ^ " " ^ v ^ "\n") in
130
+
if not (Domain.Set.is_empty s.zones) then
131
+
line "zone"
132
+
(String.concat " "
133
+
(List.map Domain.to_string (Domain.Set.elements s.zones)));
134
+
Option.iter (fun ns -> line "timeout" (string_of_int (ms_of_ns ns))) s.timeout;
135
+
line "order" (string_of_int s.order);
136
+
line "nameserver" (Address.to_string s.address);
137
+
Buffer.contents b
138
+
139
+
let to_string t =
140
+
let servers =
141
+
String.concat "" (List.map string_of_server (Server.Set.elements t.servers))
142
+
in
143
+
let search =
144
+
String.concat "" (List.map (fun d -> "search " ^ d ^ "\n") t.search)
145
+
in
146
+
servers ^ search
147
+
148
+
let pp ppf t = Fmt.string ppf (to_string t)
149
+
150
+
(* Parse the vpnkit line format. Zone / timeout / order lines set attributes for
151
+
the NEXT nameserver line, then reset, so a server's scope precedes it. *)
152
+
let words l = String.split_on_char ' ' l |> List.filter (fun x -> x <> "")
153
+
154
+
let parse_zones ds =
155
+
let ( let* ) = Result.bind in
156
+
List.fold_left
157
+
(fun acc d ->
158
+
let* acc = acc in
159
+
let* dn = Domain.of_string d in
160
+
Ok (Domain.Set.add dn acc))
161
+
(Ok Domain.Set.empty) ds
162
+
163
+
let of_string s =
164
+
let ( let* ) = Result.bind in
165
+
let int o = int_of_string_opt o in
166
+
let rec go acc z timeout order search off = function
167
+
| [] ->
168
+
Ok
169
+
{
170
+
servers = acc;
171
+
search = List.rev search;
172
+
assume_offline_after_drops = off;
173
+
}
174
+
| line :: tl -> (
175
+
match words (String.trim line) with
176
+
| [] -> go acc z timeout order search off tl
177
+
| "nameserver" :: a :: _ ->
178
+
let* address = Address.of_string a in
179
+
let server = { zones = z; address; timeout; order } in
180
+
go (Server.Set.add server acc) Domain.Set.empty None 0 search off tl
181
+
| "zone" :: ds ->
182
+
let* z = parse_zones ds in
183
+
go acc z timeout order search off tl
184
+
| "timeout" :: m :: _ ->
185
+
go acc z (Option.map ns_of_ms (int m)) order search off tl
186
+
| "order" :: o :: _ ->
187
+
go acc z timeout (Option.value ~default:0 (int o)) search off tl
188
+
| "search" :: ns ->
189
+
go acc z timeout order (List.rev_append ns search) off tl
190
+
| "assume-offline-after" :: n :: _ ->
191
+
go acc z timeout order search (int n) tl
192
+
| _ -> go acc z timeout order search off tl)
193
+
in
194
+
go Server.Set.empty Domain.Set.empty None 0 [] None
195
+
(String.split_on_char '\n' s)
196
+
197
+
(* Build a forwarder config from the host's /etc/resolv.conf: every [nameserver]
198
+
becomes an unscoped upstream on port 53, and [search] domains are carried. *)
199
+
let of_resolv_conf content =
200
+
let lines = String.split_on_char '\n' content in
201
+
let strip_comment l =
202
+
match String.index_opt l '#' with Some i -> String.sub l 0 i | None -> l
203
+
in
204
+
let tokens l =
205
+
String.split_on_char ' ' (strip_comment l) |> List.filter (fun x -> x <> "")
206
+
in
207
+
let servers, search =
208
+
List.fold_left
209
+
(fun (servers, search) line ->
210
+
match tokens (String.trim line) with
211
+
| "nameserver" :: addr :: _ -> (
212
+
match Ipaddr.of_string addr with
213
+
| Ok ip ->
214
+
( Server.Set.add
215
+
{
216
+
zones = Domain.Set.empty;
217
+
address = { ip; port = 53 };
218
+
timeout = None;
219
+
order = 0;
220
+
}
221
+
servers,
222
+
search )
223
+
| Error _ -> (servers, search))
224
+
| "search" :: names -> (servers, List.rev_append names search)
225
+
| _ -> (servers, search))
226
+
(Server.Set.empty, []) lines
227
+
in
228
+
Ok { servers; search = List.rev search; assume_offline_after_drops = None }
+98
lib/forward_config.mli
+98
lib/forward_config.mli
···
1
+
(** Upstream-resolver configuration for the DNS forwarder.
2
+
3
+
A set of upstream {!Server.t}s -- each optionally scoped to the zones it
4
+
should answer, in priority [order] -- plus the host search list. The text
5
+
format round-trips with {!to_string} / {!of_string} and follows
6
+
moby/vpnkit's [dns_forward] config, so a vpnkit config file is read
7
+
unchanged. *)
8
+
9
+
module Address : sig
10
+
type t = { ip : Ipaddr.t; port : int }
11
+
(** An upstream resolver's IP and port. *)
12
+
13
+
val compare : t -> t -> int
14
+
(** [compare] orders by IP then port. *)
15
+
16
+
val equal : t -> t -> bool
17
+
(** [equal a b] is [compare a b = 0]. *)
18
+
19
+
val pp : t Fmt.t
20
+
(** [pp] renders [ip#port]. *)
21
+
22
+
val to_string : t -> string
23
+
(** [to_string t] is [ip#port] ('#' keeps IPv6 addresses unambiguous). *)
24
+
25
+
val of_string : string -> (t, [> `Msg of string ]) result
26
+
(** [of_string s] parses a bare address (port 53) or [ip#port]. *)
27
+
28
+
module Set : Set.S with type elt = t
29
+
module Map : Map.S with type key = t
30
+
end
31
+
32
+
module Domain : sig
33
+
type t = [ `raw ] Domain_name.t
34
+
(** A zone a server is scoped to. *)
35
+
36
+
val to_string : t -> string
37
+
(** [to_string t] is the dotted domain. *)
38
+
39
+
val of_string : string -> (t, [> `Msg of string ]) result
40
+
(** [of_string s] parses a dotted domain. *)
41
+
42
+
val compare : t -> t -> int
43
+
(** [compare] is the domain-name order. *)
44
+
45
+
val is_subdomain : subdomain:[ `raw ] Domain_name.t -> t -> bool
46
+
(** [is_subdomain ~subdomain zone] is whether the queried [subdomain] falls
47
+
within this [zone], so the server is preferred for it. *)
48
+
49
+
module Set : Set.S with type elt = t
50
+
module Map : Map.S with type key = t
51
+
end
52
+
53
+
type server = {
54
+
zones : Domain.Set.t; (** empty means the server handles all queries *)
55
+
address : Address.t;
56
+
timeout : int64 option; (** per-server timeout override, ns *)
57
+
order : int; (** lower is earlier priority *)
58
+
}
59
+
(** A single upstream DNS server. *)
60
+
61
+
module Server : sig
62
+
type t = server
63
+
64
+
val compare : t -> t -> int
65
+
(** [compare] keys by address, then zones, order and timeout. *)
66
+
67
+
module Set : Set.S with type elt = t
68
+
end
69
+
70
+
type t = {
71
+
servers : Server.Set.t;
72
+
search : string list; (** host search list, carried for the edge to apply *)
73
+
assume_offline_after_drops : int option;
74
+
(** consecutive drops after which a server is marked offline *)
75
+
}
76
+
(** A forwarder configuration. *)
77
+
78
+
val empty : t
79
+
(** [empty] has no servers and no search list. *)
80
+
81
+
val pp : t Fmt.t
82
+
(** [pp] renders the configuration in the {!to_string} line format. *)
83
+
84
+
val compare : t -> t -> int
85
+
(** [compare] tests the servers and search list (not the offline threshold). *)
86
+
87
+
val to_string : t -> string
88
+
(** [to_string t] renders the vpnkit line format (nameserver, zone, timeout,
89
+
order and search lines), round-tripping with {!of_string}. *)
90
+
91
+
val of_string : string -> (t, [> `Msg of string ]) result
92
+
(** [of_string s] parses the vpnkit line format. The zone, timeout and order
93
+
lines set attributes for the nameserver line that follows them, then reset.
94
+
*)
95
+
96
+
val of_resolv_conf : string -> (t, [> `Msg of string ]) result
97
+
(** [of_resolv_conf content] reads an [/etc/resolv.conf]: each nameserver
98
+
becomes an unscoped upstream on port 53, and search domains are carried. *)
+73
lib/hosts.ml
+73
lib/hosts.ml
···
1
+
(* Locally-served names from an /etc/hosts-style table. The forwarder answers a
2
+
query from here before consulting any upstream, so host-defined names (and
3
+
gateway-local aliases) resolve without leaving the host. Names are stored
4
+
canonically (lowercased) so lookup is case-insensitive, including against a
5
+
0x20-encoded query. *)
6
+
7
+
module Name_map = Map.Make (struct
8
+
type t = [ `raw ] Domain_name.t
9
+
10
+
let compare = Domain_name.compare
11
+
end)
12
+
13
+
type entry = { v4 : Ipaddr.V4.Set.t; v6 : Ipaddr.V6.Set.t }
14
+
type t = entry Name_map.t
15
+
16
+
(* Static entries do not expire; a short TTL keeps a client from caching them
17
+
long past a table reload. *)
18
+
let default_ttl = 60l
19
+
let empty : t = Name_map.empty
20
+
let empty_entry = { v4 = Ipaddr.V4.Set.empty; v6 = Ipaddr.V6.Set.empty }
21
+
22
+
let add t name ip =
23
+
let key = Domain_name.canonical name in
24
+
let e = Option.value ~default:empty_entry (Name_map.find_opt key t) in
25
+
let e =
26
+
match ip with
27
+
| Ipaddr.V4 a -> { e with v4 = Ipaddr.V4.Set.add a e.v4 }
28
+
| Ipaddr.V6 a -> { e with v6 = Ipaddr.V6.Set.add a e.v6 }
29
+
in
30
+
Name_map.add key e t
31
+
32
+
let fields line =
33
+
let line =
34
+
match String.index_opt line '#' with
35
+
| Some i -> String.sub line 0 i
36
+
| None -> line
37
+
in
38
+
String.map (fun c -> if c = '\t' then ' ' else c) line
39
+
|> String.split_on_char ' '
40
+
|> List.filter (fun s -> s <> "")
41
+
42
+
let of_string s =
43
+
List.fold_left
44
+
(fun t line ->
45
+
match fields line with
46
+
| ip :: names -> (
47
+
match Ipaddr.of_string ip with
48
+
| Error _ -> t
49
+
| Ok ip ->
50
+
List.fold_left
51
+
(fun t name ->
52
+
match Domain_name.of_string name with
53
+
| Ok dn -> add t dn ip
54
+
| Error _ -> t)
55
+
t names)
56
+
| [] -> t)
57
+
empty
58
+
(String.split_on_char '\n' s)
59
+
60
+
let lookup : type a. t -> [ `raw ] Domain_name.t -> a Dns.Rr_map.key -> a option
61
+
=
62
+
fun t name key ->
63
+
match Name_map.find_opt (Domain_name.canonical name) t with
64
+
| None -> None
65
+
| Some e -> (
66
+
match key with
67
+
| Dns.Rr_map.A ->
68
+
if Ipaddr.V4.Set.is_empty e.v4 then None else Some (default_ttl, e.v4)
69
+
| Dns.Rr_map.Aaaa ->
70
+
if Ipaddr.V6.Set.is_empty e.v6 then None else Some (default_ttl, e.v6)
71
+
| _ -> None)
72
+
73
+
let mem t name = Name_map.mem (Domain_name.canonical name) t
+26
lib/hosts.mli
+26
lib/hosts.mli
···
1
+
(** Locally-served names from an [/etc/hosts]-style table.
2
+
3
+
The forwarder answers from here before any upstream, so host-defined names
4
+
and gateway-local aliases resolve without leaving the host. Names are stored
5
+
canonically, so lookup is case-insensitive (including against a 0x20-encoded
6
+
query). *)
7
+
8
+
type t
9
+
(** A name-to-address table. *)
10
+
11
+
val empty : t
12
+
(** [empty] serves no names. *)
13
+
14
+
val of_string : string -> t
15
+
(** [of_string s] parses [/etc/hosts] lines ([ip name alias...]); comments after
16
+
['#'] and unparseable lines are ignored. *)
17
+
18
+
val add : t -> [ `raw ] Domain_name.t -> Ipaddr.t -> t
19
+
(** [add t name ip] records [ip] (v4 or v6) for [name]. *)
20
+
21
+
val lookup : t -> [ `raw ] Domain_name.t -> 'a Dns.Rr_map.key -> 'a option
22
+
(** [lookup t name key] is the [A] or [Aaaa] answer for [name] with a short TTL,
23
+
or [None] for an absent name or any other record type. *)
24
+
25
+
val mem : t -> [ `raw ] Domain_name.t -> bool
26
+
(** [mem t name] is whether [name] has any local address. *)
+39
lib/id_mux.ml
+39
lib/id_mux.ml
···
1
+
(* A pure, collision-free allocator of DNS transaction ids. When many queries
2
+
share one upstream flow their 16-bit ids must not collide, ids handed out
3
+
must be unpredictable to an off-path attacker, and the number outstanding is
4
+
bounded (an amplification guard). Forked in spirit from vpnkit's
5
+
dns_forward_free_id, but immutable: [alloc] returns the next state, and
6
+
[None] when full so the caller parks rather than blocking here. *)
7
+
8
+
module Int_set = Set.Make (Int)
9
+
10
+
type t = { used : Int_set.t; max_elements : int; rng : int -> string }
11
+
12
+
let v ?(max_elements = 512) ~rng () =
13
+
{ used = Int_set.empty; max_elements; rng }
14
+
15
+
let in_use t id = Int_set.mem id t.used
16
+
17
+
(* A 16-bit id from two random bytes. *)
18
+
let draw rng =
19
+
let s = rng 2 in
20
+
(Char.code s.[0] lsl 8) lor Char.code s.[1] land 0xffff
21
+
22
+
(* Redraw past ids already in use. [max_elements] (<= 512 by default) is far
23
+
below the 65536 id space, so a free id is found in a handful of draws; the
24
+
bound is only a guard against a pathological rng. *)
25
+
let rec unused_id t tries =
26
+
if tries <= 0 then None
27
+
else
28
+
let id = draw t.rng in
29
+
if Int_set.mem id t.used then unused_id t (tries - 1) else Some id
30
+
31
+
let alloc t =
32
+
if Int_set.cardinal t.used >= t.max_elements then None
33
+
else
34
+
match unused_id t 1000 with
35
+
| None -> None
36
+
| Some id -> Some ({ t with used = Int_set.add id t.used }, id)
37
+
38
+
let free t id = { t with used = Int_set.remove id t.used }
39
+
let outstanding t = Int_set.cardinal t.used
+27
lib/id_mux.mli
+27
lib/id_mux.mli
···
1
+
(** A pure, collision-free allocator of DNS transaction ids.
2
+
3
+
Ids multiplexed over one upstream flow must not collide, must be
4
+
unpredictable to an off-path attacker, and must be bounded in number (an
5
+
amplification guard). This is the immutable counterpart of vpnkit's
6
+
[dns_forward_free_id]: {!alloc} returns the next state and [None] when full,
7
+
so the caller parks rather than blocking here. *)
8
+
9
+
type t
10
+
(** An allocator: the ids in use, the cap, and the injected RNG. *)
11
+
12
+
val v : ?max_elements:int -> rng:(int -> string) -> unit -> t
13
+
(** [v ~rng ()] is an empty allocator drawing ids from [rng]. At most
14
+
[max_elements] ids (default 512) may be outstanding at once. *)
15
+
16
+
val alloc : t -> (t * int) option
17
+
(** [alloc t] draws an unused 16-bit id, or [None] when [max_elements] are
18
+
already outstanding (the caller should wait for a {!free}). *)
19
+
20
+
val free : t -> int -> t
21
+
(** [free t id] returns [id] to the pool. *)
22
+
23
+
val in_use : t -> int -> bool
24
+
(** [in_use t id] is whether [id] is currently allocated. *)
25
+
26
+
val outstanding : t -> int
27
+
(** [outstanding t] is the number of ids currently allocated. *)
+46
lib/server_select.ml
+46
lib/server_select.ml
···
1
+
(* Choose which upstreams to try for a query, and in what sequence. Mirrors
2
+
vpnkit's choose_servers -- prefer servers scoped to a matching zone (so a
3
+
private name never leaks to a public resolver), fall back to all servers
4
+
otherwise -- then groups by priority [order] and, within a group, orders by
5
+
smoothed RTT so the fastest known-live upstream is tried first. Offline
6
+
upstreams are dropped. The result is a list of groups, tried in ascending
7
+
order; the edge races the members of each group. *)
8
+
9
+
module C = Forward_config
10
+
11
+
let zone_matches name (s : C.server) =
12
+
(not (C.Domain.Set.is_empty s.zones))
13
+
&& C.Domain.Set.exists
14
+
(fun z -> C.Domain.is_subdomain ~subdomain:name z)
15
+
s.zones
16
+
17
+
(* Fastest known RTT first; an upstream with no RTT yet sorts after those with
18
+
one (it is still tried -- it is in the group -- just not preferred). *)
19
+
let by_rtt health (a : C.server) (b : C.server) =
20
+
match
21
+
( Upstream_health.srtt (health a.address),
22
+
Upstream_health.srtt (health b.address) )
23
+
with
24
+
| Some x, Some y -> Int64.compare x y
25
+
| Some _, None -> -1
26
+
| None, Some _ -> 1
27
+
| None, None -> 0
28
+
29
+
let choose (cfg : C.t) ~health name =
30
+
let servers = C.Server.Set.elements cfg.servers in
31
+
let matching = List.filter (zone_matches name) servers in
32
+
let candidates = if matching <> [] then matching else servers in
33
+
let candidates =
34
+
List.filter
35
+
(fun (s : C.server) -> Upstream_health.online (health s.address))
36
+
candidates
37
+
in
38
+
let orders =
39
+
List.sort_uniq Int.compare
40
+
(List.map (fun (s : C.server) -> s.order) candidates)
41
+
in
42
+
List.map
43
+
(fun ord ->
44
+
List.filter (fun (s : C.server) -> s.order = ord) candidates
45
+
|> List.stable_sort (by_rtt health))
46
+
orders
+16
lib/server_select.mli
+16
lib/server_select.mli
···
1
+
(** Choose which upstreams to try for a query, and in what sequence.
2
+
3
+
Mirrors vpnkit's [choose_servers]: prefer servers scoped to a zone matching
4
+
the query (so a private name never leaks to a public resolver), else all
5
+
servers; drop offline ones; group by priority [order]; and within a group
6
+
order by smoothed RTT (fastest first). *)
7
+
8
+
val choose :
9
+
Forward_config.t ->
10
+
health:(Forward_config.Address.t -> Upstream_health.t) ->
11
+
[ `raw ] Domain_name.t ->
12
+
Forward_config.server list list
13
+
(** [choose cfg ~health name] is the priority-ordered groups of upstreams to try
14
+
for [name]. Groups are in ascending [order]; the edge races the members of
15
+
each group and falls to the next group on failure. Empty when every
16
+
candidate is offline. *)
+24
lib/upstream_health.ml
+24
lib/upstream_health.ml
···
1
+
(* Per-upstream health: consecutive-drop tracking (vpnkit's
2
+
assume_offline_after_drops -- a resolver that keeps dropping is marked offline
3
+
and skipped) plus a smoothed round-trip time so the selector can prefer the
4
+
fastest live upstream. Pure: each event returns the next state. *)
5
+
6
+
type t = { drops : int; offline : bool; srtt : int64 option }
7
+
8
+
let fresh = { drops = 0; offline = false; srtt = None }
9
+
10
+
(* Exponentially-weighted moving average, 7/8 old + 1/8 new (as in TCP's SRTT),
11
+
so a single slow reply does not dominate. *)
12
+
let ewma old rtt = Int64.div (Int64.add (Int64.mul old 7L) rtt) 8L
13
+
14
+
let record_success t ~rtt =
15
+
let srtt = match t.srtt with None -> rtt | Some s -> ewma s rtt in
16
+
{ drops = 0; offline = false; srtt = Some srtt }
17
+
18
+
let record_drop t ~assume_offline_after =
19
+
let drops = t.drops + 1 in
20
+
{ t with drops; offline = drops >= assume_offline_after }
21
+
22
+
let online t = not t.offline
23
+
let srtt t = t.srtt
24
+
let drops t = t.drops
+31
lib/upstream_health.mli
+31
lib/upstream_health.mli
···
1
+
(** Per-upstream health tracking.
2
+
3
+
Consecutive drops mark a resolver offline (vpnkit's
4
+
[assume_offline_after_drops]) so the selector skips it, and a smoothed
5
+
round-trip time lets the selector prefer the fastest live upstream. Pure:
6
+
each event returns the next state. *)
7
+
8
+
type t
9
+
(** An upstream's health: its consecutive-drop count, online flag, and smoothed
10
+
RTT. *)
11
+
12
+
val fresh : t
13
+
(** [fresh] is a never-contacted upstream: online, no drops, no RTT. *)
14
+
15
+
val record_success : t -> rtt:int64 -> t
16
+
(** [record_success t ~rtt] clears the drop count, marks the upstream online,
17
+
and folds [rtt] (ns) into the smoothed RTT. *)
18
+
19
+
val record_drop : t -> assume_offline_after:int -> t
20
+
(** [record_drop t ~assume_offline_after] counts one more consecutive drop and
21
+
marks the upstream offline once the count reaches [assume_offline_after]. *)
22
+
23
+
val online : t -> bool
24
+
(** [online t] is whether the upstream may still be tried. *)
25
+
26
+
val srtt : t -> int64 option
27
+
(** [srtt t] is the smoothed round-trip time (ns), or [None] if never contacted.
28
+
*)
29
+
30
+
val drops : t -> int
31
+
(** [drops t] is the current consecutive-drop count. *)
+41
nox-dns.opam
+41
nox-dns.opam
···
1
+
# This file is generated by dune, edit dune-project instead
2
+
opam-version: "2.0"
3
+
synopsis:
4
+
"Experimental fork of the ocaml-dns stub client with an injected clock"
5
+
description:
6
+
"A near-verbatim fork of ocaml-dns's Dns_client (the transport-agnostic stub resolver: query building, response matching, TCP framing, and a cache, over the upstream dns wire codec). The one change is that the monotonic clock and the RNG are lifted out of the transport module type into explicit parameters of Make.create, rather than being module-level globals every upstream transport binds to Mtime_clock.elapsed_ns and Mirage_crypto_rng. That lets the client run on a caller-supplied clock -- a unikernel's clock with no OS dependency, or a deterministic clock in tests -- so an Eio transport (nox-dns's dns-eio) can be freestanding. The wire format and the client logic are upstream's; the intent is to upstream the clock abstraction back to ocaml-dns."
7
+
maintainer: ["Thomas Gazagnaire <thomas@gazagnaire.org>"]
8
+
authors: ["Thomas Gazagnaire <thomas@gazagnaire.org>"]
9
+
license: "ISC"
10
+
tags: ["org:blacksun" "network"]
11
+
homepage: "https://tangled.org/gazagnaire.org/ocaml-dns"
12
+
bug-reports: "https://tangled.org/gazagnaire.org/ocaml-dns/issues"
13
+
depends: [
14
+
"ocaml" {>= "4.14.0"}
15
+
"dune" {>= "3.21" & >= "3.0"}
16
+
"dns"
17
+
"randomconv"
18
+
"domain-name"
19
+
"ipaddr"
20
+
"logs"
21
+
"duration"
22
+
"ohex"
23
+
"fmt"
24
+
"odoc" {with-doc}
25
+
]
26
+
build: [
27
+
["dune" "subst"] {dev}
28
+
[
29
+
"dune"
30
+
"build"
31
+
"-p"
32
+
name
33
+
"-j"
34
+
jobs
35
+
"@install"
36
+
"@runtest" {with-test}
37
+
"@doc" {with-doc}
38
+
]
39
+
]
40
+
dev-repo: "git+https://tangled.org/gazagnaire.org/ocaml-dns"
41
+
x-maintenance-intent: ["(latest)"]
+4
test/dune
+4
test/dune
+15
test/eio/dune
+15
test/eio/dune
+21
test/eio/interop/miekg-dns/dune
+21
test/eio/interop/miekg-dns/dune
···
1
+
(test
2
+
(name test)
3
+
(package dns-eio)
4
+
(libraries dns alcotest fmt domain-name nox-csv)
5
+
(deps
6
+
(source_tree traces)
7
+
(source_tree scripts)))
8
+
9
+
; Regenerate the committed traces: REGEN=1 dune build @traces.
10
+
11
+
(rule
12
+
(alias traces)
13
+
(deps
14
+
(alias traces/regen))
15
+
(action (progn)))
16
+
17
+
(rule
18
+
(alias regen-traces)
19
+
(deps
20
+
(alias traces/regen))
21
+
(action (progn)))
+73
test/eio/interop/miekg-dns/scripts/generate.go
+73
test/eio/interop/miekg-dns/scripts/generate.go
···
1
+
// Generator for dns-eio wire-format interop traces.
2
+
//
3
+
// For each TXT query we care about (e.g. _atproto.<handle>), emit the
4
+
// raw DNS query bytes miekg/dns produces. The test parses those bytes
5
+
// with the dns library our client uses and asserts the question round-
6
+
// trips (QNAME + QTYPE).
7
+
//
8
+
// Regen: dune build @traces (needs Go toolchain).
9
+
10
+
package main
11
+
12
+
import (
13
+
"encoding/csv"
14
+
"encoding/hex"
15
+
"fmt"
16
+
"os"
17
+
"path/filepath"
18
+
19
+
"github.com/miekg/dns"
20
+
)
21
+
22
+
var queries = []struct {
23
+
name string
24
+
qname string
25
+
qtype uint16
26
+
}{
27
+
{"atproto-txt", "_atproto.alice.bsky.social.", dns.TypeTXT},
28
+
{"example-txt", "_atproto.example.com.", dns.TypeTXT},
29
+
{"bsky-a", "bsky.social.", dns.TypeA},
30
+
}
31
+
32
+
func main() {
33
+
if len(os.Args) != 2 {
34
+
fmt.Fprintf(os.Stderr, "usage: generate <trace-dir>\n")
35
+
os.Exit(2)
36
+
}
37
+
traceDir := os.Args[1]
38
+
if err := os.MkdirAll(traceDir, 0o755); err != nil {
39
+
fmt.Fprintf(os.Stderr, "mkdir: %v\n", err)
40
+
os.Exit(1)
41
+
}
42
+
out, err := os.Create(filepath.Join(traceDir, "queries.csv"))
43
+
if err != nil {
44
+
fmt.Fprintf(os.Stderr, "create: %v\n", err)
45
+
os.Exit(1)
46
+
}
47
+
defer out.Close()
48
+
w := csv.NewWriter(out)
49
+
_ = w.Write([]string{"name", "qname", "qtype", "bytes_hex"})
50
+
for _, q := range queries {
51
+
m := new(dns.Msg)
52
+
m.Id = 0x1234 // deterministic for stable traces
53
+
m.RecursionDesired = true
54
+
m.Question = []dns.Question{
55
+
{Name: q.qname, Qtype: q.qtype, Qclass: dns.ClassINET},
56
+
}
57
+
b, err := m.Pack()
58
+
if err != nil {
59
+
fmt.Fprintf(os.Stderr, "pack %s: %v\n", q.name, err)
60
+
continue
61
+
}
62
+
_ = w.Write([]string{
63
+
q.name, q.qname,
64
+
dns.TypeToString[q.qtype],
65
+
hex.EncodeToString(b),
66
+
})
67
+
}
68
+
w.Flush()
69
+
if err := w.Error(); err != nil {
70
+
fmt.Fprintf(os.Stderr, "csv: %v\n", err)
71
+
os.Exit(1)
72
+
}
73
+
}
+9
test/eio/interop/miekg-dns/scripts/generate.sh
+9
test/eio/interop/miekg-dns/scripts/generate.sh
···
1
+
#!/bin/bash
2
+
set -euo pipefail
3
+
command -v go >/dev/null || { echo "go not on PATH" >&2; exit 1; }
4
+
SCRIPT_DIR="$(cd "$(dirname "$0")" && pwd)"
5
+
TRACE_DIR="$(cd "${1:-$SCRIPT_DIR/../traces}" && pwd)"
6
+
7
+
cd "$SCRIPT_DIR"
8
+
go mod download
9
+
go run generate.go "$TRACE_DIR"
+5
test/eio/interop/miekg-dns/scripts/go.mod
+5
test/eio/interop/miekg-dns/scripts/go.mod
+63
test/eio/interop/miekg-dns/test.ml
+63
test/eio/interop/miekg-dns/test.ml
···
1
+
(* miekg/dns interop: DNS wire-format roundtrip.
2
+
3
+
Oracle: github.com/miekg/dns Pack function, pinned via
4
+
scripts/go.mod. Regen: dune build @traces.
5
+
6
+
Each (name, qname, qtype, bytes_hex) row is a DNS query packet
7
+
miekg packed. We decode the packet bytes via the ocaml-dns library
8
+
and verify the question's qname and qtype match. Skipped when the
9
+
traces file has only a header (oracle not yet run in this checkout). *)
10
+
11
+
type row = { name : string; qname : string; qtype : string; bytes_hex : string }
12
+
13
+
let row_codec =
14
+
Csv.(
15
+
Row.(
16
+
obj (fun name qname qtype bytes_hex -> { name; qname; qtype; bytes_hex })
17
+
|> col "name" string ~enc:(fun r -> r.name)
18
+
|> col "qname" string ~enc:(fun r -> r.qname)
19
+
|> col "qtype" string ~enc:(fun r -> r.qtype)
20
+
|> col "bytes_hex" string ~enc:(fun r -> r.bytes_hex)
21
+
|> finish))
22
+
23
+
let hex_decode hex =
24
+
let n = String.length hex in
25
+
if n mod 2 <> 0 then invalid_arg "hex_decode: odd length";
26
+
let b = Buffer.create (n / 2) in
27
+
for i = 0 to (n / 2) - 1 do
28
+
let c = int_of_string ("0x" ^ String.sub hex (i * 2) 2) in
29
+
Buffer.add_char b (Char.chr c)
30
+
done;
31
+
Buffer.contents b
32
+
33
+
let roundtrip () =
34
+
match Csv.decode_file row_codec "traces/queries.csv" with
35
+
| Error msg -> Alcotest.failf "load CSV: %s" msg
36
+
| Ok [] ->
37
+
Fmt.pr
38
+
"@.[no data rows in queries.csv — run dune build @@traces to populate; \
39
+
skipping]@.@."
40
+
| Ok rows ->
41
+
List.iter
42
+
(fun { name; qname; qtype; bytes_hex } ->
43
+
let bytes = hex_decode bytes_hex in
44
+
match Dns.Packet.decode bytes with
45
+
| Error err ->
46
+
Alcotest.failf "%s: decode failed: %a" name Dns.Packet.pp_err err
47
+
| Ok pkt ->
48
+
let dname, _ = pkt.question in
49
+
Alcotest.(check string)
50
+
(name ^ " qname") qname
51
+
(Domain_name.to_string dname ^ ".");
52
+
Alcotest.(check string)
53
+
(name ^ " qtype") qtype
54
+
(Fmt.str "%a" Dns.Packet.Question.pp_qtype
55
+
(Option.get (Dns.Packet.Question.qtype pkt.question))))
56
+
rows
57
+
58
+
let () =
59
+
Alcotest.run "dns-eio-interop-miekg-dns"
60
+
[
61
+
( "roundtrip",
62
+
[ Alcotest.test_case "miekg-packs-ocaml-decodes" `Quick roundtrip ] );
63
+
]
+15
test/eio/interop/miekg-dns/traces/README.md
+15
test/eio/interop/miekg-dns/traces/README.md
···
1
+
# dns-eio / miekg-dns traces
2
+
3
+
`queries.csv` is generated by running the miekg/dns Pack function
4
+
against a curated set of DNS queries. Regenerate with:
5
+
6
+
dune build @traces
7
+
8
+
(needs the Go toolchain and an internet connection to fetch
9
+
`github.com/miekg/dns` at the version pinned in `../scripts/go.mod`).
10
+
11
+
The test reads `queries.csv`, decodes the hex-encoded packet bytes
12
+
with the `dns` protocol library (the same one `dns-eio` uses under
13
+
the hood), and asserts the question roundtrips to the committed
14
+
`qname`/`qtype`. It is skipped when `queries.csv` is absent or has
15
+
no data rows.
+15
test/eio/interop/miekg-dns/traces/dune
+15
test/eio/interop/miekg-dns/traces/dune
···
1
+
; Regenerate the committed traces: REGEN=1 dune build @traces.
2
+
; (enabled_if REGEN=1) keeps the rule from existing during a normal
3
+
; dune test, so the traces stay pure committed source and the oracle is
4
+
; never run; only REGEN=1 makes them promote targets and runs it.
5
+
6
+
(rule
7
+
(alias regen)
8
+
(mode promote)
9
+
(enabled_if
10
+
(= %{env:REGEN=0} 1))
11
+
(targets README.md queries.csv)
12
+
(deps
13
+
(source_tree ../scripts))
14
+
(action
15
+
(run bash ../scripts/generate.sh .)))
+1
test/eio/interop/miekg-dns/traces/queries.csv
+1
test/eio/interop/miekg-dns/traces/queries.csv
···
1
+
name,qname,qtype,bytes_hex
+1
test/eio/test.ml
+1
test/eio/test.ml
···
1
+
let () = Alcotest.run "dns-eio" [ Test_dns_eio.suite; Test_forward_eio.suite ]
+123
test/eio/test_dns_eio.ml
+123
test/eio/test_dns_eio.ml
···
1
+
(* Tests for the pure parts of Dns_eio.
2
+
3
+
Live DNS queries need an oracle trace (forthcoming interop commit);
4
+
what we test here is pp_error rendering across every variant,
5
+
nameserver discovery from a synthetic resolv.conf, and the default
6
+
resolver's fallback behavior. *)
7
+
8
+
let contains ~needle hay = Re.execp Re.(compile (str needle)) hay
9
+
10
+
let pp_error () =
11
+
let pp (e : Dns_eio.error) = Fmt.str "%a" Dns_eio.pp_error e in
12
+
Alcotest.(check bool) "msg" true (contains ~needle:"boom" (pp (`Msg "boom")));
13
+
Alcotest.(check bool)
14
+
"timeout" true
15
+
(contains ~needle:"timeout" (pp `Timeout));
16
+
Alcotest.(check bool)
17
+
"nxdomain" true
18
+
(contains ~needle:"NXDOMAIN" (pp `Nxdomain));
19
+
Alcotest.(check bool)
20
+
"servfail" true
21
+
(contains ~needle:"RCODE 2" (pp (`Servfail 2)));
22
+
Alcotest.(check bool)
23
+
"truncated" true
24
+
(contains ~needle:"truncated" (pp `Truncated));
25
+
Alcotest.(check bool)
26
+
"malformed" true
27
+
(contains ~needle:"bad" (pp (`Malformed "bad packet")))
28
+
29
+
(* create with explicit nameservers. *)
30
+
let explicit_nameservers () =
31
+
let ns =
32
+
[ Ipaddr.of_string_exn "9.9.9.9"; Ipaddr.of_string_exn "149.112.112.112" ]
33
+
in
34
+
let t = Dns_eio.v ~nameservers:ns () in
35
+
Alcotest.(check (list string))
36
+
"same ns order"
37
+
[ "9.9.9.9"; "149.112.112.112" ]
38
+
(List.map Ipaddr.to_string (Dns_eio.nameservers t))
39
+
40
+
(* create with no nameservers argument reads /etc/resolv.conf or falls
41
+
back to Cloudflare + Google. Either outcome is acceptable in CI; what
42
+
we assert is that the list is non-empty and every entry is a valid IP. *)
43
+
let default () =
44
+
let t = Dns_eio.v () in
45
+
let ns = Dns_eio.nameservers t in
46
+
Alcotest.(check bool) "non-empty" true (ns <> []);
47
+
List.iter
48
+
(fun ip ->
49
+
Alcotest.(check bool)
50
+
(Fmt.str "valid-ip-%s" (Ipaddr.to_string ip))
51
+
true
52
+
(match Ipaddr.of_string (Ipaddr.to_string ip) with
53
+
| Ok _ -> true
54
+
| Error _ -> false))
55
+
ns
56
+
57
+
(* A minimal loopback DNS-over-TCP server: read one length-prefixed query,
58
+
answer it with a single A record, framed the same way. This exercises the
59
+
real RFC 7766 framing on both ends through the dns codec. *)
60
+
let serve_one_a ~sw ~answer flow =
61
+
let r = Eio.Buf_read.of_flow ~max_size:0x10000 flow in
62
+
let len = Eio.Buf_read.BE.uint16 r in
63
+
let query = Eio.Buf_read.take len r in
64
+
ignore sw;
65
+
match Dns.Packet.decode query with
66
+
| Error _ -> ()
67
+
| Ok q ->
68
+
let name = fst q.Dns.Packet.question in
69
+
let a =
70
+
Dns.Name_rr_map.singleton name Dns.Rr_map.A
71
+
(300l, Ipaddr.V4.Set.singleton answer)
72
+
in
73
+
let reply =
74
+
Dns.Packet.create q.Dns.Packet.header q.Dns.Packet.question
75
+
(`Answer (a, Dns.Name_rr_map.empty))
76
+
in
77
+
let bytes, _ = Dns.Packet.encode `Tcp reply in
78
+
let prefix = Bytes.create 2 in
79
+
Bytes.set_uint16_be prefix 0 (String.length bytes);
80
+
Eio.Flow.copy_string (Bytes.unsafe_to_string prefix ^ bytes) flow
81
+
82
+
(* The TCP transport resolves an A record over a loopback nameserver, proving
83
+
the query framing, the connection, and the length-prefixed reply parse --
84
+
the path a unikernel takes over its TCP-only stack. *)
85
+
let tcp_resolves () =
86
+
let answer = Ipaddr.V4.of_string_exn "203.0.113.42" in
87
+
let resolved =
88
+
Eio_main.run @@ fun env ->
89
+
Eio.Switch.run @@ fun sw ->
90
+
let net = Eio.Stdenv.net env and clock = Eio.Stdenv.clock env in
91
+
let listen =
92
+
Eio.Net.listen ~sw ~backlog:1 net (`Tcp (Eio.Net.Ipaddr.V4.loopback, 0))
93
+
in
94
+
let port =
95
+
match Eio.Net.listening_addr listen with
96
+
| `Tcp (_, p) -> p
97
+
| `Unix _ -> assert false
98
+
in
99
+
Eio.Fiber.fork ~sw (fun () ->
100
+
let flow, _ = Eio.Net.accept ~sw listen in
101
+
serve_one_a ~sw ~answer flow);
102
+
let t =
103
+
Dns_eio.v
104
+
~nameservers:[ Ipaddr.V4 Ipaddr.V4.localhost ]
105
+
~port ~proto:`Tcp ()
106
+
in
107
+
match Dns_eio.a ~sw ~net ~clock t "test.example.com" with
108
+
| Ok ips -> ips
109
+
| Error e -> Alcotest.failf "TCP resolve failed: %a" Dns_eio.pp_error e
110
+
in
111
+
Alcotest.(check (list string))
112
+
"resolved the A record over TCP"
113
+
[ Ipaddr.V4.to_string answer ]
114
+
(List.map Ipaddr.V4.to_string resolved)
115
+
116
+
let suite : string * unit Alcotest.test_case list =
117
+
( "dns_eio",
118
+
[
119
+
Alcotest.test_case "error/pp" `Quick pp_error;
120
+
Alcotest.test_case "create/explicit" `Quick explicit_nameservers;
121
+
Alcotest.test_case "create/default" `Quick default;
122
+
Alcotest.test_case "tcp transport resolves" `Quick tcp_resolves;
123
+
] )
+4
test/eio/test_dns_eio.mli
+4
test/eio/test_dns_eio.mli
+107
test/eio/test_forward_eio.ml
+107
test/eio/test_forward_eio.ml
···
1
+
module Cfg = Nox_dns.Forward_config
2
+
module Hosts = Nox_dns.Hosts
3
+
module Pure = Nox_dns.Client.Pure
4
+
5
+
let dn s = Domain_name.of_string_exn s
6
+
let rng n = String.make n '\001'
7
+
8
+
let single_upstream ~ip ~port =
9
+
{
10
+
Cfg.servers =
11
+
Cfg.Server.Set.of_list
12
+
[
13
+
{
14
+
zones = Cfg.Domain.Set.empty;
15
+
address = { ip = Ipaddr.of_string_exn ip; port };
16
+
timeout = None;
17
+
order = 0;
18
+
};
19
+
];
20
+
search = [];
21
+
assume_offline_after_drops = Some 2;
22
+
}
23
+
24
+
(* A fake upstream's reply: decode the forwarded query and answer its A question
25
+
with [addr], echoing the id and (0x20-cased) name. *)
26
+
let fake_a_reply query addr =
27
+
match Dns.Packet.decode query with
28
+
| Error _ -> None
29
+
| Ok q ->
30
+
let flags =
31
+
Dns.Packet.Flags.of_list [ `Recursion_desired; `Recursion_available ]
32
+
in
33
+
let name, _ = q.Dns.Packet.question in
34
+
let ans =
35
+
( Dns.Name_rr_map.singleton name Dns.Rr_map.A
36
+
(60l, Ipaddr.V4.Set.singleton addr),
37
+
Dns.Name_rr_map.empty )
38
+
in
39
+
let reply =
40
+
Dns.Packet.create
41
+
(fst q.Dns.Packet.header, flags)
42
+
q.Dns.Packet.question (`Answer ans)
43
+
in
44
+
Some (fst (Dns.Packet.encode `Udp reply))
45
+
46
+
let extract state wire =
47
+
match Pure.handle_response state wire with
48
+
| Ok (`Data (_, set)) -> Ipaddr.V4.Set.elements set
49
+
| Ok `Partial -> Alcotest.fail "partial reply"
50
+
| Ok (`No_data _ | `No_domain _) -> Alcotest.fail "negative reply"
51
+
| Error (`Msg m) -> Alcotest.failf "client rejected reply: %s" m
52
+
53
+
(* A hosts name resolves through the edge with no upstream at all. *)
54
+
let hosts_local () =
55
+
let got =
56
+
Eio_main.run @@ fun env ->
57
+
Eio.Switch.run @@ fun sw ->
58
+
let net = (Eio.Stdenv.net env :> [ `Generic ] Eio.Net.ty Eio.Resource.t) in
59
+
let clock = Eio.Stdenv.mono_clock env in
60
+
let hosts = Hosts.of_string "203.0.113.9 svc.local\n" in
61
+
let fw = Forward_eio.v ~sw ~net ~clock ~hosts () in
62
+
let q, state =
63
+
Pure.make_query rng `Udp `None (dn "svc.local") Dns.Rr_map.A
64
+
in
65
+
extract state (Forward_eio.resolve fw q)
66
+
in
67
+
Alcotest.(check (list string))
68
+
"hosts answer" [ "203.0.113.9" ]
69
+
(List.map Ipaddr.V4.to_string got)
70
+
71
+
(* A non-local name is forwarded over UDP to a loopback upstream and its reply
72
+
returned to the client. *)
73
+
let udp_forwards () =
74
+
let answer = Ipaddr.V4.of_string_exn "198.51.100.7" in
75
+
let port = 53535 in
76
+
let got =
77
+
Eio_main.run @@ fun env ->
78
+
Eio.Switch.run @@ fun sw ->
79
+
let net = (Eio.Stdenv.net env :> [ `Generic ] Eio.Net.ty Eio.Resource.t) in
80
+
let clock = Eio.Stdenv.mono_clock env in
81
+
let server =
82
+
Eio.Net.datagram_socket ~sw net (`Udp (Eio.Net.Ipaddr.V4.loopback, port))
83
+
in
84
+
Eio.Fiber.fork ~sw (fun () ->
85
+
let buf = Cstruct.create 4096 in
86
+
let src, n = Eio.Net.recv server buf in
87
+
let query = Cstruct.to_string (Cstruct.sub buf 0 n) in
88
+
match fake_a_reply query answer with
89
+
| Some reply -> Eio.Net.send server ~dst:src [ Cstruct.of_string reply ]
90
+
| None -> ());
91
+
let cfg = single_upstream ~ip:"127.0.0.1" ~port in
92
+
let fw = Forward_eio.v ~sw ~net ~clock ~cfg ~timeout_s:2.0 () in
93
+
let q, state =
94
+
Pure.make_query rng `Udp `None (dn "example.com") Dns.Rr_map.A
95
+
in
96
+
extract state (Forward_eio.resolve fw q)
97
+
in
98
+
Alcotest.(check (list string))
99
+
"forwarded upstream answer" [ "198.51.100.7" ]
100
+
(List.map Ipaddr.V4.to_string got)
101
+
102
+
let suite =
103
+
( "forward_eio",
104
+
[
105
+
Alcotest.test_case "hosts local" `Quick hosts_local;
106
+
Alcotest.test_case "udp forwards" `Quick udp_forwards;
107
+
] )
+5
test/eio/test_forward_eio.mli
+5
test/eio/test_forward_eio.mli
+13
test/test.ml
+13
test/test.ml
+36
test/test_case0x20.ml
+36
test/test_case0x20.ml
···
1
+
module Case0x20 = Nox_dns.Case0x20
2
+
3
+
let dn s = Domain_name.of_string_exn s
4
+
5
+
(* An all-ones RNG uppercases every letter; the name is semantically unchanged
6
+
but the exact case only matches itself. *)
7
+
let test_encode_verify () =
8
+
let up =
9
+
Case0x20.encode ~rng:(fun n -> String.make n '\xff') (dn "example.com")
10
+
in
11
+
Alcotest.(check string)
12
+
"all letters uppercased" "EXAMPLE.COM" (Domain_name.to_string up);
13
+
Alcotest.(check bool)
14
+
"the semantic name is unchanged" true
15
+
(Domain_name.equal up (dn "example.com"));
16
+
Alcotest.(check bool)
17
+
"verify accepts an exact-case echo" true
18
+
(Case0x20.verify ~sent:up ~received:up);
19
+
Alcotest.(check bool)
20
+
"verify rejects a different-case reply" false
21
+
(Case0x20.verify ~sent:up ~received:(dn "example.com"))
22
+
23
+
(* An all-zeroes RNG lowercases every letter. *)
24
+
let test_lowercase () =
25
+
let lo =
26
+
Case0x20.encode ~rng:(fun n -> String.make n '\x00') (dn "ExAmPlE.CoM")
27
+
in
28
+
Alcotest.(check string)
29
+
"all letters lowercased" "example.com" (Domain_name.to_string lo)
30
+
31
+
let suite =
32
+
( "case0x20",
33
+
[
34
+
Alcotest.test_case "encode/verify" `Quick test_encode_verify;
35
+
Alcotest.test_case "lowercase" `Quick test_lowercase;
36
+
] )
+6
test/test_case0x20.mli
+6
test/test_case0x20.mli
···
1
+
(** Tests for DNS 0x20 case randomisation ({!Nox_dns.Case0x20}). *)
2
+
3
+
val suite : string * unit Alcotest.test_case list
4
+
(** [suite] checks encoding preserves the semantic name, uppercases under an
5
+
all-ones RNG and lowercases under an all-zeroes one, and that verify only
6
+
accepts an exact-case echo. *)
+79
test/test_client.ml
+79
test/test_client.ml
···
1
+
(* The point of this fork: [Make.create] takes an injected clock and RNG, so the
2
+
client runs on a caller-controlled clock with no OS dependency. This drives it
3
+
with a deterministic counter clock over a mock transport that answers from
4
+
memory (no I/O), and asserts both that resolution works and that the injected
5
+
clock was the one used. *)
6
+
7
+
module Client = Nox_dns.Client
8
+
9
+
let tcp_frame msg =
10
+
let prefix = Bytes.create 2 in
11
+
Bytes.set_uint16_be prefix 0 (String.length msg);
12
+
Bytes.unsafe_to_string prefix ^ msg
13
+
14
+
(* A transport that never touches the network: it decodes the query and answers
15
+
it with a fixed A record, framed as the client expects (RFC 7766). *)
16
+
module Mock :
17
+
Client.S
18
+
with type io_addr = unit
19
+
and type stack = Ipaddr.V4.t
20
+
and type 'a io = 'a = struct
21
+
type io_addr = unit
22
+
type +'a io = 'a
23
+
type stack = Ipaddr.V4.t
24
+
type t = Ipaddr.V4.t
25
+
type context = Ipaddr.V4.t
26
+
27
+
let v ?nameservers:_ ~timeout:_ answer = answer
28
+
let nameservers _ = (`Tcp, [ () ])
29
+
let bind x f = f x
30
+
let lift = Fun.id
31
+
let connect answer = Ok (`Tcp, answer)
32
+
let close _ = ()
33
+
34
+
let send_recv answer query =
35
+
(* strip the 2-byte TCP length prefix the client added *)
36
+
let msg = String.sub query 2 (String.length query - 2) in
37
+
match Dns.Packet.decode msg with
38
+
| Error _ -> Error (`Msg "mock: undecodable query")
39
+
| Ok q ->
40
+
let name = fst q.Dns.Packet.question in
41
+
let rr =
42
+
Dns.Name_rr_map.singleton name Dns.Rr_map.A
43
+
(300l, Ipaddr.V4.Set.singleton answer)
44
+
in
45
+
let reply =
46
+
Dns.Packet.create q.Dns.Packet.header q.Dns.Packet.question
47
+
(`Answer (rr, Dns.Name_rr_map.empty))
48
+
in
49
+
let bytes, _ = Dns.Packet.encode `Tcp reply in
50
+
Ok (tcp_frame bytes)
51
+
end
52
+
53
+
module C = Client.Make (Mock)
54
+
55
+
let test_injected_clock () =
56
+
let ticks = ref 0L in
57
+
let clock () =
58
+
let v = !ticks in
59
+
ticks := Int64.add v 1L;
60
+
v
61
+
in
62
+
let rng n = String.make n '\042' in
63
+
let answer = Ipaddr.V4.of_string_exn "192.0.2.7" in
64
+
let t = C.v ~clock ~rng ~nameservers:(`Tcp, [ () ]) answer in
65
+
match
66
+
C.getaddrinfo t Dns.Rr_map.A (Domain_name.of_string_exn "example.com")
67
+
with
68
+
| Error (`Msg m) -> Alcotest.failf "resolve failed: %s" m
69
+
| Ok (_ttl, set) ->
70
+
Alcotest.(check (list string))
71
+
"resolved the A record" [ "192.0.2.7" ]
72
+
(List.map Ipaddr.V4.to_string (Ipaddr.V4.Set.elements set));
73
+
Alcotest.(check bool)
74
+
"the injected clock was used (advanced past zero)" true (!ticks > 0L)
75
+
76
+
let suite =
77
+
( "client",
78
+
[ Alcotest.test_case "injected clock resolves" `Quick test_injected_clock ]
79
+
)
+5
test/test_client.mli
+5
test/test_client.mli
+83
test/test_edns_policy.ml
+83
test/test_edns_policy.ml
···
1
+
module E = Nox_dns.Edns_policy
2
+
3
+
let edns ?(payload_size = 512) ?(extensions = []) () =
4
+
Dns.Edns.create ~payload_size ~extensions ()
5
+
6
+
(* Payload size is clamped to [512, safe_max]; no client EDNS means 512. *)
7
+
let test_clamp_payload () =
8
+
Alcotest.(check int) "no EDNS -> floor" 512 (E.clamp_payload None);
9
+
Alcotest.(check int)
10
+
"large advertised clamps to safe_max" E.safe_max
11
+
(E.clamp_payload (Some (edns ~payload_size:4096 ())));
12
+
Alcotest.(check int)
13
+
"in-range advertised is kept" 1000
14
+
(E.clamp_payload (Some (edns ~payload_size:1000 ())));
15
+
Alcotest.(check int)
16
+
"tiny advertised raised to the floor" 512
17
+
(E.clamp_payload (Some (edns ~payload_size:200 ())));
18
+
Alcotest.(check int)
19
+
"an explicit max is honoured" 900
20
+
(E.clamp_payload ~max:900 (Some (edns ~payload_size:4096 ())))
21
+
22
+
(* A reply larger than the negotiated UDP size must be truncated. *)
23
+
let test_truncated () =
24
+
Alcotest.(check bool)
25
+
"over budget truncates" true
26
+
(E.truncated ~reply_len:1500 ~udp_size:1232);
27
+
Alcotest.(check bool)
28
+
"within budget does not" false
29
+
(E.truncated ~reply_len:800 ~udp_size:1232)
30
+
31
+
(* EDNS Client Subnet (option code 8) is stripped; other options survive. *)
32
+
let test_strip_ecs () =
33
+
let e =
34
+
edns
35
+
~extensions:[ Dns.Edns.Extension (8, "subnet"); Dns.Edns.Nsid "keep" ]
36
+
()
37
+
in
38
+
let stripped = E.strip_ecs e in
39
+
let has_ecs (x : Dns.Edns.t) =
40
+
List.exists
41
+
(function Dns.Edns.Extension (8, _) -> true | _ -> false)
42
+
x.extensions
43
+
in
44
+
let has_nsid (x : Dns.Edns.t) =
45
+
List.exists (function Dns.Edns.Nsid _ -> true | _ -> false) x.extensions
46
+
in
47
+
Alcotest.(check bool) "ECS removed" false (has_ecs stripped);
48
+
Alcotest.(check bool) "other options kept" true (has_nsid stripped)
49
+
50
+
(* A cookie is applied to the query and its server half learned from a matching
51
+
response, but a mismatched client half is rejected. *)
52
+
let test_cookie () =
53
+
let rng n = String.make n 'A' in
54
+
let c = E.Cookie.v ~rng in
55
+
Alcotest.(check bool) "no server cookie yet" false (E.Cookie.has_server c);
56
+
let q = E.Cookie.apply c (edns ()) in
57
+
let sent_cookie =
58
+
List.find_map
59
+
(function Dns.Edns.Cookie s -> Some s | _ -> None)
60
+
q.Dns.Edns.extensions
61
+
in
62
+
Alcotest.(check bool)
63
+
"cookie option present on query" true
64
+
(Option.is_some sent_cookie);
65
+
let client_half = String.make 8 'A' in
66
+
let response =
67
+
edns ~extensions:[ Dns.Edns.Cookie (client_half ^ "SERVER01") ] ()
68
+
in
69
+
let c = E.Cookie.learn c response in
70
+
Alcotest.(check bool) "server cookie learned" true (E.Cookie.has_server c);
71
+
let bad = edns ~extensions:[ Dns.Edns.Cookie ("XXXXXXXX" ^ "SERVER01") ] () in
72
+
let c2 = E.Cookie.learn (E.Cookie.v ~rng) bad in
73
+
Alcotest.(check bool)
74
+
"mismatched client half is rejected" false (E.Cookie.has_server c2)
75
+
76
+
let suite =
77
+
( "edns_policy",
78
+
[
79
+
Alcotest.test_case "clamp payload" `Quick test_clamp_payload;
80
+
Alcotest.test_case "truncated" `Quick test_truncated;
81
+
Alcotest.test_case "strip ECS" `Quick test_strip_ecs;
82
+
Alcotest.test_case "cookie" `Quick test_cookie;
83
+
] )
+6
test/test_edns_policy.mli
+6
test/test_edns_policy.mli
···
1
+
(** Tests for the EDNS(0) forwarder policy ({!Nox_dns.Edns_policy}). *)
2
+
3
+
val suite : string * unit Alcotest.test_case list
4
+
(** [suite] checks payload-size clamping to [[512, safe_max]], the TC truncation
5
+
decision, EDNS Client Subnet stripping, and DNS Cookie apply/learn with
6
+
client-half verification. *)
+115
test/test_forward.ml
+115
test/test_forward.ml
···
1
+
module F = Nox_dns.Forward
2
+
module C = Nox_dns.Forward_config
3
+
module Hosts = Nox_dns.Hosts
4
+
module Pure = Nox_dns.Client.Pure
5
+
6
+
let dn s = Domain_name.of_string_exn s
7
+
let v4 s = Ipaddr.V4.of_string_exn s
8
+
let clock () = 1_000_000_000L
9
+
10
+
let counter_rng () =
11
+
let c = ref 0 in
12
+
fun n ->
13
+
String.init n (fun _ ->
14
+
incr c;
15
+
Char.chr (!c land 0xff))
16
+
17
+
let cfg =
18
+
{
19
+
C.servers =
20
+
C.Server.Set.of_list
21
+
[
22
+
{
23
+
zones = C.Domain.Set.empty;
24
+
address = { ip = Ipaddr.of_string_exn "1.1.1.1"; port = 53 };
25
+
timeout = None;
26
+
order = 0;
27
+
};
28
+
];
29
+
search = [];
30
+
assume_offline_after_drops = Some 3;
31
+
}
32
+
33
+
let hosts = Hosts.of_string "10.0.0.9 local.test\n"
34
+
let forwarder () = F.v ~cfg ~hosts ~proto:`Udp ~rng:(counter_rng ()) ~clock ()
35
+
36
+
(* A canned upstream reply to an attempt's query, echoing its id and question
37
+
with an A answer -- what a real resolver would send back. *)
38
+
let canned_a attempt data =
39
+
match Dns.Packet.decode (F.attempt_query attempt) with
40
+
| Error _ -> Alcotest.fail "attempt query did not decode"
41
+
| Ok q ->
42
+
let flags =
43
+
Dns.Packet.Flags.of_list [ `Recursion_desired; `Recursion_available ]
44
+
in
45
+
let name, _ = q.Dns.Packet.question in
46
+
let answer =
47
+
(Dns.Name_rr_map.singleton name Dns.Rr_map.A data, Dns.Name_rr_map.empty)
48
+
in
49
+
let reply =
50
+
Dns.Packet.create
51
+
(fst q.Dns.Packet.header, flags)
52
+
q.Dns.Packet.question (`Answer answer)
53
+
in
54
+
fst (Dns.Packet.encode `Udp reply)
55
+
56
+
let extract client_state wire =
57
+
match Pure.handle_response client_state wire with
58
+
| Ok (`Data (_ttl, set)) -> set
59
+
| Ok `Partial -> Alcotest.fail "reply was partial"
60
+
| Ok (`No_data _ | `No_domain _) -> Alcotest.fail "reply was negative"
61
+
| Error (`Msg m) -> Alcotest.failf "client rejected the reply: %s" m
62
+
63
+
(* A name in the hosts table is answered locally, without any upstream. *)
64
+
let test_hosts_hit () =
65
+
let t = forwarder () in
66
+
let q, state =
67
+
Pure.make_query (counter_rng ()) `Udp `None (dn "local.test") Dns.Rr_map.A
68
+
in
69
+
match F.decide t q with
70
+
| F.Reply wire ->
71
+
Alcotest.(check bool)
72
+
"hosts answer is 10.0.0.9" true
73
+
(Ipaddr.V4.Set.mem (v4 "10.0.0.9") (extract state wire))
74
+
| F.Forward _ -> Alcotest.fail "a hosts name should not be forwarded"
75
+
| F.Drop m -> Alcotest.failf "unexpected drop: %s" m
76
+
77
+
(* A non-local name is forwarded; the upstream reply is validated and returned
78
+
to the client, then a second query for the same name is a cache hit. *)
79
+
let test_forward_then_cache () =
80
+
let t = forwarder () in
81
+
let q, state =
82
+
Pure.make_query (counter_rng ()) `Udp `None (dn "example.com") Dns.Rr_map.A
83
+
in
84
+
(match F.decide t q with
85
+
| F.Forward req -> (
86
+
let attempt = List.hd (List.hd req.groups) in
87
+
let upstream =
88
+
canned_a attempt (300l, Ipaddr.V4.Set.singleton (v4 "93.184.216.34"))
89
+
in
90
+
match F.on_reply t req attempt upstream with
91
+
| F.Resolved wire ->
92
+
Alcotest.(check bool)
93
+
"forwarded answer reaches the client" true
94
+
(Ipaddr.V4.Set.mem (v4 "93.184.216.34") (extract state wire))
95
+
| F.Negative _ -> Alcotest.fail "expected a positive answer"
96
+
| F.Failed m -> Alcotest.failf "upstream unexpectedly failed: %s" m)
97
+
| _ -> Alcotest.fail "example.com should be forwarded");
98
+
(* Second time round: served from cache, no forwarding. *)
99
+
let q2, state2 =
100
+
Pure.make_query (counter_rng ()) `Udp `None (dn "example.com") Dns.Rr_map.A
101
+
in
102
+
match F.decide t q2 with
103
+
| F.Reply wire ->
104
+
Alcotest.(check bool)
105
+
"cached answer is served" true
106
+
(Ipaddr.V4.Set.mem (v4 "93.184.216.34") (extract state2 wire))
107
+
| F.Forward _ -> Alcotest.fail "the second query should hit the cache"
108
+
| F.Drop m -> Alcotest.failf "unexpected drop: %s" m
109
+
110
+
let suite =
111
+
( "forward",
112
+
[
113
+
Alcotest.test_case "hosts hit" `Quick test_hosts_hit;
114
+
Alcotest.test_case "forward then cache" `Quick test_forward_then_cache;
115
+
] )
+6
test/test_forward.mli
+6
test/test_forward.mli
···
1
+
(** End-to-end tests for the forwarder decision core ({!Nox_dns.Forward}). *)
2
+
3
+
val suite : string * unit Alcotest.test_case list
4
+
(** [suite] drives the core against a canned upstream: a hosts name is answered
5
+
locally, a non-local name is forwarded and its validated reply returned to
6
+
the client, and a repeat query is served from the cache. *)
+128
test/test_forward_config.ml
+128
test/test_forward_config.ml
···
1
+
module C = Nox_dns.Forward_config
2
+
3
+
let dn s = Domain_name.of_string_exn s
4
+
let ip s = Ipaddr.of_string_exn s
5
+
let addr = Alcotest.testable C.Address.pp C.Address.equal
6
+
7
+
(* Address text form is [ip#port], round-tripping and unambiguous for IPv6. *)
8
+
let test_address_roundtrip () =
9
+
let check s want =
10
+
match C.Address.of_string s with
11
+
| Error (`Msg m) -> Alcotest.failf "of_string %S: %s" s m
12
+
| Ok a ->
13
+
Alcotest.check addr ("parse " ^ s) want a;
14
+
Alcotest.(check string)
15
+
("render " ^ s) (C.Address.to_string want) (C.Address.to_string a)
16
+
in
17
+
check "8.8.8.8" { ip = ip "8.8.8.8"; port = 53 };
18
+
check "8.8.8.8#5353" { ip = ip "8.8.8.8"; port = 5353 };
19
+
check "2001:4860:4860::8888#53" { ip = ip "2001:4860:4860::8888"; port = 53 }
20
+
21
+
(* A server's zone matches a queried subdomain but not an unrelated name. *)
22
+
let test_is_subdomain () =
23
+
Alcotest.(check bool)
24
+
"a.corp is within corp" true
25
+
(C.Domain.is_subdomain ~subdomain:(dn "a.corp") (dn "corp"));
26
+
Alcotest.(check bool)
27
+
"example.com is not within corp" false
28
+
(C.Domain.is_subdomain ~subdomain:(dn "example.com") (dn "corp"))
29
+
30
+
let config_eq a b = C.compare a b = 0
31
+
let config = Alcotest.testable (Fmt.of_to_string C.to_string) config_eq
32
+
33
+
(* to_string / of_string round-trip a config with a scoped server (zone +
34
+
timeout + order) and an unscoped one. *)
35
+
let test_config_roundtrip () =
36
+
let servers =
37
+
C.Server.Set.of_list
38
+
[
39
+
{
40
+
zones = C.Domain.Set.of_list [ dn "corp"; dn "internal" ];
41
+
address = { ip = ip "10.0.0.1"; port = 53 };
42
+
timeout = Some 2_000_000_000L;
43
+
order = 0;
44
+
};
45
+
{
46
+
zones = C.Domain.Set.empty;
47
+
address = { ip = ip "1.1.1.1"; port = 53 };
48
+
timeout = None;
49
+
order = 1;
50
+
};
51
+
]
52
+
in
53
+
let cfg =
54
+
{ C.servers; search = [ "example.com" ]; assume_offline_after_drops = None }
55
+
in
56
+
match C.of_string (C.to_string cfg) with
57
+
| Error (`Msg m) -> Alcotest.failf "round-trip failed: %s" m
58
+
| Ok back -> Alcotest.check config "round-trips" cfg back
59
+
60
+
(* Zone / timeout / order lines bind to the nameserver line that follows them. *)
61
+
let test_of_string_attrs_precede () =
62
+
let text =
63
+
"zone corp\n\
64
+
timeout 500\n\
65
+
order 3\n\
66
+
nameserver 10.0.0.1#5300\n\
67
+
nameserver 8.8.8.8\n"
68
+
in
69
+
match C.of_string text with
70
+
| Error (`Msg m) -> Alcotest.failf "parse failed: %s" m
71
+
| Ok cfg ->
72
+
let servers = C.Server.Set.elements cfg.servers in
73
+
Alcotest.(check int) "two servers" 2 (List.length servers);
74
+
let scoped =
75
+
List.find (fun (s : C.server) -> s.address.port = 5300) servers
76
+
in
77
+
Alcotest.(check bool)
78
+
"scoped server carries the corp zone" true
79
+
(C.Domain.Set.mem (dn "corp") scoped.zones);
80
+
Alcotest.(check (option int64))
81
+
"scoped server timeout is 500ms in ns" (Some 500_000_000L)
82
+
scoped.timeout;
83
+
Alcotest.(check int) "scoped server order" 3 scoped.order;
84
+
let plain =
85
+
List.find (fun (s : C.server) -> s.address.port = 53) servers
86
+
in
87
+
Alcotest.(check bool)
88
+
"the following server resets its scope" true
89
+
(C.Domain.Set.is_empty plain.zones)
90
+
91
+
(* /etc/resolv.conf nameservers become unscoped upstreams; comments ignored. *)
92
+
let test_of_resolv_conf () =
93
+
let text =
94
+
"# a comment\nnameserver 1.1.1.1\nnameserver 8.8.4.4 # inline\nsearch lan\n"
95
+
in
96
+
match C.of_resolv_conf text with
97
+
| Error (`Msg m) -> Alcotest.failf "parse failed: %s" m
98
+
| Ok cfg ->
99
+
Alcotest.(check int)
100
+
"two nameservers" 2
101
+
(C.Server.Set.cardinal cfg.servers);
102
+
Alcotest.(check (list string)) "search carried" [ "lan" ] cfg.search;
103
+
Alcotest.(check bool)
104
+
"all unscoped" true
105
+
(C.Server.Set.for_all
106
+
(fun (s : C.server) -> C.Domain.Set.is_empty s.zones)
107
+
cfg.servers)
108
+
109
+
(* The offline threshold is a tuning knob, not part of config identity. *)
110
+
let test_compare_ignores_offline () =
111
+
let base = C.of_string "nameserver 1.1.1.1\n" |> Result.get_ok in
112
+
let a = { base with assume_offline_after_drops = Some 2 } in
113
+
let b = { base with assume_offline_after_drops = Some 9 } in
114
+
Alcotest.(check bool)
115
+
"offline threshold does not affect compare" true (config_eq a b)
116
+
117
+
let suite =
118
+
( "forward_config",
119
+
[
120
+
Alcotest.test_case "address round-trip" `Quick test_address_roundtrip;
121
+
Alcotest.test_case "zone is-subdomain" `Quick test_is_subdomain;
122
+
Alcotest.test_case "config round-trip" `Quick test_config_roundtrip;
123
+
Alcotest.test_case "attrs precede nameserver" `Quick
124
+
test_of_string_attrs_precede;
125
+
Alcotest.test_case "of_resolv_conf" `Quick test_of_resolv_conf;
126
+
Alcotest.test_case "compare ignores offline" `Quick
127
+
test_compare_ignores_offline;
128
+
] )
+7
test/test_forward_config.mli
+7
test/test_forward_config.mli
···
1
+
(** Tests for the forwarder configuration ({!Nox_dns.Forward_config}). *)
2
+
3
+
val suite : string * unit Alcotest.test_case list
4
+
(** [suite] checks the [ip#port] address form, zone subdomain matching, the
5
+
vpnkit config text round-trip and attrs-precede-nameserver parse, the
6
+
[/etc/resolv.conf] reader, and that the offline threshold is not part of
7
+
config identity. *)
+42
test/test_hosts.ml
+42
test/test_hosts.ml
···
1
+
module Hosts = Nox_dns.Hosts
2
+
3
+
let dn s = Domain_name.of_string_exn s
4
+
5
+
(* A parsed hosts table answers A and Aaaa case-insensitively and returns None
6
+
for absent names, wrong record types, and commented-out lines. *)
7
+
let test_lookup () =
8
+
let table =
9
+
"# a comment\n\
10
+
127.0.0.1 localhost\n\
11
+
10.0.0.5 build.corp BUILD\t# aliases and a tab\n\
12
+
::1 localhost\n\
13
+
# 10.0.0.9 ignored.corp\n"
14
+
in
15
+
let t = Hosts.of_string table in
16
+
(match Hosts.lookup t (dn "build.corp") Dns.Rr_map.A with
17
+
| Some (ttl, set) ->
18
+
Alcotest.(check bool) "positive TTL" true (ttl > 0l);
19
+
Alcotest.(check bool)
20
+
"build.corp -> 10.0.0.5" true
21
+
(Ipaddr.V4.Set.mem (Ipaddr.V4.of_string_exn "10.0.0.5") set)
22
+
| None -> Alcotest.fail "build.corp A should resolve");
23
+
Alcotest.(check bool)
24
+
"lookup is case-insensitive" true
25
+
(Hosts.mem t (dn "BUILD"));
26
+
(match Hosts.lookup t (dn "localhost") Dns.Rr_map.Aaaa with
27
+
| Some (_, set) ->
28
+
Alcotest.(check bool)
29
+
"localhost -> ::1" true
30
+
(Ipaddr.V6.Set.mem (Ipaddr.V6.of_string_exn "::1") set)
31
+
| None -> Alcotest.fail "localhost AAAA should resolve");
32
+
Alcotest.(check bool)
33
+
"absent name is None" true
34
+
(Hosts.lookup t (dn "absent.corp") Dns.Rr_map.A = None);
35
+
Alcotest.(check bool)
36
+
"commented line is ignored" false
37
+
(Hosts.mem t (dn "ignored.corp"));
38
+
Alcotest.(check bool)
39
+
"no A record for an v6-only name means None" true
40
+
(Hosts.lookup t (dn "build.corp") Dns.Rr_map.Aaaa = None)
41
+
42
+
let suite = ("hosts", [ Alcotest.test_case "lookup" `Quick test_lookup ])
+5
test/test_hosts.mli
+5
test/test_hosts.mli
+50
test/test_id_mux.ml
+50
test/test_id_mux.ml
···
1
+
module Id_mux = Nox_dns.Id_mux
2
+
3
+
(* A deterministic RNG: successive bytes count up, so draws are distinct and the
4
+
tests are reproducible. *)
5
+
let counter_rng () =
6
+
let c = ref 0 in
7
+
fun n ->
8
+
String.init n (fun _ ->
9
+
incr c;
10
+
Char.chr (!c land 0xff))
11
+
12
+
(* Allocated ids are distinct, tracked, and freed. *)
13
+
let test_alloc () =
14
+
let m = Id_mux.v ~rng:(counter_rng ()) () in
15
+
let m, id1 = Option.get (Id_mux.alloc m) in
16
+
let m, id2 = Option.get (Id_mux.alloc m) in
17
+
Alcotest.(check bool) "ids are distinct" true (id1 <> id2);
18
+
Alcotest.(check bool) "ids are 16-bit" true (id1 >= 0 && id1 <= 0xffff);
19
+
Alcotest.(check bool) "allocated id is in use" true (Id_mux.in_use m id1);
20
+
Alcotest.(check int) "two outstanding" 2 (Id_mux.outstanding m);
21
+
let m = Id_mux.free m id1 in
22
+
Alcotest.(check bool) "freed id is not in use" false (Id_mux.in_use m id1);
23
+
Alcotest.(check int) "one outstanding after free" 1 (Id_mux.outstanding m)
24
+
25
+
(* At the cap, [alloc] returns [None] rather than a colliding id; a free
26
+
reopens a slot. *)
27
+
let test_cap () =
28
+
let m = Id_mux.v ~max_elements:3 ~rng:(counter_rng ()) () in
29
+
let rec fill m ids = function
30
+
| 0 -> (m, ids)
31
+
| n -> (
32
+
match Id_mux.alloc m with
33
+
| Some (m, id) -> fill m (id :: ids) (n - 1)
34
+
| None -> Alcotest.fail "allocator full before the cap")
35
+
in
36
+
let m, ids = fill m [] 3 in
37
+
Alcotest.(check bool)
38
+
"allocator is full at the cap" true
39
+
(match Id_mux.alloc m with None -> true | Some _ -> false);
40
+
let m = Id_mux.free m (List.hd ids) in
41
+
Alcotest.(check bool)
42
+
"a free reopens a slot" true
43
+
(match Id_mux.alloc m with Some _ -> true | None -> false)
44
+
45
+
let suite =
46
+
( "id_mux",
47
+
[
48
+
Alcotest.test_case "alloc/free" `Quick test_alloc;
49
+
Alcotest.test_case "cap" `Quick test_cap;
50
+
] )
+5
test/test_id_mux.mli
+5
test/test_id_mux.mli
+85
test/test_server_select.ml
+85
test/test_server_select.ml
···
1
+
module C = Nox_dns.Forward_config
2
+
module H = Nox_dns.Upstream_health
3
+
module S = Nox_dns.Server_select
4
+
5
+
let dn s = Domain_name.of_string_exn s
6
+
let ip s = Ipaddr.of_string_exn s
7
+
8
+
let server ?(zones = []) ~addr ?(order = 0) () : C.server =
9
+
{
10
+
zones = C.Domain.Set.of_list (List.map dn zones);
11
+
address = { ip = ip addr; port = 53 };
12
+
timeout = None;
13
+
order;
14
+
}
15
+
16
+
let corp = server ~zones:[ "corp" ] ~addr:"10.0.0.1" ~order:0 ()
17
+
let pub_a = server ~addr:"1.1.1.1" ~order:0 ()
18
+
let pub_b = server ~addr:"8.8.8.8" ~order:1 ()
19
+
20
+
let cfg =
21
+
{
22
+
C.servers = C.Server.Set.of_list [ corp; pub_a; pub_b ];
23
+
search = [];
24
+
assume_offline_after_drops = None;
25
+
}
26
+
27
+
let addrs groups =
28
+
List.map
29
+
(List.map (fun (s : C.server) -> Ipaddr.to_string s.address.ip))
30
+
groups
31
+
32
+
let all_fresh _ = H.fresh
33
+
34
+
(* A query inside a server's zone goes only to that server (no leak to public
35
+
resolvers). *)
36
+
let test_zone_scoped () =
37
+
let groups = S.choose cfg ~health:all_fresh (dn "host.corp") in
38
+
Alcotest.(check (list (list string)))
39
+
"corp query -> only the corp server" [ [ "10.0.0.1" ] ] (addrs groups)
40
+
41
+
(* A public query goes to all servers, grouped by ascending order. *)
42
+
let test_public_grouped_by_order () =
43
+
let groups = S.choose cfg ~health:all_fresh (dn "example.com") in
44
+
Alcotest.(check (list (list string)))
45
+
"grouped by order"
46
+
[ [ "1.1.1.1"; "10.0.0.1" ]; [ "8.8.8.8" ] ]
47
+
(addrs groups)
48
+
49
+
(* An offline upstream is dropped from the candidates. *)
50
+
let test_offline_dropped () =
51
+
let health (a : C.Address.t) =
52
+
if Ipaddr.compare a.ip (ip "1.1.1.1") = 0 then
53
+
H.record_drop H.fresh ~assume_offline_after:1
54
+
else H.fresh
55
+
in
56
+
let groups = S.choose cfg ~health (dn "example.com") in
57
+
Alcotest.(check (list (list string)))
58
+
"1.1.1.1 dropped as offline"
59
+
[ [ "10.0.0.1" ]; [ "8.8.8.8" ] ]
60
+
(addrs groups)
61
+
62
+
(* Within a group, the faster (lower smoothed RTT) upstream is tried first. *)
63
+
let test_rtt_order () =
64
+
let health (a : C.Address.t) =
65
+
if Ipaddr.compare a.ip (ip "10.0.0.1") = 0 then
66
+
H.record_success H.fresh ~rtt:100_000_000L
67
+
else if Ipaddr.compare a.ip (ip "1.1.1.1") = 0 then
68
+
H.record_success H.fresh ~rtt:20_000_000L
69
+
else H.fresh
70
+
in
71
+
let groups = S.choose cfg ~health (dn "example.com") in
72
+
Alcotest.(check (list (list string)))
73
+
"faster 1.1.1.1 before slower 10.0.0.1"
74
+
[ [ "1.1.1.1"; "10.0.0.1" ]; [ "8.8.8.8" ] ]
75
+
(addrs groups)
76
+
77
+
let suite =
78
+
( "server_select",
79
+
[
80
+
Alcotest.test_case "zone scoped" `Quick test_zone_scoped;
81
+
Alcotest.test_case "public grouped by order" `Quick
82
+
test_public_grouped_by_order;
83
+
Alcotest.test_case "offline dropped" `Quick test_offline_dropped;
84
+
Alcotest.test_case "rtt order" `Quick test_rtt_order;
85
+
] )
+5
test/test_server_select.mli
+5
test/test_server_select.mli
+48
test/test_upstream_health.ml
+48
test/test_upstream_health.ml
···
1
+
module H = Nox_dns.Upstream_health
2
+
3
+
(* A fresh upstream is online, undropped, and has no RTT. *)
4
+
let test_fresh () =
5
+
Alcotest.(check bool) "fresh is online" true (H.online H.fresh);
6
+
Alcotest.(check int) "no drops" 0 (H.drops H.fresh);
7
+
Alcotest.(check bool) "no RTT" true (H.srtt H.fresh = None)
8
+
9
+
(* Consecutive drops mark the upstream offline exactly at the threshold. *)
10
+
let test_offline_threshold () =
11
+
let assume_offline_after = 3 in
12
+
let one t = H.record_drop t ~assume_offline_after in
13
+
let t1 = one H.fresh in
14
+
let t2 = one t1 in
15
+
let t3 = one t2 in
16
+
Alcotest.(check bool) "online after 1 drop" true (H.online t1);
17
+
Alcotest.(check bool) "online after 2 drops" true (H.online t2);
18
+
Alcotest.(check bool) "offline at the 3rd drop" false (H.online t3)
19
+
20
+
(* A success clears the drop count and brings the upstream back online. *)
21
+
let test_success_recovers () =
22
+
let dropped =
23
+
H.record_drop
24
+
(H.record_drop H.fresh ~assume_offline_after:2)
25
+
~assume_offline_after:2
26
+
in
27
+
Alcotest.(check bool) "offline after 2 drops" false (H.online dropped);
28
+
let ok = H.record_success dropped ~rtt:1_000_000L in
29
+
Alcotest.(check bool) "back online after a success" true (H.online ok);
30
+
Alcotest.(check int) "drop count cleared" 0 (H.drops ok)
31
+
32
+
(* The smoothed RTT is the first sample, then an EWMA (7/8 old + 1/8 new). *)
33
+
let test_srtt_ewma () =
34
+
let t = H.record_success H.fresh ~rtt:8_000_000L in
35
+
Alcotest.(check (option int64))
36
+
"first sample is the RTT" (Some 8_000_000L) (H.srtt t);
37
+
let t = H.record_success t ~rtt:16_000_000L in
38
+
(* 7/8 * 8ms + 1/8 * 16ms = 9ms *)
39
+
Alcotest.(check (option int64)) "EWMA of the two" (Some 9_000_000L) (H.srtt t)
40
+
41
+
let suite =
42
+
( "upstream_health",
43
+
[
44
+
Alcotest.test_case "fresh" `Quick test_fresh;
45
+
Alcotest.test_case "offline threshold" `Quick test_offline_threshold;
46
+
Alcotest.test_case "success recovers" `Quick test_success_recovers;
47
+
Alcotest.test_case "srtt ewma" `Quick test_srtt_ewma;
48
+
] )
+5
test/test_upstream_health.mli
+5
test/test_upstream_health.mli