Merge pull request #36 from robur-coop/mc-1

hannesm · web-flow · commit a7cd11fb7977 · 2024-09-11T20:32:31.000+02:00
remove mirage-random, use mirage-crypto-rng-mirage &gt;= 1.0.0
diff --git a/app/dune b/app/dune
@@ -3,7 +3,7 @@
  (public_name server)
  (modules server)
  (libraries utcp mirage-net-unix cstruct lwt logs ethernet arp.mirage
-   tcpip.ipv4 mirage-random-test mirage-unix mirage-clock-unix lwt.unix
+   tcpip.ipv4 mirage-crypto-rng-mirage mirage-unix mirage-clock-unix lwt.unix
    cmdliner logs.fmt fmt.cli logs.cli fmt.tty mtime.clock.os)
  (optional))
 
@@ -12,7 +12,7 @@
  (public_name single)
  (modules single)
  (libraries utcp mirage-net-unix cstruct lwt logs ethernet arp.mirage
-   tcpip.ipv4 mirage-random-test mirage-unix mirage-clock-unix lwt.unix
+   tcpip.ipv4 mirage-crypto-rng mirage-unix mirage-clock-unix lwt.unix
    cmdliner logs.fmt fmt.cli logs.cli fmt.tty mtime.clock.os)
  (optional))
 
