swrup/mte
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Browse source
This commit is contained in:
swrup 2025-11-11 02:07:51 +01:00
parent aa2ff7b2f0
commit 2f3113f55d
11742 changed files with 1223940 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

328
unikernel/duniverse/ocaml-dns/test/client.ml Normal file
View file

@ -0,0 +1,328 @@
let ip =
let module M = struct
type t = Ipaddr.V4.t
let pp = Ipaddr.V4.pp
let equal a b = Ipaddr.V4.compare a b = 0
end in
(module M : Alcotest.TESTABLE with type t = M.t)
let ipset = Alcotest.(slist ip Ipaddr.V4.compare)
let p_cs = Alcotest.testable (Ohex.pp_hexdump ()) String.equal
module Make_query_tests = struct
let produces_same_output () =
let rng n = String.make n '\x00' in
let name:'a Domain_name.t = Domain_name.of_string_exn "example.com" in
let actual, _state = Dns_client.Pure.make_query rng `Tcp `Auto name Dns.Rr_map.A in
let expected = Ohex.decode
"00 2e 00 00 01 00 00 01 00 00 00 00 00 01 07 65
78 61 6d 70 6c 65 03 63 6f 6d 00 00 01 00 01 00
00 29 02 00 00 00 00 00 00 06 00 0b 00 02 04 b0" in
Alcotest.check p_cs "produces cool stuff" expected actual
let tests = [
"produces same output", `Quick, produces_same_output;
"fails on unspported query_type", `Quick, produces_same_output;
]
end
module Parse_response_tests = struct
let unpacks_response () =
(* Bytes 3, 4 are set to `00 00` - these represent query ID *)
let ipv4_buf = Ohex.decode
"00 77 00 00 81 80 00 01 00 01 00 02 00 02 03 66
6f 6f 03 63 6f 6d 00 00 01 00 01 c0 0c 00 01 00
01 00 00 02 2a 00 04 17 17 56 2c c0 0c 00 02 00
01 00 01 87 ae 00 10 03 6e 73 31 09 64 69 67 69
6d 65 64 69 61 c0 10 c0 0c 00 02 00 01 00 01 87
ae 00 06 03 6e 73 32 c0 39 c0 35 00 01 00 01 00
02 40 8a 00 04 17 15 f2 58 c0 51 00 01 00 01 00
02 40 8a 00 04 17 15 f3 77" in
(* This `rng` generates zeros, used for the query ID above *)
let rng n = String.make n '\x00' in
let name:'a Domain_name.t = Domain_name.of_string_exn "foo.com" in
let _actual, state = Dns_client.Pure.make_query rng `Tcp `Auto name Dns.Rr_map.A in
match Dns_client.Pure.handle_response state ipv4_buf with
| Ok `Data _ -> () (* TODO: Alcotest TESTABLE for this return value *)
| _ -> ignore(failwith "error")
let fails_to_unpack_mismatched () =
(* TODO: It is possible to use crowbar here, to generate the ipv4_buf *)
(* Bytes 3, 4 are set to `aa aa` - these represent query ID *)
let ipv4_buf = Ohex.decode
"00 77 aa aa 81 80 00 01 00 01 00 02 00 02 03 66
6f 6f 03 63 6f 6d 00 00 01 00 01 c0 0c 00 01 00
01 00 00 02 2a 00 04 17 17 56 2c c0 0c 00 02 00
01 00 01 87 ae 00 10 03 6e 73 31 09 64 69 67 69
6d 65 64 69 61 c0 10 c0 0c 00 02 00 01 00 01 87
ae 00 06 03 6e 73 32 c0 39 c0 35 00 01 00 01 00
02 40 8a 00 04 17 15 f2 58 c0 51 00 01 00 01 00
02 40 8a 00 04 17 15 f3 77" in
(* This `rng` generates zeros, used for the query ID above *)
let rng n = String.make n '\x00' in
let name:'a Domain_name.t = Domain_name.of_string_exn "foo.com" in
let _actual, state = Dns_client.Pure.make_query rng `Tcp `Auto name Dns.Rr_map.A in
match Dns_client.Pure.parse_response state ipv4_buf with
| Error `Msg _ -> ()
| __ -> failwith "should have rejected mismatched input"
(* TODO: Alcotest TESTABLE for this return value *)
let tests = [
"unpacks some kind of response", `Quick, unpacks_response;
"fails to unpack response with mismatching query ID", `Quick, fails_to_unpack_mismatched;
]
end
(* {!Transport} provides a mock implementation of the transport used by
Dns_client.Make. The mock data uses the default_debug_info reference cell.
*)
type debug_info = string
let default_debug_info = ref []
module Transport (*: Dns_client.S
with type io_addr = debug_info
and type stack = unit
and type +'a io = 'a *)
= struct
type io_addr = debug_info
type stack = Dns.proto
type context = debug_info list ref
type t = Dns.proto
type +'a io = 'a
let create ?nameservers:_ ~timeout:_ proto = proto
let nameservers proto = proto, !default_debug_info
let rng n = String.make n '\x00'
let clock () = 0L
let bind a b = b a
let lift v = v
let close _ = ()
let connect a = Ok (a, default_debug_info)
let send_recv (mock_responses : context) _ =
match !mock_responses with
| [] -> failwith("nothing to recv from the wire")
| hd::tail -> mock_responses := tail; Ok hd
end
(* Now that we have our {!Transport} implementation we can include the logic
that goes on top of it: *)
include Dns_client.Make(Transport)
module Transport_with_time_machine = struct
include Transport
(* the timestamps are for: cache lookup1, cache upate, cache lookup2, cache update2 *)
let timestamps = ref [0L; 0L; Duration.of_sec 601 ; Duration.of_sec 601]
let clock () =
match !timestamps with
| [] -> assert false
| head::tail -> timestamps := tail; head
end
module Dns_client_with_time_machine = Dns_client.Make(Transport_with_time_machine)
module Gethostbyname_tests = struct
let foo_com_is_valid () =
let domain_name = Domain_name.(of_string_exn "foo.com" |> host_exn) in
(* Bytes 3, 4 are set to `00 00` - these represent query ID *)
let ipv4_buf = Ohex.decode
"00 77 00 00 81 80 00 01 00 01 00 02 00 02 03 66
6f 6f 03 63 6f 6d 00 00 01 00 01 c0 0c 00 01 00
01 00 00 02 2a 00 04 17 17 56 2c c0 0c 00 02 00
01 00 01 87 ae 00 10 03 6e 73 31 09 64 69 67 69
6d 65 64 69 61 c0 10 c0 0c 00 02 00 01 00 01 87
ae 00 06 03 6e 73 32 c0 39 c0 35 00 01 00 01 00
02 40 8a 00 04 17 15 f2 58 c0 51 00 01 00 01 00
02 40 8a 00 04 17 15 f3 77" in
let t = create `Tcp in
default_debug_info := [ipv4_buf];
match gethostbyname t domain_name with
| Ok _ip -> ()
| Error _ -> failwith "foo.com should have been returned"
let returns_from_the_cache () =
let domain_name = Domain_name.(of_string_exn "foo.com" |> host_exn) in
(* Bytes 3, 4 are set to `00 00` - these represent query ID *)
let ipv4_buf = Ohex.decode
"00 77 00 00 81 80 00 01 00 01 00 02 00 02 03 66
6f 6f 03 63 6f 6d 00 00 01 00 01 c0 0c 00 01 00
01 00 00 02 2a 00 04 17 17 56 2c c0 0c 00 02 00
01 00 01 87 ae 00 10 03 6e 73 31 09 64 69 67 69
6d 65 64 69 61 c0 10 c0 0c 00 02 00 01 00 01 87
ae 00 06 03 6e 73 32 c0 39 c0 35 00 01 00 01 00
02 40 8a 00 04 17 15 f2 58 c0 51 00 01 00 01 00
02 40 8a 00 04 17 15 f3 77" in
let t = create `Tcp in
default_debug_info := [ipv4_buf];
match gethostbyname t domain_name with
| Error _ -> failwith "foo.com should have been returned"
| Ok _ip ->
default_debug_info := [];
match gethostbyname t domain_name with
| Error _ -> failwith "should have been cached"
| Ok _ -> () (* we returned content, but the wire stayed silent *)
let uses_network_when_cache_evicted () =
let domain_name = Domain_name.(of_string_exn "foo.com" |> host_exn) in
(* Bytes 3, 4 are set to `00 00` - these represent query ID *)
let ipv4_buf = Ohex.decode
"00 77 00 00 81 80 00 01 00 01 00 02 00 02 03 66
6f 6f 03 63 6f 6d 00 00 01 00 01 c0 0c 00 01 00
01 00 00 02 2a 00 04 17 17 56 2c c0 0c 00 02 00
01 00 01 87 ae 00 10 03 6e 73 31 09 64 69 67 69
6d 65 64 69 61 c0 10 c0 0c 00 02 00 01 00 01 87
ae 00 06 03 6e 73 32 c0 39 c0 35 00 01 00 01 00
02 40 8a 00 04 17 15 f2 58 c0 51 00 01 00 01 00
02 40 8a 00 04 17 15 f3 77" in
let t = Dns_client_with_time_machine.create `Tcp in
default_debug_info := [ipv4_buf];
match Dns_client_with_time_machine.gethostbyname t domain_name with
| Error _ -> failwith "foo.com should have been returned"
| Ok _ip ->
default_debug_info := [ipv4_buf];
match Dns_client_with_time_machine.gethostbyname t domain_name with
| Error _ -> failwith "should have been cached"
| Ok _ -> (* we returned content, AND the wire was used *)
assert (!default_debug_info = [])
let tests = [
"foo.com is valid", `Quick, foo_com_is_valid;
"when cache is populated, return from cache", `Quick, returns_from_the_cache;
"when content evicted, use network", `Quick, uses_network_when_cache_evicted;
]
end
module Getaddrinfo_tests = struct
let supports_mx_packets () =
let domain_name = Domain_name.(of_string_exn "google.com" |> host_exn) in
(* a google.com MX record - bytes 3,4 are set to the query ID 00 00 *)
let ipv4_buf = Ohex.decode
"02 1e 00 00 81 80 00 01 00 05 00 04 00 0f 06 67
6f 6f 67 6c 65 03 63 6f 6d 00 00 0f 00 01 c0 0c
00 0f 00 01 00 00 02 58 00 11 00 1e 04 61 6c 74
32 05 61 73 70 6d 78 01 6c c0 0c c0 0c 00 0f 00
01 00 00 02 58 00 04 00 0a c0 2f c0 0c 00 0f 00
01 00 00 02 58 00 09 00 28 04 61 6c 74 33 c0 2f
c0 0c 00 0f 00 01 00 00 02 58 00 09 00 14 04 61
6c 74 31 c0 2f c0 0c 00 0f 00 01 00 00 02 58 00
09 00 32 04 61 6c 74 34 c0 2f c0 0c 00 02 00 01
00 00 ad 8c 00 06 03 6e 73 31 c0 0c c0 0c 00 02
00 01 00 00 ad 8c 00 06 03 6e 73 34 c0 0c c0 0c
00 02 00 01 00 00 ad 8c 00 06 03 6e 73 33 c0 0c
c0 0c 00 02 00 01 00 00 ad 8c 00 06 03 6e 73 32
c0 0c c0 2f 00 01 00 01 00 00 00 e0 00 04 6c b1
77 1b c0 6c 00 01 00 01 00 00 00 0d 00 04 ac d9
c2 1b 04 41 4c 54 32 c0 2f 00 01 00 01 00 00 00
0d 00 04 6c b1 61 1b c0 81 00 01 00 01 00 00 00
e0 00 04 6c b1 08 1a c0 94 00 01 00 01 00 03 8b
b6 00 04 d8 ef 20 0a c0 ca 00 01 00 01 00 03 8f
54 00 04 d8 ef 22 0a c0 b8 00 01 00 01 00 03 8b
b6 00 04 d8 ef 24 0a c0 a6 00 01 00 01 00 03 97
5d 00 04 d8 ef 26 0a c0 2f 00 1c 00 01 00 00 00
f9 00 10 2a 00 14 50 40 13 0c 01 00 00 00 00 00
00 00 1b c0 6c 00 1c 00 01 00 00 00 f9 00 10 24
04 68 00 40 03 0c 04 00 00 00 00 00 00 00 1b 04
41 4c 54 33 c0 2f 00 1c 00 01 00 00 01 1b 00 10
26 07 f8 b0 40 0e 0c 00 00 00 00 00 00 00 00 1b
c0 94 00 1c 00 01 00 02 64 96 00 10 20 01 48 60
48 02 00 32 00 00 00 00 00 00 00 0a c0 ca 00 1c
00 01 00 04 54 3a 00 10 20 01 48 60 48 02 00 34
00 00 00 00 00 00 00 0a c0 b8 00 1c 00 01 00 01
79 ea 00 10 20 01 48 60 48 02 00 36 00 00 00 00
00 00 00 0a c0 a6 00 1c 00 01 00 01 d1 ba 00 10
20 01 48 60 48 02 00 38 00 00 00 00 00 00 00 0a" in
let mock_state = create `Tcp in
default_debug_info := [ipv4_buf];
match getaddrinfo mock_state Dns.Rr_map.Mx domain_name with
| Ok (_ttl, mx_set) ->
let make_mx_record (preference, domain_name) =
Dns.Mx.{
preference;
mail_exchange = Domain_name.host_exn (Domain_name.of_string_exn domain_name)
} in
(* assert this is Google MX *)
Alcotest.(check bool __LOC__ true (Dns.Rr_map.Mx_set.equal mx_set
(Dns.Rr_map.Mx_set.of_list
(List.map make_mx_record [
(10, "aspmx.l.google.com");
(20, "alt1.aspmx.l.google.com");
(30, "alt2.aspmx.l.google.com");
(40, "alt3.aspmx.l.google.com");
(50, "alt4.aspmx.l.google.com")
]))))
| Error _ -> failwith "foo.com should have been returned"
let fails_on_partial_udp_packet () =
let domain_name = Domain_name.(of_string_exn "google.com" |> host_exn) in
(* A partial google.com MX record
first two bytes identify this as a TCP packet - dropped here
bytes 3,4 are set to the query ID 00 00
*)
let udp_buf = Ohex.decode
" 00 00 81 80 00 01 00 05 00 04 00 0f 06 67
6f 6f 67 6c 65 03 63 6f " in
let mock_state = create `Udp in
default_debug_info := [udp_buf];
match getaddrinfo mock_state Dns.Rr_map.Mx domain_name with
| Error `Msg actual ->
let expected = "Truncated UDP response" in
Alcotest.(check string "reports the truncated UDP packet failure" expected actual)
| Ok (_, _) -> failwith "Should have reported the Truncated UDP packet"
let cname_and_nodata_packet () =
(* we request a non-existing record type of existing domain name, which is
an alias - the reply is a CNAME with NoData *)
(* concretely, requesting AAAA raw.githubusercontent.com, reply is
AN: raw.githubusercontent.com CNAME github.map.fastly.net
AU: SOA fastly.net *)
let domain_name =
Domain_name.(of_string_exn "raw.githubusercontent.com" |> host_exn)
in
let udp_buf = Ohex.decode {|
00 00 81 80 00 01 00 01 00 01 00 00 03 72
61 77 11 67 69 74 68 75 62 75 73 65 72 63 6f 6e
74 65 6e 74 03 63 6f 6d 00 00 1c 00 01 c0 0c 00
05 00 01 00 00 00 16 00 17 06 67 69 74 68 75 62
03 6d 61 70 06 66 61 73 74 6c 79 03 6e 65 74 00
c0 42 00 06 00 01 00 00 00 14 00 2e 03 6e 73 31
c0 42 0a 68 6f 73 74 6d 61 73 74 65 72 06 66 61
73 74 6c 79 c0 22 78 39 c6 29 00 00 0e 10 00 00
02 58 00 09 3a 80 00 00 00 1e|}
in
let mock_state = create `Udp in
default_debug_info := [udp_buf];
match getaddrinfo mock_state Dns.Rr_map.Aaaa domain_name with
| Error `Msg actual ->
let expected = "DNS cache error no data fastly.net" in
let len = String.length expected in
Alcotest.(check string __LOC__ expected (String.sub actual 0 len))
| Ok (_, _) -> Alcotest.fail "Should have returned nodata"
let tests = [
"supports_mx_packets", `Quick, supports_mx_packets;
"a partial UDP response packet fails", `Quick, fails_on_partial_udp_packet;
"cname and nodata in packet", `Quick, cname_and_nodata_packet;
]
end
let tests = [
"make_query tests", Make_query_tests.tests;
"parse_response tests", Parse_response_tests.tests;
"gethostbyname tests", Gethostbyname_tests.tests;
"getaddrinfo tests", Getaddrinfo_tests.tests;
]
let () = Alcotest.run "DNS client tests" tests