Skip to content

improve ARP cache logic #33

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
ansiwen wants to merge 2 commits into
base: main
Choose a base branch
from
Open

improve ARP cache logic #33

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
f547caf
stabilize entries_expire in mirage tests
ansiwen Nov 5, 2025
21c6f07
improve ARP cache logic
ansiwen Oct 12, 2025
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
100 changes: 75 additions & 25 deletions src/arp_handler.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,8 +1,10 @@

type 'a entry =
| Static of Macaddr.t * bool
| Dynamic of Macaddr.t * int
| Pending of 'a * int
| Dynamic of Macaddr.t * int (* active dynamic entry *)
| Pending of 'a * int (* unresolved pending entry *)
| Stale of Macaddr.t * int (* stale dynamic entry *)
| Probing of Macaddr.t * int (* probing stale entry *)

module M = struct
module M = Map.Make(Ipaddr.V4)
Expand Down Expand Up @@ -57,9 +59,10 @@ type 'a t = {
cache : 'a M.t;
mac : Macaddr.t ;
ip : Ipaddr.V4.t ;
timeout : int ;
retries : int ;
epoch : int ;
timeout : int ; (* Stale entry expire interval in ticks *)
refresh : int ; (* Dynamic entry becomes stale interval in ticks *)
retries : int ; (* how many retries for ARP requests/probes *)
epoch : int ; (* current tick value *)
logsrc : Logs.src
}

Expand All @@ -82,6 +85,12 @@ let[@coverage off] pp_entry now k pp =
| Pending (_, retries) ->
Format.fprintf pp "%a (incomplete, %d retries left)"
Ipaddr.V4.pp k (retries - now)
| Stale (m, t) ->
Format.fprintf pp "%a at %a (stale, timeout in %d)" Ipaddr.V4.pp k
Macaddr.pp m (t - now)
| Probing (m, t) ->
Format.fprintf pp "%a at %a (probing, timeout in %d)" Ipaddr.V4.pp k
Macaddr.pp m (t - now)

let[@coverage off] pp pp t =
Format.fprintf pp "mac %a ip %a entries %d timeout %d retries %d@."
Expand Down Expand Up @@ -113,7 +122,7 @@ let alias t ip =
Ipaddr.V4.pp ip Macaddr.pp t.mac) ;
{ t with cache }, (garp, Macaddr.broadcast), pending t ip

let create ?(cache_size=1024) ?(timeout = 800) ?(retries = 5)
let create ?(cache_size=1024) ?(timeout = 800) ?(refresh = 40) ?(retries = 2)
?(logsrc = Logs.Src.create "arp" ~doc:"ARP handler")
?ipaddr
mac =
Expand All @@ -123,7 +132,7 @@ let create ?(cache_size=1024) ?(timeout = 800) ?(retries = 5)
invalid_arg "retries must be positive" ;
let cache = M.empty cache_size in
let ip = match ipaddr with None -> Ipaddr.V4.any | Some x -> x in
let t = { cache ; mac ; ip ; timeout ; retries ; epoch = 0 ; logsrc } in
let t = { cache ; mac ; ip ; timeout ; refresh; retries ; epoch = 0 ; logsrc } in
match ipaddr with
| None -> t, None
| Some ip ->
Expand All @@ -144,9 +153,10 @@ let in_cache t ip =
| Pending _ -> None
| Static (m, _) -> Some m
| Dynamic (m, _) -> Some m
| Stale (m, _) -> Some m
| Probing (m, _) -> Some m

