From e55c304160e61296ea32bfa36733600c15e85d2c Mon Sep 17 00:00:00 2001
From: Thomas Leonard <thomas.leonard@unikernel.com>
Date: Sat, 29 Apr 2017 11:42:31 +0100
Subject: [PATCH] Drop frames if the xmit queue gets too long

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).
---
 frameQ.ml  | 31 +++++++++++++++++++------------
 frameQ.mli |  2 +-
 2 files changed, 20 insertions(+), 13 deletions(-)

diff --git a/frameQ.ml b/frameQ.ml
index bea4cf2..b6b7ed1 100644
--- a/frameQ.ml
+++ b/frameQ.ml
@@ -10,16 +10,23 @@ type t = {
 }
 
 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 =
-  (* TODO: drop if queue too long *)
-  let sent = fn () in
-  if Lwt.state sent = Lwt.Sleep then (
-    q.items <- q.items + 1;
-    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;
-      Log.info (fun f -> f "Queue length for %s: decr to %d" q.name q.items);
-    )
-  );
-  sent
+  if q.items = max_qlen then (
+    Log.warn (fun f -> f "Maximim queue length exceeded for %s: dropping frame" q.name);
+    Lwt.return_unit
+  ) else (
+    let sent = fn () in
+    if Lwt.state sent = Lwt.Sleep then (
+      q.items <- q.items + 1;
+      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;
+        Log.info (fun f -> f "Queue length for %s: decr to %d" q.name q.items);
+      )
+    );
+    sent
+  )
diff --git a/frameQ.mli b/frameQ.mli
index de72211..f11e1ae 100644
--- a/frameQ.mli
+++ b/frameQ.mli
@@ -8,7 +8,7 @@ type t
 val create : string -> t
 (** [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.
     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