Merge branch 'master' into dunify-with-variants

src/arpv4/arpv4.ml

@@ -86,7 +86,7 @@ module Make (Ethif : Mirage_protocols_lwt.ETHIF)
     Format.fprintf fmt "%s" repr
 
   let notify t ip mac =
-    Log.debug (fun f -> f "notifying: %a -> %s" Ipaddr.V4.pp ip (Macaddr.to_string mac));
+    Log.debug (fun f -> f "notifying: %a -> %a" Ipaddr.V4.pp ip Macaddr.pp mac);
     match Ipaddr.V4.is_multicast ip || (Ipaddr.V4.compare ip Ipaddr.V4.any = 0) with
     | true -> Log.debug (fun f -> f "Ignoring ARP notification request for IP %a" Ipaddr.V4.pp ip)
     | false ->
@@ -218,12 +218,12 @@ module Make (Ethif : Mirage_protocols_lwt.ETHIF)
     let bound_ips = [] in
     let t = { clock; ethif; cache; bound_ips } in
     Lwt.async (tick t);
-    Log.info (fun f -> f "Connected arpv4 device on %s" (Macaddr.to_string (
-               Ethif.mac t.ethif)));
+    Log.info (fun f -> f "Connected arpv4 device on %a"
+                 Macaddr.pp (Ethif.mac t.ethif));
     Lwt.return t
 
   let disconnect t =
-    Log.info (fun f -> f "Disconnected arpv4 device on %s" (Macaddr.to_string (
-               Ethif.mac t.ethif)));
+    Log.info (fun f -> f "Disconnected arpv4 device on %a"
+                 Macaddr.pp (Ethif.mac t.ethif));
     Lwt.return_unit (* TODO: should kill tick *)
 end

src/arpv4/arpv4_packet.ml

@@ -16,8 +16,8 @@ let equal {op; sha; spa; tha; tpa} q =
   Ipaddr.V4.compare tpa q.tpa = 0
 
 let pp fmt t =
-  Format.fprintf fmt "MAC %s (IP %a) -> MAC %s (IP %a): ARP operation %s"
-    (Macaddr.to_string t.sha) Ipaddr.V4.pp t.spa (Macaddr.to_string t.tha)
+  Format.fprintf fmt "MAC %a (IP %a) -> MAC %a (IP %a): ARP operation %s"
+    Macaddr.pp t.sha Ipaddr.V4.pp t.spa Macaddr.pp t.tha
     Ipaddr.V4.pp t.tpa (Arpv4_wire.op_to_string t.op)
 
 module Unmarshal = struct
@@ -56,10 +56,10 @@ module Unmarshal = struct
     let src_mac = copy_arp_sha buf in
     let target_mac = copy_arp_tha buf in
     match (Macaddr.of_bytes src_mac, Macaddr.of_bytes target_mac) with
