Merge pull request 'IPv4 routing improvements' (#16) from ipv4 into main

Reviewed-on: https://git.robur.coop/robur/mnet/pulls/16

Author: dinosaure

src/TCP.ml

@@ -124,7 +124,7 @@ let write_without_interruption_ipv4 state (src, dst, seg) =
       Log.warn (fun m -> m "A packet is kept in our internal queue");
       Queue.push (Ipaddr.V4 src, Ipaddr.V4 dst, seg) state.outs
   | Some macaddr ->
-      IPv4.write_directly state.ipv4 ~src (dst, macaddr) ~protocol:6 pkt
+      IPv4.write_directly state.ipv4 src (dst, macaddr) ~protocol:6 pkt
 
 let write_ipv4 ipv4 (src, dst, seg) =
   let len = Utcp.Segment.length seg in

src/ipv4/IPv4.ml

@@ -250,10 +250,9 @@ let fixed pkt user's_fn len bstr =
   Bstr.set_uint16_be bstr 10 chk;
   20 + len
 
-let write_directly t ?(ttl = 38) ?src (dst, macaddr) ~protocol p =
+let write_directly t ?(ttl = 38) src (dst, macaddr) ~protocol p =
   Log.debug (fun m ->
       m ~tags:t.tags "%a is-at %a" Ipaddr.V4.pp dst Macaddr.pp macaddr);
-  let src = Option.value ~default:(Ipaddr.V4.Prefix.address t.cidr) src in
   let mtu = Ethernet.mtu t.eth in
   match p with
   | Writer.Fixed { total_length; fn= user's_fn } ->
@@ -306,21 +305,31 @@ let write_directly t ?(ttl = 38) ?src (dst, macaddr) ~protocol p =
       go 0 total_length (fn ())
 
 let write t ?(ttl = 38) ?src dst ~protocol p =
+  let src = Option.value ~default:(Ipaddr.V4.Prefix.address t.cidr) src in
   Log.debug (fun m -> m ~tags:t.tags "Asking where is %a" Ipaddr.V4.pp dst);
-  match Routing.destination_macaddr t.cidr t.gateway t.arp dst with
+  match Routing.destination_macaddr t.cidr t.gateway t.arp ~src ~dst with
   | Error (`Exn _ | `Timeout | `Clear) ->
       Log.err (fun m -> m ~tags:t.tags "no route found for %a" Ipaddr.V4.pp dst);
       Error `Route_not_found
   | Error `Gateway ->
       Log.debug (fun m ->
-          m ~tags:t.tags "no gateway specified for writing IPv4 packets");
+          m ~tags:t.tags
+            "no gateway specified for writing IPv4 packets, dropping %a"
+            Ipaddr.V4.pp dst);
+      Ok ()
+  | Error `Loopback ->
+      Log.debug (fun m ->
+          m ~tags:t.tags "not sending packet loopback (src %a dst %a)"
+            Ipaddr.V4.pp src Ipaddr.V4.pp dst);
       Ok ()
   | Ok macaddr ->
-      write_directly t ~ttl ?src (dst, macaddr) ~protocol p;
+      write_directly t ~ttl src (dst, macaddr) ~protocol p;
       Ok ()
 
 let attempt_to_discover_destination t dst =
-  Routing.destination_macaddr_without_interruption t.cidr t.gateway t.arp dst
+  let src = Ipaddr.V4.Prefix.address t.cidr in
+  Routing.destination_macaddr_without_interruption t.cidr t.gateway t.arp ~src
+    ~dst
 
 let input t pkt =
   match Packet.decode pkt.Ethernet.payload with

src/ipv4/IPv4.mli

@@ -170,12 +170,12 @@ end
 val write_directly :
      t
   -> ?ttl:int
-  -> ?src:Ipaddr.V4.t
+  -> Ipaddr.V4.t
   -> Ipaddr.V4.t * Macaddr.t
   -> protocol:int
   -> Writer.t
   -> unit
-(** [write_directly ipv4 ?ttl ?src (dst, macaddr) ~protocol w] writes a new IPv4
+(** [write_directly ipv4 ?ttl src (dst, macaddr) ~protocol w] writes a new IPv4
     packet [w] {b effectively} (without interruption) (fragmented or not) to the
     specified destination [macaddr]. *)
 

src/ipv4/routing.ml

@@ -1,35 +1,36 @@
-let broadcast = Ok Macaddr.broadcast
+type r = Mac of Macaddr.t | Arp of Ipaddr.V4.t
 
-let macaddr_of_multicast ipaddr =
-  let buf = Ipaddr.V4.to_octets ipaddr in
-  let mac = Bytes.create 6 in
-  Bytes.set_uint8 mac 0 0x01;
-  Bytes.set_uint8 mac 1 0x00;
-  Bytes.set_uint8 mac 2 0x5e;
-  Bytes.set_uint8 mac 3 (String.get_uint8 buf 1 land 0x7f);
-  Bytes.set_uint8 mac 4 (String.get_uint8 buf 2);
-  Bytes.set_uint8 mac 5 (String.get_uint8 buf 3);
-  Macaddr.of_octets_exn (Bytes.unsafe_to_string mac)
-
-let destination_macaddr network gateway arp ipaddr =
-  if
-    Ipaddr.V4.(compare broadcast) ipaddr == 0
-    || Ipaddr.V4.(compare any) ipaddr == 0
-    || Ipaddr.V4.(compare (Prefix.broadcast network)) ipaddr == 0
-  then broadcast
-  else if Ipaddr.V4.is_multicast ipaddr then Ok (macaddr_of_multicast ipaddr)
-  else if Ipaddr.V4.Prefix.mem ipaddr network then ARPv4.query arp ipaddr
+let routing network gateway ~src ~dst =
+  if Ipaddr.V4.Prefix.(mem dst loopback) || Ipaddr.V4.Prefix.(mem src loopback)
+  then
+    (* avoid packets to or from 127.0.0.0/8 *)
+    Error `Loopback
+  else if
+    Ipaddr.V4.(compare broadcast) dst == 0
+    || Ipaddr.V4.(compare (Prefix.broadcast network)) dst == 0
+  then
+    (* use broadcast mac *)
+    Ok (Mac Macaddr.broadcast)
+  else if Ipaddr.V4.is_multicast dst then
+    (* filter multicast *)
+    Ok (Mac (Ipaddr.V4.multicast_to_mac dst))
+  else if Ipaddr.V4.Prefix.mem dst network then
+    (* direct to this network *)
+    Ok (Arp dst)
   else
+    (* send to gateway *)
     match gateway with
     | None -> Error `Gateway
-    | Some gateway -> ARPv4.query arp gateway
+    | Some gateway -> Ok (Arp gateway)
+
+let ( let* ) = Result.bind
+
+let destination_macaddr network gateway arp ~src ~dst =
+  let* it = routing network gateway ~src ~dst in
+  match it with Mac x -> Ok x | Arp ip -> ARPv4.query arp ip
 
-let destination_macaddr_without_interruption network gateway arp ipaddr =
-  if
-    Ipaddr.V4.(compare broadcast) ipaddr == 0
-    || Ipaddr.V4.(compare any) ipaddr == 0
-    || Ipaddr.V4.(compare (Prefix.broadcast network)) ipaddr == 0
-  then Result.to_option broadcast
-  else if Ipaddr.V4.is_multicast ipaddr then Some (macaddr_of_multicast ipaddr)
-  else if Ipaddr.V4.Prefix.mem ipaddr network then ARPv4.ask arp ipaddr
-  else match gateway with None -> None | Some gateway -> ARPv4.ask arp gateway
+let destination_macaddr_without_interruption network gateway arp ~src ~dst =
+  match routing network gateway ~src ~dst with
+  | Error _ -> None
+  | Ok (Mac x) -> Some x
+  | Ok (Arp ip) -> ARPv4.ask arp ip