let request t ip =
let target = Macaddr.broadcast in
let request t ?(target = Macaddr.broadcast) ip =
let request = {
Arp_packet.operation = Arp_packet.Request ;
source_mac = t.mac ; source_ip = t.ip ;
Expand All @@ -168,25 +178,42 @@ let tick t =
let entry k v (cache, acc, r) = match v with
| Dynamic (m, tick) when tick = epoch ->
Logs.debug ~src:t.logsrc
(fun pp -> pp "removing ARP entry %a (mac %a)"
(fun pp -> pp "ARP entry %a (mac %a) timed out --> Stale"
Ipaddr.V4.pp k Macaddr.pp m) ;
M.remove k cache, acc, r
| Dynamic (_, tick) when tick = succ epoch ->
cache, request t k :: acc, r
M.add k (Stale (m, t.epoch + t.timeout)) cache, acc, r
| Pending (a, retry) when retry = epoch ->
Logs.info ~src:t.logsrc
(fun pp -> pp "ARP timeout after %d retries for %a"
t.retries Ipaddr.V4.pp k) ;
M.remove k cache, acc, a :: r
| Pending _ -> cache, request t k :: acc, r
| Pending (_, retry) ->
Logs.debug ~src:t.logsrc
(fun pp -> pp "resending ARP request for %a (%d left)"
Ipaddr.V4.pp k (retry - epoch)) ;
cache, request t k :: acc, r
| Stale (m, tick) when tick = epoch ->
Logs.debug ~src:t.logsrc
(fun pp -> pp "removing stale ARP entry %a (mac %a)"
Ipaddr.V4.pp k Macaddr.pp m) ;
M.remove k cache, acc, r
| Probing (m, retry) when retry = epoch ->
Logs.info ~src:t.logsrc
(fun pp -> pp "unicast ARP probe timeout after %d retries for %a/%a failed"
t.retries Ipaddr.V4.pp k Macaddr.pp m) ;
M.remove k cache, acc, r
| Probing (target, retry) ->
Logs.debug ~src:t.logsrc
(fun pp -> pp "sending unicast ARP probe for %a/%a (%d left)"
Ipaddr.V4.pp k Macaddr.pp target (retry - epoch)) ;
cache, request t ~target k :: acc, r
| _ -> cache, acc, r
in
let cache, outs, r = M.fold entry t.cache (t.cache, [], []) in
{ t with cache ; epoch = succ epoch }, outs, r

let handle_reply t source mac =
let extcache =
let cache = M.add source (Dynamic (mac, t.epoch + t.timeout)) t.cache in
let update_cache () =
Copy link
Member

@hannesm hannesm Nov 7, 2025

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

why is this renamed, and moved to be a function?

Copy link
Author

@ansiwen ansiwen Nov 7, 2025

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

because extcache is not used in all branches, so I think it is better to do it on demand. For me at least update_cache is easier to understand.

let cache = M.add source (Dynamic (mac, t.epoch + t.refresh)) t.cache in
{ t with cache }
in
match M.find source t.cache with
Expand All @@ -205,16 +232,29 @@ let handle_reply t source mac =
Ipaddr.V4.pp source (if adv then "advertised " else ""))
[@coverage off] ;
t, None, None
| Dynamic (m, _) ->
if Macaddr.compare mac m <> 0 then
| Dynamic (m, _)
| Stale (m, _)
| Probing (m, _) ->
let t = if Macaddr.compare mac m <> 0 then
let cache = M.add source (Stale (mac, t.epoch + t.timeout)) t.cache in
Logs.warn ~src:t.logsrc
(fun pp -> pp "ARP for %a moved from %a to %a"
(fun pp -> pp "MAC address for %a moved from %a to %a, marked as stale"
Ipaddr.V4.pp source
Macaddr.pp m
Macaddr.pp mac) ;
extcache, None, None
| Pending (xs, _) -> extcache, None, Some (mac, xs)

Macaddr.pp mac);
{ t with cache }
else (
Logs.debug ~src:t.logsrc
(fun pp -> pp "ARP reply received for %a/%a, refreshing cache entry"
Ipaddr.V4.pp source Macaddr.pp mac);
update_cache ())
in
t, None, None
| Pending (xs, _) ->
Logs.debug ~src:t.logsrc
(fun pp -> pp "ARP reply received for %a/%a, adding cache entry"
Ipaddr.V4.pp source Macaddr.pp mac);
update_cache (), None, Some (mac, xs)

let handle_request t arp =
let dest = arp.Arp_packet.target_ip
Expand Down Expand Up @@ -272,10 +312,20 @@ let query t ip a =
| exception Not_found ->
let a = a None in
let cache = M.add ip (Pending (a, t.epoch + t.retries)) t.cache in
Logs.debug ~src:t.logsrc
(fun pp -> pp "sending ARP request for %a --> Pending"
Ipaddr.V4.pp ip) ;
{ t with cache }, RequestWait (request t ip, a)
| Pending (x, r) ->
let a = a (Some x) in
let cache = M.add ip (Pending (a, r)) t.cache in
{ t with cache }, Wait a
| Static (m, _) -> t, Mac m
| Dynamic (m, _) -> t, Mac m
| Stale (m, _) ->
Logs.debug ~src:t.logsrc
(fun pp -> pp "request for stale entry %a/%a --> Probing"
Ipaddr.V4.pp ip Macaddr.pp m) ;
let cache = M.add ip (Probing (m, t.epoch + t.retries + 1)) t.cache in
{ t with cache }, Mac m
| Static (m, _)
| Dynamic (m, _)
| Probing (m, _) -> t, Mac m
15 changes: 8 additions & 7 deletions src/arp_handler.mli
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -45,17 +45,18 @@ type 'a t

(** {2 Constructor} *)

(** [create ~cache_size ~timeout ~retries ~ipaddr mac)] is [t, garp]. The constructor of
the ARP handler, specifying timeouts (defaults to 800) and amount of
retries (defaults to 5). If [ipaddr] is provided, a gratuitous ARP
request will be encoded in [garp], otherwise {!Ipaddr.V4.any} is temporarily
used and [garp] is [None]. The value of [timeout] is the number of
[Tick] events.
(** [create ~cache_size ~timeout ~refresh ~retries ~ipaddr mac)] is [t, garp]. The
constructor of the ARP handler, specifying timeout of stale cache entries
(defaults to 800), the refresh interval of active entries (defaults to 40)
and amount of retries for requests and probes (defaults to 5). If [ipaddr]
is provided, a gratuitous ARP request will be encoded in [garp], otherwise
{!Ipaddr.V4.any} is temporarily used and [garp] is [None]. The value of
[timeout] and [refresh] is the number of [Tick] events.
[cache_size] limits the number of dynamic entries in the ARP cache.

@raise Invalid_argument is [timeout] is 0 or negative or [retries] is
negative. *)
val create : ?cache_size: int -> ?timeout:int -> ?retries:int -> ?logsrc:Logs.src ->
val create : ?cache_size: int -> ?timeout:int -> ?refresh:int -> ?retries:int -> ?logsrc:Logs.src ->
?ipaddr:Ipaddr.V4.t -> Macaddr.t -> 'a t * (Arp_packet.t * Macaddr.t) option