-    | None, None   -> Error (Bad_mac [ src_mac ; target_mac ])
-    | None, Some _ -> Error (Bad_mac [ src_mac ])
-    | Some _, None -> Error (Bad_mac [ target_mac ])
-    | Some src_mac, Some target_mac ->
+    | Error _, Error _ -> Error (Bad_mac [ src_mac ; target_mac ])
+    | Error _, Ok _ -> Error (Bad_mac [ src_mac ])
+    | Ok _, Error _ -> Error (Bad_mac [ target_mac ])
+    | Ok src_mac, Ok target_mac ->
       let src_ip = Ipaddr.V4.of_int32 (get_arp_spa buf) in
       let target_ip = Ipaddr.V4.of_int32 (get_arp_tpa buf) in
       Ok { op;

src/arpv4/dune

@@ -1,6 +1,6 @@
 (library
  (name        tcpip_arpv4)
  (public_name tcpip.arpv4)
- (libraries   mirage-protocols-lwt logs ipaddr cstruct rresult tcpip.ethif duration fmt mirage-clock-lwt mirage-time-lwt)
+ (libraries   mirage-protocols-lwt logs ipaddr macaddr cstruct rresult tcpip.ethif duration fmt mirage-clock-lwt mirage-time-lwt)
  (preprocess (pps ppx_cstruct))
  (wrapped false))

src/ethif/ethif.ml

@@ -78,10 +78,10 @@ module Make(Netif : Mirage_net_lwt.S) = struct
   let connect ?(mtu = default_mtu) netif =
     MProf.Trace.label "ethif.connect";
     let t = { netif; mtu } in
-    Log.info (fun f -> f "Connected Ethernet interface %s" (Macaddr.to_string (mac t)));
+    Log.info (fun f -> f "Connected Ethernet interface %a" Macaddr.pp (mac t));
     Lwt.return t
 
   let disconnect t =
-    Log.info (fun f -> f "Disconnected Ethernet interface %s" (Macaddr.to_string (mac t)));
+    Log.info (fun f -> f "Disconnected Ethernet interface %a" Macaddr.pp (mac t));
     Lwt.return_unit
 end

src/ethif/ethif_packet.ml

@@ -9,8 +9,8 @@ type t = {
 type error = string
 
 let pp fmt t =
-  Format.fprintf fmt "%s -> %s: %s" (Macaddr.to_string t.source)
-    (Macaddr.to_string t.destination) (Ethif_wire.ethertype_to_string t.ethertype)
+  Format.fprintf fmt "%a -> %a: %s" Macaddr.pp t.source
+    Macaddr.pp t.destination (Ethif_wire.ethertype_to_string t.ethertype)
 
 let equal {source; destination; ethertype} q =
   (Macaddr.compare source q.source) = 0 &&

src/ipv6/ndpv6.ml

@@ -115,8 +115,8 @@ let macaddr_to_cstruct_raw x cs off =
 let macaddr_of_cstruct cs =
   if Cstruct.len cs <> 6 then invalid_arg "macaddr_of_cstruct";
   match Macaddr.of_bytes (Cstruct.to_string cs) with
-  | Some x -> x
-  | None -> assert false
+  | Ok x -> x
+  | Error _ -> assert false
 
 let interface_addr mac =
   let bmac = Macaddr.to_bytes mac in
@@ -645,7 +645,7 @@ module NeighborCache = struct
     | Not_found ->
       nc, []
 
-  let query nc ~now ~reachable_time ip =
+  let query nc ~now ~retrans_timer ip =
     try
       let nb = IpMap.find ip nc in
       match nb.state with
@@ -659,7 +659,7 @@ module NeighborCache = struct
         nc, Some dmac, []
     with
     | Not_found ->
-      let nb  = {state = INCOMPLETE (Int64.add now reachable_time, 0); is_router = false} in
+      let nb  = {state = INCOMPLETE (Int64.add now retrans_timer, 0); is_router = false} in
       let nc  = IpMap.add ip nb nc in
       let dst = Ipaddr.Prefix.network_address solicited_node_prefix ip in
       nc, None, [SendNS (`Specified, dst, ip)]
@@ -1110,7 +1110,7 @@ and send ~now ctx dst frame datav =
   | false ->
     let ctx, ip = next_hop ctx dst in
     let neighbor_cache, mac, actions =
-      NeighborCache.query ctx.neighbor_cache ~now ~reachable_time:ctx.reachable_time ip in
+      NeighborCache.query ctx.neighbor_cache ~now ~retrans_timer:ctx.retrans_timer ip in
     let ctx = {ctx with neighbor_cache} in
     match mac with
     | Some dmac ->

tcpip.opam

@@ -33,7 +33,8 @@ depends: [
   "mirage-protocols" {>= "1.4.0"}
   "mirage-protocols-lwt" {>= "1.4.0"}
   "mirage-time-lwt" {>= "1.0.0"}
-  "ipaddr" {>= "2.2.0"}
+  "ipaddr" {>= "3.0.0"}
+  "macaddr"
   "mirage-profile" {>= "0.5"}
   "fmt"
   "lwt" {>= "3.0.0"}

test/test_ipv6.ml

@@ -50,29 +50,38 @@ let listen ?(tcp = noop) ?(udp = noop) ?(default = noop) stack =
 
 let udp_message = Cstruct.of_string "hello on UDP over IPv6"
 
-let check_for_one_udp_packet netif ~src ~dst buf =
+let check_for_one_udp_packet netif on_received_one ~src ~dst buf =
   Alcotest.(check ip) "sender address" (Ipaddr.V6.of_string_exn "fc00::23") src;
   Alcotest.(check ip) "receiver address" (Ipaddr.V6.of_string_exn "fc00::45") dst;
   (match Udp_packet.Unmarshal.of_cstruct buf with
   | Ok (_, payload) ->
     Alcotest.(check cstruct) "payload is correct" udp_message payload
   | Error m -> Alcotest.fail m);
+  (try Lwt.wakeup_later on_received_one () with _ -> () (* the first succeeds, the rest raise *));
   (*after receiving 1 packet, disconnect stack so test can continue*)
   V.disconnect netif
 
+let send_forever sender receiver_address udp_message =
+  let rec loop () =
+    Printf.fprintf stderr "Udp.write\n%!";
+    Udp.write sender.udp ~dst:receiver_address ~dst_port:1234 udp_message
+    >|= Rresult.R.get_ok >>= fun () ->
+    Time.sleep_ns (Duration.of_ms 50) >>= fun () ->
+    loop () in
+  loop ()
+
 let pass_udp_traffic () =
   let sender_address = Ipaddr.V6.of_string_exn "fc00::23" in
   let receiver_address = Ipaddr.V6.of_string_exn "fc00::45" in
   let backend = B.create () in
   get_stack backend sender_address >>= fun sender ->
   get_stack backend receiver_address >>= fun receiver ->
+  let received_one, on_received_one = Lwt.task () in
   Lwt.pick [
-    listen receiver ~udp:(check_for_one_udp_packet receiver.netif);
+    listen receiver ~udp:(check_for_one_udp_packet receiver.netif on_received_one);
     listen sender;
-    (* Duration.of_ms 500 makes this test fail - why? *)
-    Time.sleep_ns (Duration.of_ms 1000) >>= fun () ->
-      Udp.write sender.udp ~dst:receiver_address ~dst_port:1234 udp_message
-      >|= Rresult.R.get_ok >>= fun () ->
+    send_forever sender receiver_address udp_message;
+    received_one; (* stop on the first packet *)
       Time.sleep_ns (Duration.of_ms 3000) >>= fun () ->
       Alcotest.fail "UDP packet should have been received";
   ]

test/test_tcp_window.ml

@@ -1,20 +1,22 @@
 open Lwt.Infix
 
+let now = ref 0L
+
 module Clock = struct
   (* Mirage_device.S *)
   type error = string
-  type t = { time: int64 }
+  type t = unit
   type 'a io = 'a Lwt.t
   let disconnect _ = Lwt.return_unit
-  let connect () = Lwt.return { time = 0L }
+  let connect () = Lwt.return_unit
 
   (* Mirage_clock.MCLOCK *)
-  let period_ns _ = None
-  let elapsed_ns {time} = time
+  let period_ns () = None
+  let elapsed_ns () = !now
 
   (* Test-related function: advance by 1 ns *)
-  let tick {time} = { time = Int64.add time 1L }
-  let tick_for {time} duration = { time = Int64.add time duration }
+  let tick () = now := Int64.add !now 1L
+  let tick_for () duration = now := Int64.add !now duration
 end
 
 module Timed_window = Tcp.Window.Make(Clock)