Git-Mirrors/qubes-mirage-firewall
1
0
Fork 0
mirror of https://github.com/mirage/qubes-mirage-firewall.git synced 2024-12-18 12:04:28 -05:00
Code Issues Packages Projects Releases Wiki Activity

Drop frames if the xmit queue gets too long

Browse Source 
With lots of VMs updating, the firewall quit with:

    2017-04-23 20:47:52 -00:00: INF [frameQ] Queue length for 10.137.3.11: incr to 474
    2017-04-23 20:47:52 -00:00: INF [memory_pressure] Writing meminfo: free 2648 / 17504 kB (15.13 %)
    [...]
    Fatal error: out of memory.

The firewall will now drop frames when more than 10 are queued (note
that queuing only starts once the network driver's transmit buffer is
already full).
This commit is contained in:
Thomas Leonard 2017-04-29 11:42:31 +01:00
parent 445b1711cb
commit e55c304160
2 changed files with 20 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
frameQ.ml
View File

@ -11,15 +11,22 @@ type t = {
let create name = { name; items = 0 } let create name = { name; items = 0 }
(* Note: the queue is only used if we already filled the transmit buffer. *)
let max_qlen = 10
let send q fn = let send q fn =
(* TODO: drop if queue too long *) if q.items = max_qlen then (
let sent = fn () in Log.warn (fun f -> f "Maximim queue length exceeded for %s: dropping frame" q.name);
if Lwt.state sent = Lwt.Sleep then ( Lwt.return_unit
q.items <- q.items + 1; ) else (
Log.info (fun f -> f "Queue length for %s: incr to %d" q.name q.items); let sent = fn () in
Lwt.on_termination sent (fun () -> if Lwt.state sent = Lwt.Sleep then (
q.items <- q.items - 1; q.items <- q.items + 1;
Log.info (fun f -> f "Queue length for %s: decr to %d" q.name q.items); Log.info (fun f -> f "Queue length for %s: incr to %d" q.name q.items);
) Lwt.on_termination sent (fun () ->
); q.items <- q.items - 1;
sent Log.info (fun f -> f "Queue length for %s: decr to %d" q.name q.items);
)
);
sent
)

2
frameQ.mli
View File

@ -8,7 +8,7 @@ type t
val create : string -> t val create : string -> t
(** [create name] is a new empty queue. [name] is used in log messages. *) (** [create name] is a new empty queue. [name] is used in log messages. *)
val send : t -> (unit -> 'a Lwt.t) -> 'a Lwt.t val send : t -> (unit -> unit Lwt.t) -> unit Lwt.t
(** [send t fn] checks that the queue isn't overloaded and calls [fn ()] if it's OK. (** [send t fn] checks that the queue isn't overloaded and calls [fn ()] if it's OK.
The item is considered to be queued until the result of [fn] has resolved. The item is considered to be queued until the result of [fn] has resolved.
In the case of mirage-net-xen's [writev], this happens when the frame has been In the case of mirage-net-xen's [writev], this happens when the frame has been