Tcpip.4.1.0

.gitignore

@@ -1,7 +1,6 @@
-*.byte
-setup.data
-setup.log
 opam/
 log/
-_build
+_build/
 *.swp
+.merlin
+*.install

example/unikernel.ml

@@ -163,7 +163,7 @@ module Main
        handle ipv4 traffic with the functions we've defined above for NATting,
        and ignore all ipv6 traffic (ipv6 has no need for NAT!). *)
     let listen_public =
-      let cache = Fragments.Cache.create (256 * 1024) in
+      let cache = ref (Fragments.Cache.empty (256 * 1024)) in
       let header_size = Ethernet_wire.sizeof_ethernet
       and input =
         Public_ethernet.input
@@ -180,7 +180,7 @@ module Main
     in
 
     let listen_private =
-      let cache = Fragments.Cache.create (256 * 1024) in
+      let cache = ref (Fragments.Cache.empty (256 * 1024)) in
       let header_size = Ethernet_wire.sizeof_ethernet
       and input =
         Private_ethernet.input

example/util.ml

@@ -5,7 +5,9 @@
 let get_dst (`IPv4 (packet, _) : Nat_packet.t) = packet.Ipv4_packet.dst
 
 let try_decompose cache ~now f packet =
-  match Nat_packet.of_ipv4_packet cache ~now:(now ()) packet with
+  let cache', r = Nat_packet.of_ipv4_packet !cache ~now:(now ()) packet in
+  cache := cache';
+  match r with
   | Error e ->
     Logs.err (fun m -> m "of_ipv4_packet error %a" Nat_packet.pp_error e);
     Lwt.return_unit

lib/dune

@@ -3,6 +3,6 @@
  (public_name mirage-nat)
  (modules mirage_nat nat_rewrite nat_packet mirage_nat_lru)
  (wrapped false)
- (libraries mirage-clock tcpip.ipv4 tcpip.tcp tcpip.udp tcpip.icmpv4 lru ethernet arp)
+ (libraries tcpip.ipv4 tcpip.tcp tcpip.udp tcpip.icmpv4 lru ethernet stdlib-shims)
  (preprocess
   (pps ppx_deriving.eq)))

lib/mirage_nat_lru.ml

@@ -16,98 +16,98 @@ end
 
 module Id = struct
   type t = Cstruct.uint16 channel
-  let equal = (=)
-  let hash = Hashtbl.seeded_hash
+  let compare = Stdlib.compare
 end
 
 module Ports = struct
   type t = (Mirage_nat.port * Mirage_nat.port) channel
-  let equal = (=)
-  let hash = Hashtbl.seeded_hash
+  let compare = Stdlib.compare
 end
 
-module Port_cache = Lru.M.MakeSeeded(Ports)(Uniform_weights(Ports))
-module Id_cache = Lru.M.MakeSeeded(Id)(Uniform_weights(Id))
+module Port_cache = Lru.F.Make(Ports)(Uniform_weights(Ports))
+module Id_cache = Lru.F.Make(Id)(Uniform_weights(Id))
 
 module Storage = struct
 
   type defaults = {
-    empty_tcp : unit -> Port_cache.t;
-    empty_udp : unit -> Port_cache.t;
-    empty_icmp : unit -> Id_cache.t;
+    empty_tcp : Port_cache.t;
+    empty_udp : Port_cache.t;
+    empty_icmp : Id_cache.t;
   }
 
   type t = {
     defaults : defaults;
-    mutable tcp: Port_cache.t;
-    mutable udp: Port_cache.t;
-    mutable icmp: Id_cache.t;
+    tcp: Port_cache.t ref;
+    udp: Port_cache.t ref;
+    icmp: Id_cache.t ref;
   }
 
   module Subtable
       (L : sig
          type transport_channel
-         module LRU : Lru.M.S with type v = transport_channel channel
-         val table : t -> LRU.t
+         module LRU : Lru.F.S with type v = transport_channel channel
+         val table : t -> LRU.t ref
        end)
   = struct
     type transport_channel = L.transport_channel
     type nonrec channel = transport_channel channel
 
     let lookup t key =
-      MProf.Trace.label "Mirage_nat_hashtable.lookup.read";
+      MProf.Trace.label "Mirage_nat_lru.lookup.read";
       let t = L.table t in
-      match L.LRU.find key t with
+      match L.LRU.find key !t with
       | None -> Lwt.return_none
-      | Some _ as r -> L.LRU.promote key t; Lwt.return r
+      | Some _ as r -> t := L.LRU.promote key !t; Lwt.return r
 
     (* cases that should result in a valid mapping:
        neither side is already mapped *)
     let insert t mappings =
-      MProf.Trace.label "Mirage_nat_hashtable.insert";
+      MProf.Trace.label "Mirage_nat_lru.insert";
       let t = L.table t in
       match mappings with
       | [] -> Lwt.return (Ok ())
       | m :: ms ->
-        let known (src, _dst) = L.LRU.mem src t in
+        let known (src, _dst) = L.LRU.mem src !t in
         let first_known = known m in
         if List.exists (fun x -> known x <> first_known) ms then Lwt.return (Error `Overlap)
         else (
           (* TODO: this is not quite right if all mappings already exist, because it's possible that
              the lookups are part of differing pairs -- this situation is pathological, but possible *)
-          mappings |> List.iter L.LRU.(fun (a, b) -> add a b t; trim t);
+          let t' = List.fold_left (fun t (a, b) -> L.LRU.add a b t) !t mappings in
+          t := L.LRU.trim t';
           Lwt.return_ok ()
         )
 
     let delete t mappings =
       let t = L.table t in