(** [pp ppf t] prints the ARP handler [t] on [ppf] by iterating over all cache
Expand Down
60 changes: 35 additions & 25 deletions test/mirage/tests.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -309,10 +309,11 @@ let input_replaces_old () =
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 () ->
A.remove_ip listen.arp first_ip >>= fun () ->
V.disconnect listen.netif
)

let os_linux_bsd () =
let os_linux_freebsd () =
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
Expand All @@ -321,32 +322,41 @@ let os_linux_bsd () =
| 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})
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
(* start ARP listener that will stay active throughout the test *)
Lwt.async (fun () -> V.listen listen.netif ~header_size (start_arp_listener listen ()) >|= fun _ -> ());
let for_listener = arp_reply ~from_netif:speak.netif ~to_netif:listen.netif
~from_ip:first_ip ~to_ip:second_ip in
let establish_entry =
let query = A.query listen.arp first_ip >>= function
| Ok mac when Macaddr.compare mac (V.mac speak.netif) = 0 -> Lwt.return_unit
| Ok mac -> failf "got unexpected MAC %a, expected %a"
Macaddr.pp mac Macaddr.pp (V.mac speak.netif)
| Error e -> failf "query failed: %a" A.pp_error e
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
let send_reply =
E.write speak.ethif (V.mac listen.netif) `ARP ~size for_listener >|= function
| Ok _ -> ()
| Error _ -> failf "ethernet write failed"
in
timeout ~time:7000 test
query >>= fun () -> send_reply
in
timeout ~time:1000 establish_entry >>= fun () ->
(* wait for cache entry to expire, entry is removed after timeout (800 ticks *
2ms = 1600ms) from initial creation *)
(* CI for MacOS/OpenBSD/etc. has slower ticks, wait longer *)
let delay = if os_linux_freebsd () then 5 else 20 in
Mirage_sleep.ns (Duration.of_sec delay) >>= fun () ->
(* querying now should generate an ARP request since entry should be removed *)
timeout ~time:1000 (not_in_cache ~listen:speak.netif expected_arp_query listen.arp first_ip)

(* RFC isn't strict on how many times to try, so we'll just say any number
greater than 1 is fine *)
Expand Down
Loading