diff --git a/app/pcap_replay.ml b/app/pcap_replay.ml
@@ -85,7 +85,7 @@ let initial_packet state ip rng_data now ~src ~dst tcp =
   in
   if Ipaddr.compare ip src = 0 then begin
     (* we're the client - set ISS to match *)
-    Cstruct.LE.set_uint32 rng_data 0 (Cstruct.BE.get_uint32 tcp 4);
+    Bytes.set_int32_le rng_data 0 (Cstruct.BE.get_uint32 tcp 4);
     let state, flow, _cond, out =
       Utcp.connect ~src ~src_port ~dst ~dst_port state now
     in
@@ -102,7 +102,7 @@ let initial_packet state ip rng_data now ~src ~dst tcp =
       assert (dst_port = Cstruct.BE.get_uint16 tcp' 0);
       assert (src_port = Cstruct.BE.get_uint16 tcp' 2);
       (* set ISS to the seq in the next segment ;) *)
-      Cstruct.LE.set_uint32 rng_data 0 (Cstruct.BE.get_uint32 tcp' 4);
+      Bytes.set_int32_le rng_data 0 (Cstruct.BE.get_uint32 tcp' 4);
       (* replay the 0 packet *)
       Logs.info (fun m -> m "replay packet 0");
       let state, _stuff, out = Utcp.handle_buf state now ~src ~dst tcp in
@@ -116,8 +116,8 @@ let jump () filename ip =
   if ip = None then
     Logs.warn (fun m -> m "only decoding and printing pcap, no replaying done (specify --ip=<IP> to take an endpoint)");
   let fold = pcap_reader filename in
-  let rng_data = Cstruct.create 4 in
-  let rng i = assert (i = 4) ; rng_data in
+  let rng_data = Bytes.make 4 '\000' in
+  let rng i = assert (i = 4) ; Bytes.unsafe_to_string rng_data in
   let state = Utcp.empty Fun.id "pcap-replay" rng in
   let flow = ref None in
   fold (fun (state, act) idx ts ~src ~dst tcp ->
diff --git a/app/server.ml b/app/server.ml
@@ -2,7 +2,8 @@ open Lwt.Infix
 
 module Ethernet = Ethernet.Make(Netif)
 module ARP = Arp.Make(Ethernet)(Unix_os.Time)
-module IPv4 = Static_ipv4.Make(Mirage_random_test)(Mclock)(Ethernet)(ARP)
+module R = Mirage_crypto_rng_mirage.Make(Unix_os.Time)(Mclock)
+module IPv4 = Static_ipv4.Make(R)(Mclock)(Ethernet)(ARP)
 
 let log_err ~pp_error = function
   | Ok _ -> ()
@@ -26,8 +27,8 @@ let cb ~proto ~src ~dst payload =
 
 let jump () =
   Printexc.record_backtrace true;
-  Mirage_random_test.initialize ();
   Lwt_main.run (
+    R.initialize (module Mirage_crypto_rng.Fortuna) >>= fun () ->
     Netif.connect "tap2" >>= fun tap ->
     Ethernet.connect tap >>= fun eth ->
     ARP.connect eth >>= fun arp ->
@@ -36,7 +37,7 @@ let jump () =
     let tcp (*, clo, out *) =
       (* let dst = Ipaddr.(V4 (V4.of_string_exn "10.0.42.1")) in *)
       let init (*, conn, out *) =
-        let s = Utcp.empty Fun.id "" Mirage_random_test.generate in
+        let s = Utcp.empty Fun.id "" R.generate in
         let s' = Utcp.start_listen s 23 in
         (* Tcp.connect ~src:Ipaddr.(V4 (V4.Prefix.address cidr)) ~dst ~dst_port:1234 s' (Mtime_clock.now ()) *)
         s'
diff --git a/app/single.ml b/app/single.ml
@@ -2,7 +2,8 @@ open Lwt.Infix
 
 module Ethernet = Ethernet.Make(Netif)
 module ARP = Arp.Make(Ethernet)(Unix_os.Time)
-module IPv4 = Static_ipv4.Make(Mirage_random_test)(Mclock)(Ethernet)(ARP)
+module R = Mirage_crypto_rng_mirage.Make(Unix_os.Time)(Mclock)
+module IPv4 = Static_ipv4.Make(R)(Mclock)(Ethernet)(ARP)
 
 let log_err ~pp_error = function
   | Ok _ -> ()
@@ -30,8 +31,8 @@ let tcp_cb ~src ~dst payload =
 
 let jump _ src src_port dst dst_port syn fin rst push ack seq window data =
   Printexc.record_backtrace true;
-  Mirage_random_test.initialize ();
   Lwt_main.run (
+    R.initialize (module Mirage_crypto_rng.Fortuna) >>= fun () ->
     let cidr = Ipaddr.V4.Prefix.of_string_exn src
     and dst = Ipaddr.(V4 (V4.of_string_exn dst))
     in
diff --git a/app/trace_replay.ml b/app/trace_replay.ml
@@ -198,8 +198,8 @@ let jump () filename ip =
   if ip = None then
     Logs.warn (fun m -> m "only decoding and printing trace, no replaying done (specify --ip=<IP> to take an endpoint)");
   let msgs = trace_reader filename in
-  let rng_data = Cstruct.create 4 in
-  let rng i = assert (i = 4) ; rng_data in
+  let rng_data = Bytes.make 4 '\000' in
+  let rng i = assert (i = 4) ; Bytes.unsafe_to_string rng_data in
   let state =
     let s = Utcp.empty Fun.id "trace-replay" rng in
     Utcp.start_listen s 443
@@ -213,7 +213,7 @@ let jump () filename ip =
       |> List.hd
     in
     let data = Option.get (snd first_out.data) in
-    Cstruct.LE.set_uint32 rng_data 0
+    Bytes.set_int32_le rng_data 0
       (Cstruct.BE.get_uint32 (Cstruct.of_string data) 4)
   in
   let _, _ , _ =
diff --git a/mirage/dune b/mirage/dune
@@ -1,4 +1,4 @@
 (library
  (name utcp_mirage)
  (public_name utcp.mirage)
- (libraries utcp lwt tcpip mirage-random mirage-time mirage-clock))
+ (libraries utcp lwt tcpip mirage-crypto-rng-mirage mirage-time mirage-clock))
diff --git a/mirage/utcp_mirage.ml b/mirage/utcp_mirage.ml
@@ -3,7 +3,7 @@ open Lwt.Infix
 let src = Logs.Src.create "tcp.mirage" ~doc:"TCP mirage"
 module Log = (val Logs.src_log src : Logs.LOG)
 
-module Make (R : Mirage_random.S) (Mclock : Mirage_clock.MCLOCK) (Time : Mirage_time.S) (Ip : Tcpip.Ip.S with type ipaddr = Ipaddr.t) = struct
+module Make (R : Mirage_crypto_rng_mirage.S) (Mclock : Mirage_clock.MCLOCK) (Time : Mirage_time.S) (Ip : Tcpip.Ip.S with type ipaddr = Ipaddr.t) = struct
 
   let now () = Mtime.of_uint64_ns (Mclock.elapsed_ns ())
 
diff --git a/mirage/utcp_mirage.mli b/mirage/utcp_mirage.mli
@@ -1,5 +1,5 @@
 
-module Make (R : Mirage_random.S) (Mclock : Mirage_clock.MCLOCK) (Time : Mirage_time.S) (Ip : Tcpip.Ip.S with type ipaddr = Ipaddr.t) : sig
+module Make (R : Mirage_crypto_rng_mirage.S) (Mclock : Mirage_clock.MCLOCK) (Time : Mirage_time.S) (Ip : Tcpip.Ip.S with type ipaddr = Ipaddr.t) : sig
   include Tcpip.Tcp.S with type ipaddr = Ip.ipaddr
 
   val connect : string -> Ip.t -> t
diff --git a/src/input.ml b/src/input.ml
@@ -87,7 +87,7 @@ let deliver_in_1 mk_notify m stats rng now id seg =
       last_ack_sent = ack' ;
       t_rttseg }
     in
-    conn_state mk_notify ~rcvbufsize ~sndbufsize Syn_received control_block
+    conn_state now mk_notify ~rcvbufsize ~sndbufsize Syn_received control_block
   in
   let reply = Segment.make_syn_ack conn.control_block id in
   Log.debug (fun m -> m "%a passive open %a" Connection.pp id (pp_conn_state now) conn);
diff --git a/src/state.ml b/src/state.ml
@@ -412,18 +412,25 @@ type 'a conn_state = {
   sndq : Cstruct.t list ; (* reverse list of data to be sent out *)
   rcv_notify : 'a;
   snd_notify : 'a;
+  created : Mtime.t;
 }
 
-let conn_state mk_notify ~rcvbufsize ~sndbufsize tcp_state control_block = {
+let conn_state created mk_notify ~rcvbufsize ~sndbufsize tcp_state control_block = {
   tcp_state ; control_block ;
   cantrcvmore = false ; cantsndmore = false ;
   rcvq = [] ; sndq = [] ;
   rcvbufsize ; sndbufsize ;
   rcv_notify = mk_notify () ; snd_notify = mk_notify () ;
+  created ;
 }
 
 let pp_conn_state now ppf c =
-  Fmt.pf ppf "TCP %a cb %a" pp_fsm c.tcp_state (pp_control now) c.control_block
+  let created_span = Mtime.Span.of_uint64_ns (Mtime.to_uint64_ns c.created) in
+  Fmt.pf ppf "TCP (since %a) %a cb %a"
+    Duration.pp
+    (Mtime.to_uint64_ns
+       (Option.value ~default:Mtime.min_stamp (Mtime.sub_span now created_span)))
+    pp_fsm c.tcp_state (pp_control now) c.control_block
 
 module IS = Set.Make(struct type t = int let compare = compare_int end)
 
@@ -452,13 +459,13 @@ end
 
 (* path mtu (its global to a stack) *)
 type 'a t = {
-  rng : int -> Cstruct.t ;
+  rng : int -> string ;
   listeners : IS.t ;
   connections : 'a conn_state CM.t ;
   stats : Stats.t ;
   id : string ;
   mutable ctr : int ;
-  metrics : (string -> Metrics.field list, 'a conn_state CM.t * Stats.t -> Metrics.data) Metrics.src;
+  metrics : (string -> Metrics.field list, Mtime.t * 'a conn_state CM.t * Stats.t -> Metrics.data) Metrics.src;
   transitions : (string -> Metrics.field list, string -> Metrics.data) Metrics.src;
   mk_notify : unit -> 'a;
 }
@@ -468,6 +475,9 @@ module States = Map.Make (struct
     let compare a b = compare a b
   end)
 
+let src = Logs.Src.create "tcp.state" ~doc:"TCP state"
+module Log = (val Logs.src_log src : Logs.LOG)
+
 let metrics () =
   let tcp_states =
     [ Syn_sent ; Syn_received ; Established ; Close_wait ; Fin_wait_1 ;
@@ -476,9 +486,11 @@ let metrics () =
   in
   let open Metrics in
   let doc = "uTCP metrics" in
-  let data (connections, stats) =
+  let data (now, connections, stats) =
     let rcvq, sndq, states =
-      CM.fold (fun _ conn (rcvq, sndq, acc) ->
+      CM.fold (fun k conn (rcvq, sndq, acc) ->
+          if Mtime.(Span.to_uint64_ns (span now conn.created)) > Duration.of_min 1 then
+            Log.info (fun m -> m "%a in %a" Connection.pp k (pp_conn_state now) conn);
           rcvq + Cstruct.lenv conn.rcvq,
           sndq + Cstruct.lenv conn.sndq,
           States.update conn.tcp_state (fun v -> Some (succ (Option.value ~default:0 v))) acc)
@@ -502,8 +514,8 @@ let metrics () =
   let tag = Tags.string "stack-id" in
   Src.v ~doc ~tags:Tags.[ tag ] ~data "utcp"
 
-let add_metrics t =
-  Metrics.add t.metrics (fun x -> x t.id) (fun d -> d (t.connections, t.stats))
+let add_metrics t now =
+  Metrics.add t.metrics (fun x -> x t.id) (fun d -> d (now, t.connections, t.stats))
 
 let transitions () =
   let create () =
diff --git a/src/tcptimer.ml b/src/tcptimer.ml
@@ -180,7 +180,7 @@ let slow_timer t now =
 let timer t now =
   t.ctr <- succ t.ctr ;
   (* every 9.5 seconds, compute metrics *)
-  if t.ctr mod 95 = 0 then add_metrics t;
+  if t.ctr mod 95 = 0 then add_metrics t now;
   if t.ctr mod 2 = 0 then fast_timer t now
   else if t.ctr mod 5 = 0 then slow_timer t now
   else t, [], []
diff --git a/src/user.ml b/src/user.ml
@@ -35,7 +35,7 @@ let connect ~src ?src_port ~dst ~dst_port t now =
       t_advmss = advmss ;
       t_rttseg
     } in
-    conn_state t.mk_notify ~rcvbufsize:rcv_wnd ~sndbufsize:Params.so_sndbuf Syn_sent control_block
+    conn_state now t.mk_notify ~rcvbufsize:rcv_wnd ~sndbufsize:Params.so_sndbuf Syn_sent control_block
   in
   let _, _, seg = Segment.make_syn conn.control_block id in
   let connections =
diff --git a/src/utcp.mli b/src/utcp.mli
@@ -1,6 +1,6 @@
 type 'a state
 
-val empty : (unit -> 'a) -> string -> (int -> Cstruct.t) -> 'a state
+val empty : (unit -> 'a) -> string -> (int -> string) -> 'a state
 
 val start_listen : 'a state -> int -> 'a state
 
@@ -190,25 +190,26 @@ module State : sig
     sndq : Cstruct.t list ;
     rcv_notify : 'a;
     snd_notify : 'a;
+    created : Mtime.t;
   }
-  val conn_state : (unit -> 'a) -> rcvbufsize:int -> sndbufsize:int -> tcp_state ->
+  val conn_state : Mtime.t -> (unit -> 'a) -> rcvbufsize:int -> sndbufsize:int -> tcp_state ->
     control_block -> 'a conn_state
   module IS : Set.S with type elt = int
   module CM : Map.S with type key = flow
   module Stats : sig type t end
   type 'a t = {
-    rng : int -> Cstruct.t ;
+    rng : int -> string ;
     listeners : IS.t ;
     connections : 'a conn_state CM.t ;
     stats : Stats.t ;
     id : string ;
     mutable ctr : int ;
-    metrics : (string -> Metrics.field list, 'a conn_state CM.t * Stats.t -> Metrics.data) Metrics.src;
+    metrics : (string -> Metrics.field list, Mtime.t * 'a conn_state CM.t * Stats.t -> Metrics.data) Metrics.src;
     transitions : (string -> Metrics.field list, string -> Metrics.data) Metrics.src;
     mk_notify : unit -> 'a;
   }
   val pp : Mtime.t -> 'a t Fmt.t
-  val empty : (unit -> 'a) -> string -> (int -> Cstruct.t) -> 'a t
+  val empty : (unit -> 'a) -> string -> (int -> string) -> 'a t
   val start_listen : 'a t -> int -> 'a t
   val stop_listen : 'a t -> int -> 'a t
 end
diff --git a/test/state_machine.ml b/test/state_machine.ml
@@ -4,7 +4,7 @@ open Utcp
 
 (* generates the bit pattern 0b10100101 *)
 let static_rng y =
-  let b = Cstruct.create y in Cstruct.memset b 0xA5 ; b
+  Bytes.make y '\xA5' |> Bytes.unsafe_to_string
 
 let equal_rttinf a b =
   a.State.t_rttupdated = b.State.t_rttupdated &&
@@ -225,7 +225,7 @@ let listen =
              options = [ Segment.MaximumSegmentSize 1460 ] }
   in
   let tcp' =
-    let conn = State.conn_state (fun () -> ()) ~rcvbufsize:0 ~sndbufsize:0 Syn_received State.initial_cb in
+    let conn = State.conn_state Mtime.min_stamp (fun () -> ()) ~rcvbufsize:0 ~sndbufsize:0 Syn_received State.initial_cb in
     { tcp_listen with connections = State.CM.add quad conn tcp_listen.connections }
   in [
     tcp_listen, None ;
diff --git a/utcp.opam b/utcp.opam
@@ -4,6 +4,7 @@ authors: ["Robur <team@robur.coop>"]
 homepage: "https://github.com/robur-coop/utcp"
 dev-repo: "git+https://github.com/robur-coop/utcp.git"
 bug-reports: "https://github.com/robur-coop/utcp/issues"
+available: [ arch != "arm32" & arch != "x86_32" ] # see #35
 
 depends: [
   "ocaml" {>= "4.13.0"}
@@ -14,23 +15,23 @@ depends: [
   "ipaddr" {>= "5.2.0"}
   "ipaddr-cstruct" {>= "5.2.0"}
   "logs" {>= "0.7.0"}
-  "randomconv" {>= "0.1.3"}
-  "mtime" {>= "1.3.0"}
+  "randomconv" {>= "0.2.0"}
+  "mtime" {>= "1.4.0"}
   "metrics" {>= "0.4.1"}
   "base64" {>= "3.5.1"} #only used for tracing
   #for mirage sublibrary
   "lwt" {>= "5.4.2"}
-  "mirage-random" {>= "2.0.0"}
+  "mirage-crypto-rng-mirage" {>= "1.0.0"}
   "mirage-time" {>= "2.0.1"}
   "mirage-clock" {>= "3.1.0"}
   "tcpip" {>= "8.0.1"}
   "mirage-flow" {>= "4.0.0"}
   #for apps
+  "mirage-crypto-rng" {>= "1.0.0" & dev}
   "cmdliner" {>= "1.1.0" & dev}
   "mirage-net-unix" {>= "2.8.0" & dev}
   "ethernet" {>= "2.2.1" & dev}
   "arp" {>= "2.3.0" & dev}
-  "mirage-random-test" {dev}
   "mirage-unix" {>= "5.0.0" & dev}
   "mirage-clock-unix" {>= "3.1.0" & dev}
   "pcap-format" {>= "0.6.0" & dev}