-      mappings |> List.iter (fun m -> L.LRU.remove m t);
+      let t' = List.fold_left (fun t m -> L.LRU.remove m t) !t mappings in
+      t := t';
       Lwt.return_unit
 
-    let pp f t = Fmt.pf f "%d/%d" (L.LRU.size t) (L.LRU.capacity t)
+    let pp f t = Fmt.pf f "%d/%d" (L.LRU.size !t) (L.LRU.capacity !t)
   end
 
   module TCP  = Subtable(struct module LRU = Port_cache let table t = t.tcp  type transport_channel = Mirage_nat.port * Mirage_nat.port end)
   module UDP  = Subtable(struct module LRU = Port_cache let table t = t.udp  type transport_channel = Mirage_nat.port * Mirage_nat.port end)
   module ICMP = Subtable(struct module LRU = Id_cache   let table t = t.icmp type transport_channel = Cstruct.uint16                    end)
 
   let reset t =
-    t.tcp <- t.defaults.empty_tcp ();
-    t.udp <- t.defaults.empty_udp ();
-    t.icmp <- t.defaults.empty_icmp ();
+    t.tcp := t.defaults.empty_tcp;
+    t.udp := t.defaults.empty_udp;
+    t.icmp := t.defaults.empty_icmp;
     Lwt.return ()
 
   let empty ~tcp_size ~udp_size ~icmp_size =
     let defaults = {
-      empty_tcp = (fun () -> Port_cache.create ~random:false tcp_size);
-      empty_udp = (fun () -> Port_cache.create ~random:false udp_size);
-      empty_icmp = (fun () -> Id_cache.create ~random:false icmp_size);
+      empty_tcp = Port_cache.empty tcp_size;
+      empty_udp = Port_cache.empty udp_size;
+      empty_icmp = Id_cache.empty icmp_size;
     } in
     Lwt.return {
       defaults;
-      tcp = defaults.empty_tcp ();
-      udp = defaults.empty_udp ();
-      icmp = defaults.empty_icmp ();
+      tcp = ref defaults.empty_tcp;
+      udp = ref defaults.empty_udp;
+      icmp = ref defaults.empty_icmp;
     }
 
   let pp_summary f t =

lib/nat_packet.ml

@@ -29,12 +29,14 @@ let icmp_type header =
   | Parameter_problem
   | Destination_unreachable -> `Error
 
-let of_ipv4_packet cache ~now packet : (t option, error) result =
+let of_ipv4_packet cache ~now packet : Fragments.Cache.t * (t option, error) result =
   match Ipv4_packet.Unmarshal.of_cstruct packet with
   | Error e ->
+    cache,
     Error (fun f -> Fmt.pf f "Failed to parse IPv4 packet: %s@.%a" e Cstruct.hexdump_pp packet)
   | Ok (ip_packet, payload) ->
-    match Fragments.process cache now ip_packet payload with
+    let cache', r = Fragments.process cache now ip_packet payload in
+    cache', match r with
     | None -> Ok None
     | Some (ip, transport) ->
       match Ipv4_packet.(Unmarshal.int_to_protocol ip.proto) with
@@ -62,11 +64,11 @@ let of_ipv4_packet cache ~now packet : (t option, error) result =
 let of_ethernet_frame cache ~now frame =
   match Ethernet_packet.Unmarshal.of_cstruct frame with
   | Error e ->
-    Error (fun f -> Fmt.pf f "Failed to parse ethernet frame: %s@.%a" e Cstruct.hexdump_pp frame)
+    cache, Error (fun f -> Fmt.pf f "Failed to parse ethernet frame: %s@.%a" e Cstruct.hexdump_pp frame)
   | Ok (eth, packet) ->
     match eth.Ethernet_packet.ethertype with
     | `ARP | `IPv6 ->
-      Error (fun f -> Fmt.pf f "Ignoring a non-IPv4 frame: %a" Cstruct.hexdump_pp frame)
+      cache, Error (fun f -> Fmt.pf f "Ignoring a non-IPv4 frame: %a" Cstruct.hexdump_pp frame)
     | `IPv4 -> of_ipv4_packet cache ~now packet
 
 let decompose_transport = function

lib/nat_packet.mli

