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

View file

@ -0,0 +1,4 @@
(test
(name tests)
(package arp)
(libraries arp macaddr cstruct alcotest))

View file

@ -0,0 +1,5 @@
(test
(name tests)
(package arp)
(libraries alcotest lwt.unix logs logs.fmt fmt mirage-vnetif
duration ethernet arp arp.mirage cstruct bos))

View file

@ -0,0 +1,530 @@
open Lwt.Infix
module B = Basic_backend.Make
module V = Vnetif.Make(B)
module E = Ethernet.Make(V)
module A = Arp.Make(E)
let src = Logs.Src.create "test_arp" ~doc:"Mirage ARP tester"
module Log = (val Logs.src_log src : Logs.LOG)
type arp_stack = {
backend : B.t;
netif: V.t;
ethif: E.t;
arp: A.t;
}
let first_ip = Ipaddr.V4.of_string_exn "192.168.3.1"
let second_ip = Ipaddr.V4.of_string_exn "192.168.3.10"
let sample_mac = Macaddr.of_string_exn "10:9a:dd:c0:ff:ee"
let packet = (module Arp_packet : Alcotest.TESTABLE with type t = Arp_packet.t)
let ip =
let module M = struct
type t = Ipaddr.V4.t
let pp = Ipaddr.V4.pp
let equal p q = (Ipaddr.V4.compare p q) = 0
end in
(module M : Alcotest.TESTABLE with type t = M.t)
let macaddr =
let module M = struct
type t = Macaddr.t
let pp = Macaddr.pp
let equal p q = (Macaddr.compare p q) = 0
end in
(module M : Alcotest.TESTABLE with type t = M.t)
let header_size = Ethernet.Packet.sizeof_ethernet
let size = Arp_packet.size
let check_header ~message expected actual =
Alcotest.(check packet) message expected actual
let fail = Alcotest.fail
let failf fmt = Fmt.kstr (fun s -> Alcotest.fail s) fmt
let timeout ~time t =
let msg = Printf.sprintf "Timed out: didn't complete in %d milliseconds" time in
Lwt.pick [ t; Mirage_sleep.ns (Duration.of_ms time) >>= fun () -> fail msg; ]
let check_response expected buf =
match Arp_packet.decode buf with
| Error s -> Alcotest.fail (Fmt.to_to_string Arp_packet.pp_error s)
| Ok actual ->
Alcotest.(check packet) "parsed packet comparison" expected actual
let check_ethif_response expected buf =
let open Ethernet.Packet in
match of_cstruct buf with
| Error s -> Alcotest.fail s
| Ok ({ethertype; _}, arp) ->
match ethertype with
| `ARP -> check_response expected arp
| _ -> Alcotest.fail "Ethernet packet with non-ARP ethertype"
let garp source_mac source_ip =
let open Arp_packet in
{
operation = Request;
source_mac;
target_mac = Macaddr.of_octets_exn "\000\000\000\000\000\000";
source_ip;
target_ip = source_ip;
}
let fail_on_receipt netif buf =
Alcotest.fail (Format.asprintf "received traffic when none was expected on interface %a: %a"
Macaddr.pp (V.mac netif) Cstruct.hexdump_pp buf)
let single_check netif expected =
V.listen netif ~header_size (fun buf ->
match Ethernet.Packet.of_cstruct buf with
| Error _ -> failwith "sad face"
| Ok (_, payload) ->
check_response expected payload; V.disconnect netif) >|= fun _ -> ()
(* { Ethernet_packet.source = arp.source_mac;
destination = arp.target_mac;
ethertype = `ARP;
} *)
let arp_reply ~from_netif ~to_netif ~from_ip ~to_ip arp =
let open Arp_packet in
let a =
{ operation = Reply;
source_mac = V.mac from_netif;
target_mac = V.mac to_netif;
source_ip = from_ip;
target_ip = to_ip}
in
encode_into a arp ;
Arp_packet.size
let arp_request ~from_netif ~to_mac ~from_ip ~to_ip arp =
let open Arp_packet in
let a =
{ operation = Request;
source_mac = V.mac from_netif;
target_mac = to_mac;
source_ip = from_ip;
target_ip = to_ip}
in
encode_into a arp ;
Arp_packet.size
let get_arp ?backend () =
let backend = match backend with
| None -> B.create ~use_async_readers:true ~yield:Lwt.pause ()
| Some b -> b
in
V.connect backend >>= fun netif ->
E.connect netif >>= fun ethif ->
A.connect ~probe_delay:(Duration.of_ms 2) ethif >>= fun arp ->
Lwt.return { backend; netif; ethif; arp }
(* we almost always want two stacks on the same backend *)
let two_arp () =
get_arp () >>= fun first ->
get_arp ~backend:first.backend () >>= fun second ->
Lwt.return (first, second)
(* ...but sometimes we want three *)
let three_arp () =
get_arp () >>= fun first ->
get_arp ~backend:first.backend () >>= fun second ->
get_arp ~backend:first.backend () >>= fun third ->
Lwt.return (first, second, third)
let query_or_die arp ip expected_mac =
A.query arp ip >>= function
| Error `Timeout ->
Log.warn (fun f -> f "Timeout querying %a. Table contents: %a"
Ipaddr.V4.pp ip A.pp arp);
fail "ARP query failed when success was mandatory";
| Ok mac ->
Alcotest.(check macaddr) "mismatch for expected query value" expected_mac mac;
Lwt.return_unit
| Error e -> failf "ARP query failed with %a" A.pp_error e
let query_and_no_response arp ip =
A.query arp ip >>= function
| Error `Timeout ->
Log.warn (fun f -> f "Timeout querying %a. Table contents: %a" Ipaddr.V4.pp ip A.pp arp);
Lwt.return_unit
| Ok _ -> failf "expected nothing, found something in cache"
| Error e ->
Log.err (fun m -> m "another err");
failf "ARP query failed with %a" A.pp_error e
let set_and_check ~listener ~claimant ip =
A.set_ips claimant.arp [ ip ] >>= fun () ->
Log.debug (fun f -> f "Set IP for %a to %a" Macaddr.pp (V.mac claimant.netif) Ipaddr.V4.pp ip);
Logs.debug (fun f -> f "Listener table contents after IP set on claimant: %a" A.pp listener);
query_or_die listener ip (V.mac claimant.netif)
let start_arp_listener stack () =
let noop = (fun _ -> Lwt.return_unit) in
Log.debug (fun f -> f "starting arp listener for %a" Macaddr.pp (V.mac stack.netif));
let arpv4 frame =
Log.debug (fun f -> f "frame received for arpv4");
A.input stack.arp frame
in
E.input ~arpv4 ~ipv4:noop ~ipv6:noop stack.ethif
let not_in_cache ~listen probe arp ip =
Lwt.pick [
single_check listen probe;
Mirage_sleep.ns (Duration.of_ms 100) >>= fun () ->
A.query arp ip >>= function
| Ok _ -> failf "entry in cache when it shouldn't be %a" Ipaddr.V4.pp ip
| Error `Timeout -> Lwt.return_unit
| Error e -> failf "error for %a while reading the cache: %a"
Ipaddr.V4.pp ip A.pp_error e
]
let set_ip_sends_garp () =
two_arp () >>= fun (speak, listen) ->
let emit_garp =
Mirage_sleep.ns (Duration.of_ms 100) >>= fun () ->
A.set_ips speak.arp [ first_ip ] >>= fun () ->
Alcotest.(check (list ip)) "garp emitted when setting ip" [ first_ip ] (A.get_ips speak.arp);
Lwt.return_unit
in
let expected_garp = garp (V.mac speak.netif) first_ip in
timeout ~time:500 (
Lwt.join [
single_check listen.netif expected_garp;
emit_garp;
]) >>= fun () ->
(* now make sure we have consistency when setting *)
A.set_ips speak.arp [] >>= fun () ->
Alcotest.(check (slist ip Ipaddr.V4.compare)) "list of bound IPs on initialization" [] (A.get_ips speak.arp);
A.set_ips speak.arp [ first_ip; second_ip ] >>= fun () ->
Alcotest.(check (slist ip Ipaddr.V4.compare)) "list of bound IPs after setting two IPs"
[ first_ip; second_ip ] (A.get_ips speak.arp);
Lwt.return_unit
let add_get_remove_ips () =
get_arp () >>= fun stack ->
let check str expected =
Alcotest.(check (list ip)) str expected (A.get_ips stack.arp)
in
check "bound ips is an empty list on startup" [];
A.set_ips stack.arp [ first_ip; first_ip ] >>= fun () ->
check "set ips with duplicate elements result in deduplication" [first_ip];
A.remove_ip stack.arp first_ip >>= fun () ->
check "ip list is empty after removing only ip" [];
A.remove_ip stack.arp first_ip >>= fun () ->
check "ip list is empty after removing from empty list" [];
A.add_ip stack.arp first_ip >>= fun () ->
check "first ip is the only member of the set of bound ips" [first_ip];
A.add_ip stack.arp first_ip >>= fun () ->
check "adding ips is idempotent" [first_ip];
Lwt.return_unit
let input_single_garp () =
two_arp () >>= fun (listen, speak) ->
(* set the IP on speak_arp, which should cause a GARP to be emitted which
listen_arp will hear and cache. *)
let one_and_done buf =
let arpbuf = Cstruct.shift buf 14 in
A.input listen.arp arpbuf >>= fun () ->
V.disconnect listen.netif
in
timeout ~time:500 (
Lwt.join [
(V.listen listen.netif ~header_size one_and_done >|= fun _ -> ());
Mirage_sleep.ns (Duration.of_ms 100) >>= fun () ->
Lwt.async (fun () -> A.query listen.arp first_ip >|= ignore) ;
A.set_ips speak.arp [ first_ip ];
])
>>= fun () ->
(* try a lookup of the IP set by speak.arp, and fail if this causes listen_arp
to block or send an ARP query -- listen_arp should answer immediately from
the cache. An attempt to resolve via query will result in a timeout, since
speak.arp has no listener running and therefore won't answer any arp
who-has requests. *)
timeout ~time:500 (query_or_die listen.arp first_ip (V.mac speak.netif)) (* >>= fun () ->
Time.sleep_ns (Duration.of_sec 5) *)
let input_single_unicast () =
two_arp () >>= fun (listen, speak) ->
(* contrive to make a reply packet for the listener to hear *)
let for_listener =
arp_reply
~from_netif:speak.netif ~to_netif:listen.netif
~from_ip:first_ip ~to_ip:second_ip
in
let listener = start_arp_listener listen () in
timeout ~time:500 (
Lwt.choose [
(V.listen listen.netif ~header_size listener >|= fun _ -> ());
Mirage_sleep.ns (Duration.of_ms 2) >>= fun () ->
E.write speak.ethif (V.mac listen.netif) `ARP ~size for_listener >>= fun _ ->
query_and_no_response listen.arp first_ip
])
let input_resolves_wait () =
two_arp () >>= fun (listen, speak) ->
(* contrive to make a reply packet for the listener to hear *)
let for_listener = arp_reply ~from_netif:speak.netif ~to_netif:listen.netif
~from_ip:first_ip ~to_ip:second_ip in
(* initiate query when the cache is empty. On resolution, fail for a timeout
and test the MAC if resolution was successful, then disconnect the
listening interface to ensure the test terminates.
Fail with a timeout message if the whole thing takes more than 5s. *)
let listener = start_arp_listener listen () in
let query_then_disconnect =
query_or_die listen.arp first_ip (V.mac speak.netif) >>= fun () ->
V.disconnect listen.netif
in
timeout ~time:5000 (
Lwt.join [
(V.listen listen.netif ~header_size listener >|= fun _ -> ());
query_then_disconnect;
Mirage_sleep.ns (Duration.of_ms 1) >>= fun () ->
E.write speak.ethif (V.mac listen.netif) `ARP ~size for_listener >|= function
| Ok x -> x
| Error _ -> failf "ethernet write failed"
]
)
let unreachable_times_out () =
get_arp () >>= fun speak ->
A.query speak.arp first_ip >>= function
| Ok _ -> failf "query claimed success when impossible for %a" Ipaddr.V4.pp first_ip
| Error `Timeout -> Lwt.return_unit
| Error e -> failf "error waiting for a timeout: %a" A.pp_error e
let input_replaces_old () =
three_arp () >>= fun (listen, claimant_1, claimant_2) ->
(* query for IP to accept responses *)
Lwt.async (fun () -> A.query listen.arp first_ip >|= ignore) ;
Lwt.async (fun () ->
Log.debug (fun f -> f "arp listener started");
V.listen listen.netif ~header_size (start_arp_listener listen ()) >|= fun _ -> ());
timeout ~time:2000 (
set_and_check ~listener:listen.arp ~claimant:claimant_1 first_ip >>= fun () ->
set_and_check ~listener:listen.arp ~claimant:claimant_2 first_ip >>= fun () ->
V.disconnect listen.netif
)
let os_linux_bsd () =
let cmd = Bos.Cmd.(v "uname" % "-s") in
match Bos.OS.Cmd.(run_out cmd |> out_string |> success) with
| Ok s when s = "FreeBSD" -> true
| Ok s when s = "Linux" -> true
| Ok _ -> false
| Error _ -> false
let entries_expire () =
(* this test fails on windows and macOS for unknown reasons. please, if you
happen to have your hands on such a machine, investigate the issue. *)
if not (os_linux_bsd ()) then
Lwt.return_unit
else
two_arp () >>= fun (listen, speak) ->
A.set_ips listen.arp [ second_ip ] >>= fun () ->
(* here's what we expect listener to emit once its cache entry has expired *)
let expected_arp_query =
Arp_packet.({operation = Request;
source_mac = V.mac listen.netif;
target_mac = Macaddr.broadcast;
source_ip = second_ip; target_ip = first_ip})
in
(* query for IP to accept responses *)
Lwt.async (fun () -> A.query listen.arp first_ip >|= ignore) ;
Lwt.async (fun () -> V.listen listen.netif ~header_size (start_arp_listener listen ()) >|= fun _ -> ());
let test =
Mirage_sleep.ns (Duration.of_ms 10) >>= fun () ->
set_and_check ~listener:listen.arp ~claimant:speak first_ip >>= fun () ->
(* sleep for 5s to make sure we hit `tick` often enough *)
Mirage_sleep.ns (Duration.of_sec 5) >>= fun () ->
(* asking now should generate a query *)
not_in_cache ~listen:speak.netif expected_arp_query listen.arp first_ip
in
timeout ~time:7000 test
(* RFC isn't strict on how many times to try, so we'll just say any number
greater than 1 is fine *)
let query_retries () =
two_arp () >>= fun (listen, speak) ->
let expected_query = Arp_packet.({source_mac = V.mac speak.netif;
target_mac = Macaddr.broadcast;
source_ip = Ipaddr.V4.any;
target_ip = first_ip;
operation = Request;})
in
let how_many = ref 0 in
let listener buf =
check_ethif_response expected_query buf;
if !how_many = 0 then begin
how_many := !how_many + 1;
Lwt.return_unit
end else V.disconnect listen.netif
in
let ask () =
A.query speak.arp first_ip >>= function
| Error e -> failf "Received error before >1 query: %a" A.pp_error e
| Ok _ -> failf "got result from query for %a, erroneously" Ipaddr.V4.pp first_ip
in
Lwt.pick [
(V.listen listen.netif ~header_size listener >|= fun _ -> ());
Mirage_sleep.ns (Duration.of_ms 2) >>= ask;
Mirage_sleep.ns (Duration.of_sec 6) >>= fun () ->
fail "query didn't succeed or fail within 6s"
]
(* requests for us elicit a reply *)
let requests_are_responded_to () =
let (answerer_ip, inquirer_ip) = (first_ip, second_ip) in
two_arp () >>= fun (inquirer, answerer) ->
(* neither has a listener set up when we set IPs, so no GARPs in the cache *)
A.add_ip answerer.arp answerer_ip >>= fun () ->
A.add_ip inquirer.arp inquirer_ip >>= fun () ->
let request = arp_request ~from_netif:inquirer.netif ~to_mac:Macaddr.broadcast
~from_ip:inquirer_ip ~to_ip:answerer_ip
in
let expected_reply =
Arp_packet.({ operation = Reply;
source_mac = V.mac answerer.netif;
target_mac = V.mac inquirer.netif;
source_ip = answerer_ip; target_ip = inquirer_ip})
in
let listener close_netif buf =
check_ethif_response expected_reply buf;
V.disconnect close_netif
in
let arp_listener =
V.listen answerer.netif ~header_size (start_arp_listener answerer ()) >|= fun _ -> ()
in
timeout ~time:1000 (
Lwt.join [
(* listen for responses and check them against an expected result *)
(V.listen inquirer.netif ~header_size (listener inquirer.netif) >|= fun _ -> ());
(* start the usual ARP listener, which should respond to requests *)
arp_listener;
(* send a request for the ARP listener to respond to *)
Mirage_sleep.ns (Duration.of_ms 100) >>= fun () ->
E.write inquirer.ethif Macaddr.broadcast `ARP ~size request >>= fun _ ->
Mirage_sleep.ns (Duration.of_ms 100) >>= fun () ->
V.disconnect answerer.netif
];
)
let requests_not_us () =
let (answerer_ip, inquirer_ip) = (first_ip, second_ip) in
two_arp () >>= fun (answerer, inquirer) ->
A.add_ip answerer.arp answerer_ip >>= fun () ->
A.add_ip inquirer.arp inquirer_ip >>= fun () ->
let ask ip buf =
let open Arp_packet in
encode_into
{ operation = Request;
source_mac = V.mac inquirer.netif; target_mac = Macaddr.broadcast;
source_ip = inquirer_ip; target_ip = ip }
buf ;
size
in
let requests = List.map ask [ inquirer_ip; Ipaddr.V4.any;
Ipaddr.V4.of_string_exn "255.255.255.255" ] in
let make_requests =
Lwt_list.iter_s (fun b -> E.write inquirer.ethif Macaddr.broadcast `ARP ~size b >|= fun _ -> ())
requests
in
let disconnect_listeners () =
Lwt_list.iter_s (V.disconnect) [answerer.netif; inquirer.netif]
in
Lwt.join [
(V.listen answerer.netif ~header_size (start_arp_listener answerer ()) >|= fun _ -> ());
(V.listen inquirer.netif ~header_size (fail_on_receipt inquirer.netif) >|= fun _ -> ());
make_requests >>= fun _ ->
Mirage_sleep.ns (Duration.of_ms 100) >>=
disconnect_listeners
]
let nonsense_requests () =
let (answerer_ip, inquirer_ip) = (first_ip, second_ip) in
three_arp () >>= fun (answerer, inquirer, checker) ->
A.set_ips answerer.arp [ answerer_ip ] >>= fun () ->
let request number arp =
let open Arp_packet in
encode_into
{ operation = Request;
source_mac = V.mac inquirer.netif;
target_mac = Macaddr.broadcast;
source_ip = inquirer_ip;
target_ip = answerer_ip } arp ;
Cstruct.BE.set_uint16 arp 6 number;
Arp_packet.size
in
let requests = List.map request [0; 3; -1; 255; 256; 257; 65536] in
let make_requests =
Lwt_list.iter_s (fun l -> E.write inquirer.ethif Macaddr.broadcast `ARP ~size l >|= fun _ -> ()) requests in
let expected_probe = Arp_packet.{ operation = Request;
source_mac = V.mac answerer.netif;
source_ip = answerer_ip;
target_mac = Macaddr.broadcast;
target_ip = inquirer_ip; }
in
Lwt.async (fun () -> V.listen answerer.netif ~header_size (start_arp_listener answerer ()) >|= fun _ -> ());
timeout ~time:1000 (
Lwt.join [
(V.listen inquirer.netif ~header_size (fail_on_receipt inquirer.netif) >|= fun _ -> ());
make_requests >>= fun () ->
V.disconnect inquirer.netif >>= fun () ->
(* not sufficient to just check to see whether we've replied; it's equally
possible that we erroneously make a cache entry. Make sure querying
inquirer_ip results in an outgoing request. *)
not_in_cache ~listen:checker.netif expected_probe answerer.arp inquirer_ip
] )
let packet () =
let first_mac = Macaddr.of_string_exn "10:9a:dd:01:23:45" in
let second_mac = Macaddr.of_string_exn "00:16:3e:ab:cd:ef" in
let example_request =
Arp_packet.{ operation = Request;
source_mac = first_mac;
target_mac = second_mac;
source_ip = first_ip;
target_ip = second_ip;
}
in
let marshalled = Arp_packet.encode example_request in
match Arp_packet.decode marshalled with
| Error _ -> Alcotest.fail "couldn't unmarshal something we made ourselves"
| Ok unmarshalled ->
Alcotest.(check packet) "serialize/deserialize" example_request unmarshalled;
Lwt.return_unit
let suite =
[
"conversions neither lose nor gain information", `Quick, packet;
"nonsense requests are ignored", `Quick, nonsense_requests;
"requests are responded to", `Quick, requests_are_responded_to;
"entries expire", `Quick, entries_expire;
"irrelevant requests are ignored", `Quick, requests_not_us;
"set_ip sets ip, sends GARP", `Quick, set_ip_sends_garp;
"add_ip, get_ip and remove_ip as advertised", `Quick, add_get_remove_ips;
"GARPs are heard and not cached", `Quick, input_single_garp;
"unsolicited unicast replies are heard and not cached", `Quick, input_single_unicast;
"solicited unicast replies resolve pending threads", `Quick, input_resolves_wait;
"entries are replaced with new information", `Quick, input_replaces_old;
"unreachable IPs time out", `Quick, unreachable_times_out;
"queries are tried repeatedly before timing out", `Quick, query_retries;
]
let run test () =
Lwt_main.run (test ())
let () =
(* enable logging to stdout for all modules *)
Logs.set_reporter (Logs_fmt.reporter ());
Logs.set_level ~all:true (Some Logs.Debug);
let suite =
[ "arp", List.map (fun (d, s, f) -> d, s, run f) suite ]
in
Alcotest.run "arp" suite

View file

@ -0,0 +1,878 @@
let generate n =
let data = Cstruct.create n in
for i = 0 to pred n do
Cstruct.set_uint8 data i (Random.int 256)
done;
data
let rec gen_ip () =
let buf = generate 4 in
let ip = Ipaddr.V4.of_octets_exn (Cstruct.to_string buf) in
if ip = Ipaddr.V4.any || ip = Ipaddr.V4.broadcast then
gen_ip ()
else
buf, ip
let rec gen_mac () =
let buf = generate 6 in
let mac = Macaddr.of_octets_exn (Cstruct.to_string buf) in
if mac = Macaddr.broadcast then
gen_mac ()
else
buf, mac
let hdr = Cstruct.of_string "\000\001\008\000\006\004"
let gen_int () =
let buf = generate 1 in
(buf, Cstruct.get_uint8 buf 0)
let gen_op () =
let _, op = gen_int () in
let buf = Cstruct.create 2 in
let op = 1 + op mod 2 in
Cstruct.BE.set_uint16 buf 0 op ;
(if op = 1 then Arp_packet.Request else Arp_packet.Reply), buf
let gen_arp () =
let sm, source_mac = gen_mac ()
and si, source_ip = gen_ip ()
and tm, target_mac = gen_mac ()
and ti, target_ip = gen_ip ()
and op, opb = gen_op ()
in
{ Arp_packet.operation = op ; source_mac ; source_ip ; target_mac ; target_ip },
Cstruct.concat [ hdr ; opb ; sm ; si ; tm ; ti ]
let p =
let module M = struct
type t = Arp_packet.t
let pp = Arp_packet.pp
let equal s t =
let open Arp_packet in
s.operation = t.operation &&
Macaddr.compare s.source_mac t.source_mac = 0 &&
Macaddr.compare s.target_mac t.target_mac = 0 &&
Ipaddr.V4.compare s.source_ip t.source_ip = 0 &&
Ipaddr.V4.compare s.target_ip t.target_ip = 0
end in
(module M : Alcotest.TESTABLE with type t = M.t)
module Coding = struct
let gen_op_arp () =
let rec gen_op () =
let buf = generate 2 in
match Cstruct.BE.get_uint16 buf 0 with
| 1 | 2 -> gen_op ()
| x -> (x, buf)
in
let data = generate 20
and o, opb = gen_op ()
in
o, Cstruct.concat [ hdr ; opb ; data ]
let rec gen_unhandled_arp () =
(* some consistency -- hlen and plen *)
let htype = generate 2
and ptype = generate 2
in
(* if we don't have at least length m, we'll end up in Too_short *)
let rec i_min m () =
let buf, len = gen_int () in
if len < m then i_min m ()
else buf, len
in
let hl, hlen = i_min 6 ()
and pl, plen = i_min 4 ()
in
let my_hdr = Cstruct.concat [ htype ; ptype ; hl ; pl ] in
if Cstruct.equal my_hdr hdr then
gen_unhandled_arp ()
else
let rec gen_op () =
let buf = generate 2 in
match Cstruct.BE.get_uint16 buf 0 with
| 1 | 2 -> gen_op ()
| _ -> buf
in
let op = gen_op ()
and sha = generate hlen
and tha = generate hlen
and spa = generate plen
and tpa = generate plen
in
Cstruct.concat [ my_hdr ; op ; sha ; spa ; tha ; tpa ]
let gen_short_arp () =
let _, l = gen_int () in
generate (l mod 28)
let e =
let module M = struct
type t = Arp_packet.error
let pp = Arp_packet.pp_error
let equal a b =
let open Arp_packet in
match a, b with
| Too_short, Too_short -> true
| Unusable, Unusable -> true
| Unknown_operation x, Unknown_operation y -> x = y
| _ -> false
end in
(module M : Alcotest.TESTABLE with type t = M.t)
let repeat f n () =
for _i = 0 to n do
f ()
done
let check_r s res buf =
Alcotest.(check (result p e) s res (Arp_packet.decode buf))
let dec_valid_arp () =
let pkt, buf = gen_arp () in
check_r "decoding valid ARP frames" (Ok pkt) buf
let dec_unhandled_arp () =
let buf = gen_unhandled_arp () in
check_r "invalid header is error" (Error Arp_packet.Unusable) buf
let dec_short_arp () =
let buf = gen_short_arp () in
check_r "short is error" (Error Arp_packet.Too_short) buf
let dec_op_arp () =
let o, buf = gen_op_arp () in
check_r "invalid op is error" (Error (Arp_packet.Unknown_operation o)) buf
let dec_enc () =
let pkt, buf = gen_arp () in
let cbuf = Arp_packet.encode pkt in
Alcotest.(check bool "encoding produces same buffer" true (Cstruct.equal buf cbuf)) ;
match Arp_packet.decode buf with
| Error _ -> Alcotest.fail "decoding failed, should not happen"
| Ok pack ->
Alcotest.(check p "decoding worked" pkt pack) ;
let cbuf = Arp_packet.encode pack in
Alcotest.(check bool "encoding produces same buffer" true (Cstruct.equal buf cbuf))
let enc_into () =
let pkt, buf = gen_arp () in
let cbuf = Cstruct.create 28 in
Arp_packet.encode_into pkt cbuf ;
Alcotest.(check bool "encode_into works" true (Cstruct.equal cbuf buf))
let enc_fail () =
for i = 0 to 27 do
let buf = Cstruct.create i
and pkg, _ = gen_arp ()
in
Alcotest.check_raises "buffer is too small" (Invalid_argument "too small")
(fun () ->
try Arp_packet.encode_into pkg buf with Invalid_argument _ -> invalid_arg "too small")
done
let coder_tsts = [
"valid arp decoding", `Quick, (repeat dec_valid_arp 1000) ;
"unhandled arp decoding", `Quick, (repeat dec_unhandled_arp 1000) ;
"short arp decoding", `Quick, (repeat dec_short_arp 1000) ;
"invalid operation decoding", `Quick, (repeat dec_op_arp 1000) ;
"decoding is inverse of encoding", `Quick, (repeat dec_enc 1000) ;
"encode_into works", `Quick, (repeat enc_into 1000) ;
"encode_into fails with small bufs", `Quick, enc_fail ;
]
end
module Handling = struct
let garp_of ip mac =
let mac0 = Macaddr.of_octets_exn (String.make 6 '\000') in
{ Arp_packet.operation = Arp_packet.Request ;
source_ip = ip ; target_ip = ip ;
source_mac = mac ; target_mac = mac0 }
let gen_ip () = snd (gen_ip ())
and gen_mac () = snd (gen_mac ())
let m =
let module M = struct
type t = Macaddr.t
let pp = Macaddr.pp
let equal a b = Macaddr.compare a b = 0
end in
(module M : Alcotest.TESTABLE with type t = M.t)
let i =
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 create_raises () =
let mac = gen_mac () in
Alcotest.check_raises "timeout <= 0" (Invalid_argument "timeout must be strictly positive")
(fun () -> ignore(Arp_handler.create ~timeout:0 mac)) ;
Alcotest.check_raises "retries < 0" (Invalid_argument "retries must be positive")
(fun () -> ignore(Arp_handler.create ~retries:(-1) mac))
let basic_good () =
let mac = gen_mac ()
and ipaddr = gen_ip ()
in
let t, garp = Arp_handler.create ~ipaddr mac in
let garp = match garp with
| None -> Alcotest.fail "expected some garp"
| Some garp -> garp
in
Alcotest.(check bool "create has good GARP" true
(Cstruct.equal (Arp_packet.encode (garp_of ipaddr mac))
(Arp_packet.encode (fst garp)))) ;
Alcotest.(check (list i) "ip is sensible" [ipaddr] (Arp_handler.ips t)) ;
Alcotest.(check (option m) "own entry is in cache"
(Some mac) (Arp_handler.in_cache t ipaddr)) ;
Alcotest.(check (option m) "any is not in cache" None
(Arp_handler.in_cache t Ipaddr.V4.any)) ;
Alcotest.(check (option m) "broadcast is not in cache" None
(Arp_handler.in_cache t Ipaddr.V4.broadcast))
let remove_good () =
let mac = gen_mac ()
and ipaddr = gen_ip ()
in
let t, _garp = Arp_handler.create ~ipaddr mac in
Alcotest.(check (list i) "ip is sensible" [ipaddr] (Arp_handler.ips t)) ;
Alcotest.(check (option m) "own entry is in cache"
(Some mac) (Arp_handler.in_cache t ipaddr)) ;
let t = Arp_handler.remove t ipaddr in
Alcotest.(check (option m) "own entry is no longer in cache" None
(Arp_handler.in_cache t ipaddr))
let remove_no () =
let mac = gen_mac ()
and ipaddr = gen_ip ()
in
let t, _garp = Arp_handler.create ~ipaddr mac in
Alcotest.(check (list i) "ip is sensible" [ipaddr] (Arp_handler.ips t)) ;
Alcotest.(check (option m) "own entry is in cache"
(Some mac) (Arp_handler.in_cache t ipaddr)) ;
let t = Arp_handler.remove t Ipaddr.V4.any in
Alcotest.(check (option m) "own entry is still in cache" (Some mac)
(Arp_handler.in_cache t ipaddr))
let alias_good () =
let mac = gen_mac ()
and ipaddr = gen_ip ()
in
let t, _garp = Arp_handler.create ~ipaddr mac in
Alcotest.(check (list i) "ip is sensible" [ipaddr] (Arp_handler.ips t)) ;
Alcotest.(check (option m) "own entry is in cache"
(Some mac) (Arp_handler.in_cache t ipaddr)) ;
let t, _, _ = Arp_handler.alias t ipaddr in
Alcotest.(check (option m) "own entry is still in cache" (Some mac)
(Arp_handler.in_cache t ipaddr)) ;
let ip' = gen_ip () in
let t, _, _ = Arp_handler.alias t ip' in
Alcotest.(check (option m) "own entry is still in cache" (Some mac)
(Arp_handler.in_cache t ipaddr)) ;
Alcotest.(check (option m) "aliased entry is in cache" (Some mac)
(Arp_handler.in_cache t ip'))
let alias_remove_inverse () =
let mac = gen_mac ()
and ipaddr = gen_ip ()
in
let t, _garp = Arp_handler.create ~ipaddr mac in
let ip' = gen_ip () in
let t, _, _ = Arp_handler.alias t ip' in
Alcotest.(check (option m) "own entry is in cache" (Some mac)
(Arp_handler.in_cache t ipaddr)) ;
Alcotest.(check (option m) "aliased entry is in cache" (Some mac)
(Arp_handler.in_cache t ip')) ;
let t = Arp_handler.remove t ip' in
Alcotest.(check (option m) "aliased entry is no longer in cache" None
(Arp_handler.in_cache t ip'))
let static_good () =
let mac = gen_mac ()
and ipaddr = gen_ip ()
in
let t, _garp = Arp_handler.create ~ipaddr mac in
let ip' = gen_ip () in
let mac' = gen_mac () in
let t, _ = Arp_handler.static t ip' mac' in
Alcotest.(check (option m) "own entry is in cache" (Some mac)
(Arp_handler.in_cache t ipaddr)) ;
Alcotest.(check (option m) "static entry is in cache" (Some mac')
(Arp_handler.in_cache t ip')) ;
let t = Arp_handler.remove t ip' in
Alcotest.(check (option m) "static entry is no longer in cache" None
(Arp_handler.in_cache t ip'))
let static_alias_good () =
let mac = gen_mac ()
and ipaddr = gen_ip ()
in
let t, _garp = Arp_handler.create ~ipaddr mac in
let ip' = gen_ip () in
let mac' = gen_mac () in
let t, _ = Arp_handler.static t ip' mac' in
Alcotest.(check (option m) "own entry is in cache" (Some mac)
(Arp_handler.in_cache t ipaddr)) ;
Alcotest.(check (option m) "static entry is in cache" (Some mac')
(Arp_handler.in_cache t ip')) ;
let t, _, _ = Arp_handler.alias t ip' in
Alcotest.(check (option m) "alias entry overwrote static one" (Some mac)
(Arp_handler.in_cache t ip')) ;
let t, _ = Arp_handler.static t ip' mac' in
Alcotest.(check (option m) "static entry overwrite aliased one" (Some mac')
(Arp_handler.in_cache t ip')) ;
let t = Arp_handler.remove t ip' in
Alcotest.(check (option m) "static entry is no longer in cache" None
(Arp_handler.in_cache t ip'))
let more_good () =
let mac = gen_mac ()
and ipaddr = gen_ip ()
in
let t, _garp = Arp_handler.create ~ipaddr mac in
let rec more_entries acc t = function
| 0 -> acc, t
| n ->
let ip' = gen_ip () in
if List.mem ip' (List.map fst acc) then
more_entries acc t n
else
let t, e =
if n mod 2 = 0 then
let mac' = gen_mac () in
let t, _ = Arp_handler.static t ip' mac' in
(t, (ip', mac'))
else
let t, _, _ = Arp_handler.alias t ip' in
(t, (ip', mac))
in
more_entries (e::acc) t (pred n)
in
let acc, t = more_entries [(ipaddr,mac)] t 100 in
List.iter (fun (ip, mac) ->
Alcotest.(check (option m) "entry is in cache" (Some mac)
(Arp_handler.in_cache t ip)))
acc ;
List.iter (fun (ip, _) ->
let t = Arp_handler.remove t ip in
Alcotest.(check (option m) "entry is no longer in cache" None
(Arp_handler.in_cache t ip)))
acc ;
let t = List.fold_left (fun t (ip, _) -> Arp_handler.remove t ip) t acc in
Alcotest.(check (option m) "own entry is no longer in cache" None
(Arp_handler.in_cache t ipaddr))
let packet =
let module M = struct
type t = Arp_packet.t
let pp = Arp_packet.pp
let equal = Arp_packet.equal
end in
(module M : Alcotest.TESTABLE with type t = M.t)
let out =
let module M = struct
type t = Arp_packet.t * Macaddr.t
let pp ppf (cs, mac) =
Format.fprintf ppf "out: %a to %a" Arp_packet.pp cs Macaddr.pp mac
let equal (acs, amac) (bcs, bmac) =
Arp_packet.equal acs bcs && Macaddr.compare amac bmac = 0
end in
(module M : Alcotest.TESTABLE with type t = M.t)
let qres =
let module M = struct
type t = int list Arp_handler.qres
let pp ppf = function
| Arp_handler.Mac mac -> Format.fprintf ppf "ok %a" Macaddr.pp mac
| Arp_handler.RequestWait ((cs, mac), xs) ->
Format.fprintf ppf "requestwait %a to %a, wait %s"
Arp_packet.pp cs Macaddr.pp mac
(String.concat ", " (List.map string_of_int xs))
| Arp_handler.Wait xs ->
Format.fprintf ppf "wait %s"
(String.concat ", " (List.map string_of_int xs))
let equal a b = match a, b with
| Arp_handler.Mac a, Arp_handler.Mac b -> Macaddr.compare a b = 0
| Arp_handler.RequestWait ((csa, maca), xsa),
Arp_handler.RequestWait ((csb, macb), xsb) ->
Arp_packet.equal csa csb && Macaddr.compare maca macb = 0 &&
List.length xsa = List.length xsb &&
List.for_all (fun x -> List.mem x xsb) xsa
| Arp_handler.Wait xsa, Arp_handler.Wait xsb ->
List.length xsa = List.length xsb &&
List.for_all (fun x -> List.mem x xsb) xsa
| _ -> false
end in
(module M : Alcotest.TESTABLE with type t = M.t)
let merge v = function
| None -> [v]
| Some xs -> v::xs
let handle_good () =
let mac = gen_mac ()
and ipaddr = gen_ip ()
in
let t, _garp = Arp_handler.create ~ipaddr mac in
let _t, res = Arp_handler.query t ipaddr (merge 1) in
Alcotest.check qres "own IP can be queried" (Arp_handler.Mac mac) res
let query source_mac source_ip target_ip =
{ Arp_packet.operation = Arp_packet.Request ;
source_mac ; source_ip ;
target_mac = Macaddr.broadcast ; target_ip },
Macaddr.broadcast
let handle_gen_request () =
let mac = gen_mac ()
and ipaddr = gen_ip ()
in
let t, _garp = Arp_handler.create ~retries:1 ~ipaddr mac in
let other = gen_ip () in
let _, res = Arp_handler.query t other (merge 1) in
let out = query mac ipaddr other in
Alcotest.check qres "res is requestwait" (Arp_handler.RequestWait (out, [1])) res
let handle_gen_request_twice () =
let mac = gen_mac ()
and ipaddr = gen_ip ()
in
let t, _garp = Arp_handler.create ~ipaddr ~retries:1 mac in
let other = gen_ip () in
let t, res = Arp_handler.query t other (merge 1) in
let out = query mac ipaddr other in
Alcotest.check qres "res is requestwait" (Arp_handler.RequestWait (out, [1])) res ;
let _, res = Arp_handler.query t other (merge 2) in
Alcotest.check qres "res is wait" (Arp_handler.Wait [2;1]) res
let alias_wakes () =
let mac = gen_mac ()
and ipaddr = gen_ip ()
in
let t, _garp = Arp_handler.create ~ipaddr mac in
let other = gen_ip () in
let t, res = Arp_handler.query t other (merge 1) in
let out = query mac ipaddr other in
Alcotest.check qres "res is requestwait!" (Arp_handler.RequestWait (out, [1])) res ;
Alcotest.(check (option m) "query is not cache" None (Arp_handler.in_cache t other)) ;
let _, _, a = Arp_handler.alias t other in
Alcotest.(check (option (list int)) "alias wakes up" (Some [1]) a)
let static_wakes () =
let mac = gen_mac ()
and ipaddr = gen_ip ()
in
let t, _garp = Arp_handler.create ~ipaddr mac in
let other = gen_ip () in
let t, res = Arp_handler.query t other (merge 1) in
let out = query mac ipaddr other in
Alcotest.check qres "res is requestwait" (Arp_handler.RequestWait (out, [1])) res ;
let _, a = Arp_handler.static t other mac in
Alcotest.(check (option (list int)) "alias wakes up" (Some [1]) a)
let handle_timeout () =
let mac = gen_mac ()
and ipaddr = gen_ip ()
in
let t, _garp = Arp_handler.create ~retries:1 ~ipaddr mac in
let other = gen_ip () in
let t, _ = Arp_handler.query t other (merge 1) in
let t, _, a = Arp_handler.tick t in
Alcotest.(check (list (list int)) "tick didn't timeout" [] a) ;
let _, _, a = Arp_handler.tick t in
Alcotest.(check (list (list int)) "tick timed out" [[1]] a)
let req_before_timeout () =
let mac = gen_mac ()
and ipaddr = gen_ip ()
in
let t, _garp = Arp_handler.create ~timeout:1 ~ipaddr mac in
let other = gen_ip () in
let t, _ = Arp_handler.query t other (merge 1) in
let omac = gen_mac () in
let pkt =
Arp_packet.encode { Arp_packet.operation = Arp_packet.Reply ;
source_ip = other ; source_mac = omac ;
target_ip = ipaddr ; target_mac = mac }
in
let t, outp, wake = Arp_handler.input t pkt in
Alcotest.(check (option out) "out is none" None outp) ;
Alcotest.(check (option (pair m (list int))) "wake is correct"
(Some (omac, [1])) wake) ;
let _, outp, rs = Arp_handler.tick t in
Alcotest.(check bool "timeouts are empty" true (rs = [])) ;
Alcotest.(check (list out) "arp request is sent" [query mac ipaddr other] outp)
let multiple_reqs () =
let mac = gen_mac ()
and ipaddr = gen_ip ()
in
let t, _garp = Arp_handler.create ~retries:1 ~ipaddr mac in
let other = gen_ip () in
let t, res = Arp_handler.query t other (merge 1) in
let q = query mac ipaddr other in
Alcotest.check qres "query generates ARP request" (Arp_handler.RequestWait (q, [1])) res ;
let t, outs, touts = Arp_handler.tick t in
Alcotest.(check (list out) "tick generates second ARP request" [q] outs) ;
Alcotest.(check (list (list int)) "tick generated no timeout yet" [] touts) ;
let _, outs, touts = Arp_handler.tick t in
Alcotest.(check (list out) "tick generated no other request" [] outs) ;
Alcotest.(check (list (list int)) "tick generated a timeout" [[1]] touts)
let multiple_reqs_2 () =
let mac = gen_mac ()
and ipaddr = gen_ip ()
in
let t, _garp = Arp_handler.create ~retries:4 ~ipaddr mac in
let other = gen_ip () in
let t, res = Arp_handler.query t other (merge 1) in
let q = query mac ipaddr other in
Alcotest.check qres "query generates ARP request" (Arp_handler.RequestWait (q, [1])) res ;
let t, outs, touts = Arp_handler.tick t in
Alcotest.(check (list out) "tick generates second ARP request" [q] outs) ;
Alcotest.(check (list (list int)) "tick generated no timeout yet" [] touts) ;
let t, outs, touts = Arp_handler.tick t in
Alcotest.(check (list out) "tick generates third ARP request" [q] outs) ;
Alcotest.(check (list (list int)) "tick generated no timeout yet" [] touts) ;
let t, outs, touts = Arp_handler.tick t in
Alcotest.(check (list out) "tick generates fourth ARP request" [q] outs) ;
Alcotest.(check (list (list int)) "tick generated no timeout yet" [] touts) ;
let t, outs, touts = Arp_handler.tick t in
Alcotest.(check (list out) "tick generates fifth ARP request" [q] outs) ;
Alcotest.(check (list (list int)) "tick generated no timeout yet" [] touts) ;
let _, outs, touts = Arp_handler.tick t in
Alcotest.(check (list out) "tick generated no other request" [] outs) ;
Alcotest.(check (list (list int)) "tick generated a timeout" [[1]] touts)
let handle_reply () =
let mac = gen_mac ()
and ipaddr = gen_ip ()
in
let t, _garp = Arp_handler.create ~timeout:1 ~ipaddr mac in
let other = gen_ip () in
let omac = gen_mac () in
let pkt =
Arp_packet.encode { Arp_packet.operation = Arp_packet.Reply ;
source_ip = other ; source_mac = omac ;
target_ip = ipaddr ; target_mac = mac }
in
let t, outp, w = Arp_handler.input t pkt in
Alcotest.(check (option out) "nothing to be sent" None outp) ;
Alcotest.(check (option (pair m (list int))) "noone wakes up" None w) ;
Alcotest.(check (option m) "received entry is not in cache" None
(Arp_handler.in_cache t other))
let handle_garp () =
let mac = gen_mac ()
and ipaddr = gen_ip ()
in
let t, _garp = Arp_handler.create ~timeout:1 ~ipaddr mac in
let other = gen_ip () in
let omac = gen_mac () in
let pkt = Arp_packet.encode (garp_of other omac) in
let t, outp, w = Arp_handler.input t pkt in
Alcotest.(check (option out) "nothing out" None outp) ;
Alcotest.(check (option (pair m (list int))) "nothin woken up" None w) ;
Alcotest.(check (option m) "received garp entry is not in cache" None
(Arp_handler.in_cache t other))
let answer_req_broadcast () =
let mac = gen_mac ()
and ipaddr = gen_ip ()
in
let t, _garp = Arp_handler.create ~timeout:1 ~ipaddr mac in
let other = gen_ip () in
let omac = gen_mac () in
let pkt, _ = query omac other ipaddr in
let _, outp, w = Arp_handler.input t (Arp_packet.encode pkt) in
Alcotest.(check (option (pair m (list int))) "nothin woken up" None w) ;
Alcotest.(check (option out) "request to us provokes a reply"
(Some ({ Arp_packet.operation = Arp_packet.Reply ;
source_mac = mac ; source_ip = ipaddr ;
target_mac = omac ; target_ip = other },
omac)) outp)
let answer_req_unicast () =
let mac = gen_mac ()
and ipaddr = gen_ip ()
in
let t, _garp = Arp_handler.create ~timeout:1 ~ipaddr mac in
let other = gen_ip () in
let omac = gen_mac () in
let pkt =
Arp_packet.encode { Arp_packet.operation = Arp_packet.Request ;
source_ip = other ; source_mac = omac ;
target_ip = ipaddr ; target_mac = mac }
in
let _, outp, w = Arp_handler.input t pkt in
Alcotest.(check (option (pair m (list int))) "nothin woken up" None w) ;
Alcotest.(check (option out) "request to us provokes a reply"
(Some ({ Arp_packet.operation = Arp_packet.Reply ;
source_mac = mac ; source_ip = ipaddr ;
target_mac = omac ; target_ip = other },
omac)) outp)
let not_answer_req () =
let mac = gen_mac ()
and ipaddr = gen_ip ()
in
let t, _garp = Arp_handler.create ~timeout:1 ~ipaddr mac in
let other = gen_ip () in
let third = gen_ip () in
let omac = gen_mac () in
let pkt, _ = query omac other third in
let _, outp, w = Arp_handler.input t (Arp_packet.encode pkt) in
Alcotest.(check (option out) "nothing out" None outp) ;
Alcotest.(check (option (pair m (list int))) "nothin woken up" None w)
let ignoring_random () =
let mac = gen_mac ()
and ipaddr = gen_ip ()
in
let t, _garp = Arp_handler.create ~timeout:1 ~ipaddr mac in
let pkt = generate 24 in
let _, outp, w = Arp_handler.input t pkt in
Alcotest.(check (option out) "nothing out" None outp) ;
Alcotest.(check (option (pair m (list int))) "nothin woken up" None w)
let reply_does_not_override () =
let mac = gen_mac ()
and ipaddr = gen_ip ()
in
let t, _garp = Arp_handler.create ~timeout:1 ~ipaddr mac in
let omac = gen_mac () in
let pkt =
Arp_packet.encode { Arp_packet.operation = Arp_packet.Reply ;
source_ip = ipaddr ; source_mac = omac ;
target_ip = ipaddr ; target_mac = mac }
in
let t, outp, w = Arp_handler.input t pkt in
Alcotest.(check (option out) "nothing out" None outp) ;
Alcotest.(check (option (pair m (list int))) "nothin woken up" None w) ;
Alcotest.(check (option m) "our entry is still in cache" (Some mac)
(Arp_handler.in_cache t ipaddr))
let reply_query () =
let mac = gen_mac ()
and ipaddr = gen_ip ()
in
let t, _garp = Arp_handler.create ~timeout:1 ~ipaddr mac in
let other = gen_ip () in
let omac = gen_mac () in
let pkt =
Arp_packet.encode { Arp_packet.operation = Arp_packet.Reply ;
source_ip = other ; source_mac = omac ;
target_ip = ipaddr ; target_mac = mac }
in
let q = query mac ipaddr other in
let t, r = Arp_handler.query t other (merge 1) in
Alcotest.check qres "r is request wait" (Arp_handler.RequestWait (q, [1])) r ;
let t, outp, w = Arp_handler.input t pkt in
Alcotest.(check (option out) "nothing out" None outp) ;
Alcotest.(check (option (pair m (list int))) "something woken up" (Some (omac, [1])) w) ;
let _t, res = Arp_handler.query t other (merge 2) in
Alcotest.check qres "dynamic entry can be queried" (Arp_handler.Mac omac) res
let reply_in_cache () =
let mac = gen_mac ()
and ipaddr = gen_ip ()
in
let t, _garp = Arp_handler.create ~timeout:1 ~ipaddr mac in
let other = gen_ip () in
let omac = gen_mac () in
let pkt =
Arp_packet.encode { Arp_packet.operation = Arp_packet.Reply ;
source_ip = other ; source_mac = omac ;
target_ip = ipaddr ; target_mac = mac }
in
let q = query mac ipaddr other in
let t, r = Arp_handler.query t other (merge 1) in
Alcotest.check qres "r is request wait" (Arp_handler.RequestWait (q, [1])) r ;
let t, outp, w = Arp_handler.input t pkt in
Alcotest.(check (option out) "nothing out" None outp) ;
Alcotest.(check (option (pair m (list int))) "something woken up" (Some (omac, [1])) w) ;
Alcotest.(check (option m) "entry in cache" (Some omac) (Arp_handler.in_cache t other)) ;
Alcotest.(check (list i) "ips do not include dynamic entries" [ipaddr] (Arp_handler.ips t))
let reply_overriden () =
let mac = gen_mac ()
and ipaddr = gen_ip ()
in
let t, _garp = Arp_handler.create ~timeout:1 ~ipaddr mac in
let other = gen_ip () in
let omac = gen_mac () in
let pkt =
Arp_packet.encode { Arp_packet.operation = Arp_packet.Reply ;
source_ip = other ; source_mac = omac ;
target_ip = ipaddr ; target_mac = mac }
in
let q = query mac ipaddr other in
let t, r = Arp_handler.query t other (merge 1) in
Alcotest.check qres "r is request wait" (Arp_handler.RequestWait (q, [1])) r ;
let t, outp, w = Arp_handler.input t pkt in
Alcotest.(check (option out) "nothing out" None outp) ;
Alcotest.(check (option (pair m (list int))) "something woken up" (Some (omac, [1])) w) ;
Alcotest.(check (option m) "entry in cache" (Some omac) (Arp_handler.in_cache t other)) ;
let t, outp, w = Arp_handler.input t pkt in
Alcotest.(check (option out) "nothing out" None outp) ;
Alcotest.(check (option (pair m (list int))) "nothing woken up" None w) ;
Alcotest.(check (option m) "entry in cache" (Some omac) (Arp_handler.in_cache t other))
let reply_overriden_other () =
let mac = gen_mac ()
and ipaddr = gen_ip ()
in
let t, _garp = Arp_handler.create ~timeout:1 ~ipaddr mac in
let other = gen_ip () in
let omac = gen_mac () in
let pkt =
Arp_packet.encode { Arp_packet.operation = Arp_packet.Reply ;
source_ip = other ; source_mac = omac ;
target_ip = ipaddr ; target_mac = mac }
in
let q = query mac ipaddr other in
let t, r = Arp_handler.query t other (merge 1) in
Alcotest.check qres "r is request wait" (Arp_handler.RequestWait (q, [1])) r ;
let t, outp, w = Arp_handler.input t pkt in
Alcotest.(check (option out) "nothing out" None outp) ;
Alcotest.(check (option (pair m (list int))) "something woken up" (Some (omac, [1])) w) ;
Alcotest.(check (option m) "entry in cache" (Some omac) (Arp_handler.in_cache t other)) ;
let omac = gen_mac () in
let pkt =
Arp_packet.encode { Arp_packet.operation = Arp_packet.Reply ;
source_ip = other ; source_mac = omac ;
target_ip = ipaddr ; target_mac = mac }
in
let t, outp, w = Arp_handler.input t pkt in
Alcotest.(check (option out) "nothing out" None outp) ;
Alcotest.(check (option (pair m (list int))) "nothing woken up" None w) ;
Alcotest.(check (option m) "overriden entry in cache" (Some omac)
(Arp_handler.in_cache t other))
let reply_times_out () =
let mac = gen_mac ()
and ipaddr = gen_ip ()
in
let t, _garp = Arp_handler.create ~timeout:1 ~ipaddr mac in
let other = gen_ip () in
let omac = gen_mac () in
let pkt =
Arp_packet.encode { Arp_packet.operation = Arp_packet.Reply ;
source_ip = other ; source_mac = omac ;
target_ip = ipaddr ; target_mac = mac }
in
let q = query mac ipaddr other in
let t, r = Arp_handler.query t other (merge 1) in
Alcotest.check qres "r is request wait" (Arp_handler.RequestWait (q, [1])) r ;
let t, outp, w = Arp_handler.input t pkt in
Alcotest.(check (option out) "nothing out" None outp) ;
Alcotest.(check (option (pair m (list int))) "something woken up" (Some (omac, [1])) w) ;
Alcotest.(check (option m) "entry in cache" (Some omac) (Arp_handler.in_cache t other)) ;
let t, outp, timeout = Arp_handler.tick t in
Alcotest.(check (list out) "request sent" [q] outp) ;
Alcotest.(check (list (list int)) "nothing timed out" [] timeout) ;
let t, outp, timeout = Arp_handler.tick t in
Alcotest.(check (list out) "nada sent" [] outp) ;
Alcotest.(check (list (list int)) "nothing timed out" [] timeout) ;
Alcotest.(check (option m) "entry no longer in cache" None
(Arp_handler.in_cache t other))
let dyn_not_advertised () =
let mac = gen_mac ()
and ipaddr = gen_ip ()
in
let t, _garp = Arp_handler.create ~timeout:1 ~ipaddr mac in
let other = gen_ip () in
let omac = gen_mac () in
let pkt =
Arp_packet.encode { Arp_packet.operation = Arp_packet.Reply ;
source_ip = other ; source_mac = omac ;
target_ip = ipaddr ; target_mac = mac }
in
let q = query mac ipaddr other in
let t, r = Arp_handler.query t other (merge 1) in
Alcotest.check qres "r is request wait" (Arp_handler.RequestWait (q, [1])) r ;
let t, outp, w = Arp_handler.input t pkt in
Alcotest.(check (option out) "nothing out" None outp) ;
Alcotest.(check (option (pair m (list int))) "something woken up" (Some (omac, [1])) w) ;
let third = gen_ip ()
and third_mac = gen_mac ()
in
let q, _ = query third_mac third other in
let _, outp, w = Arp_handler.input t (Arp_packet.encode q) in
Alcotest.(check (option out) "request a dynamic entry is not answered" None outp) ;
Alcotest.(check (option (pair m (list int))) "nothing woken up" None w)
let handle_reply_wakesup () =
let mac = gen_mac ()
and ipaddr = gen_ip ()
in
let t, _garp = Arp_handler.create ~timeout:1 ~ipaddr mac in
let other = gen_ip () in
let omac = gen_mac () in
let pkt =
Arp_packet.encode { Arp_packet.operation = Arp_packet.Reply ;
source_ip = other ; source_mac = omac ;
target_ip = ipaddr ; target_mac = mac }
in
let q = query mac ipaddr other in
let t, r = Arp_handler.query t other (merge 1) in
Alcotest.check qres "r is request wait" (Arp_handler.RequestWait (q, [1])) r ;
let t, r = Arp_handler.query t other (merge 2) in
Alcotest.check qres "r is wait" (Arp_handler.Wait [2;1]) r ;
let _, outp, w = Arp_handler.input t pkt in
Alcotest.(check (option out) "nothing out" None outp) ;
Alcotest.(check (option (pair m (list int))) "something woken up" (Some (omac, [2;1])) w)
let handl_tsts = [
"create raises", `Quick, create_raises ;
"basic tests", `Quick, basic_good ;
"remove test", `Quick, remove_good ;
"remove no test", `Quick, remove_no ;
"alias test", `Quick, alias_good ;
"alias remove test", `Quick, alias_remove_inverse ;
"static test", `Quick, static_good ;
"static alias test", `Quick, static_alias_good ;
"more tests", `Quick, more_good ;
"handle good", `Quick, handle_good ;
"handle generates req", `Quick, handle_gen_request ;
"handle generates req, next doesn't", `Quick, handle_gen_request_twice ;
"alias wakes", `Quick, alias_wakes ;
"static wakes", `Quick, static_wakes ;
"handle timeout", `Quick, handle_timeout ;
"request send before timeout", `Quick, req_before_timeout ;
"multiple requests are send", `Quick, multiple_reqs ;
"multiple requests are send 2", `Quick, multiple_reqs_2 ;
"handle reply", `Quick, handle_reply ;
"handle garp", `Quick, handle_garp ;
"answers broadcast request", `Quick, answer_req_broadcast ;
"answers unicast request", `Quick, answer_req_unicast ;
"not answering random request", `Quick, not_answer_req ;
"ignoring random", `Quick, ignoring_random ;
"reply does not harm static entries", `Quick, reply_does_not_override ;
"reply is in cache", `Quick, reply_in_cache ;
"dynamic entry can be queried", `Quick, reply_query ;
"reply times out", `Quick, reply_times_out ;
"dynamic entry overriden by same", `Quick, reply_overriden ;
"dynamic entry overriden by other", `Quick, reply_overriden_other ;
"dynamic entry is not advertised", `Quick, dyn_not_advertised ;
"reply wakes tasks", `Quick, handle_reply_wakesup ;
]
end
let tests = [
"Coder", Coding.coder_tsts ;
"Handler", Handling.handl_tsts ;
]
let () =
Random.self_init ();
Alcotest.run "ARP tests" tests