@@ -12,10 +12,10 @@ val icmp_type : Icmpv4_packet.t -> [ `Query | `Error ]
 val pp_error : error Fmt.t
 
 val of_ethernet_frame : Fragments.Cache.t -> now:int64 -> Cstruct.t ->
-  (t option, error) result
+  Fragments.Cache.t * (t option, error) result
 
 val of_ipv4_packet : Fragments.Cache.t -> now:int64 -> Cstruct.t ->
-  (t option, error) result
+  Fragments.Cache.t * (t option, error) result
 
 val to_cstruct : ?mtu:int -> t -> (Cstruct.t list, error) result
 (** [to_cstruct packet] is the list of cstructs representing [packet].

lib_test/test_rewrite.ml

@@ -33,7 +33,7 @@ module Constructors = struct
         (Ipv4_packet.Unmarshal.verify_transport_checksum ~ipv4_header ~transport_packet ~proto)
 
   let check_save_restore packet =
-    let cache = Fragments.Cache.create 10 in
+    let cache = Fragments.Cache.empty 10 in
     let raw_to_cstruct =
       match Nat_packet.to_cstruct packet with
       | Ok [ data ] -> data
@@ -49,12 +49,12 @@ module Constructors = struct
     assert_checksum_correct raw_to_cstruct;
     assert_checksum_correct raw_into_cstruct;
     let check_packet raw =
-      match Nat_packet.of_ipv4_packet cache ~now:0L raw with
+      match snd (Nat_packet.of_ipv4_packet cache ~now:0L raw) with
       | Ok Some loaded when Nat_packet.equal packet loaded -> ()
       | Ok Some loaded -> Alcotest.fail (Fmt.strf "Packet changed by save/load! Saved:@.%a@.Got:@.%a"
                                            Nat_packet.pp packet
                                            Nat_packet.pp loaded
-                                        )
+                                           )
       | Ok None -> Alcotest.fail (Fmt.strf "Packet changed by save/load! Saved:@.%a@.Got nothing"
                                     Nat_packet.pp packet)
       | Error e   -> Alcotest.fail (Fmt.strf "Failed to load saved packet! Saved:@.%a@.As:@.%a@.Error: %a"
@@ -223,7 +223,7 @@ let test_add_nat_valid_pkt () =
   Alcotest.check add_result "Check overlap detection" (Error `Overlap)
 
 let test_add_nat_broadcast () =
-  let cache = Fragments.Cache.create 10 in
+  let cache = Fragments.Cache.empty 10 in
   let open Default_values in
   let broadcast_dst = ipv4_of_str "255.255.255.255" in
   let broadcast = Constructors.full_packet ~payload ~proto:`TCP ~ttl:30 ~src
@@ -234,7 +234,7 @@ let test_add_nat_broadcast () =
   Alcotest.check add_result "Ignore broadcast" (Error `Cannot_NAT) >>= fun () ->
   (* try just an ethernet frame *)
   let e = Cstruct.create Ethernet_wire.sizeof_ethernet in
-  Nat_packet.of_ethernet_frame cache ~now:0L e |> Rresult.R.reword_error ignore
+  Nat_packet.of_ethernet_frame cache ~now:0L e |> snd |> Rresult.R.reword_error ignore
   |> Alcotest.(check (result (option packet_t) unit)) "Bare ethernet frame" (Error ());
   Lwt.return ()
 
@@ -535,12 +535,12 @@ let test_of_ipv4_packet_reassembly_basic () =
   let packet = gen_icmp 1473 in
   match Nat_packet.to_cstruct ~mtu:1500 packet with
   | Ok [ init; more ] ->
-    let cache = Fragments.Cache.create (128 * 1024)
+    let cache = Fragments.Cache.empty (128 * 1024)
     and now = 0L
     in
     begin match Nat_packet.of_ipv4_packet cache ~now init with
-      | Ok None ->
-        begin match Nat_packet.of_ipv4_packet cache ~now more with
+      | cache', Ok None ->
+        begin match snd (Nat_packet.of_ipv4_packet cache' ~now more) with
           | Ok Some pkt -> Alcotest.check packet_t __LOC__ packet pkt
           | _ -> Alcotest.fail "expecting a packet"
         end

mirage-nat.opam

@@ -16,17 +16,15 @@ depends: [
   "ocaml" {>= "4.06.0"}
   "ipaddr"
   "cstruct"
-  "mirage-time" {>= "2.0.0"}
-  "mirage-clock" {>= "3.0.0"}
   "lwt"
   "rresult"
   "logs"
   "lru" {>= "0.3.0"}
   "ppx_deriving" {>= "4.2" }
   "dune" {>= "1.0"}
-  "tcpip" { >= "3.7.8" }
+  "tcpip" { >= "4.1.0" }
   "ethernet" { >= "2.0.0" }
-  "arp"
+  "stdlib-shims"
   "alcotest" {with-test}
   "mirage-clock-unix" {with-test}
 ]